added support for subroutines in commands

Traditionally, a command is a piece of perl that is a simple
in line lump of code e.g (blank.pl):

		my ($self, $line) = @_;
		my $lines = 1;
		my $data = ' ';
		my @f = split /\s+/, $line;
		if (@f && $f[0] !~ /^\d+$/) {
			$data = shift @f;
			$data = $data x int(($self->width-1) / length($data));
			$data .= substr $data, 0, int(($self->width-1) % length($data))
		}
		if (@f && $f[0] =~ /^\d+$/) {
			$lines = shift @f;
			$lines = 9 if $lines > 9;
			$lines = 1 if $lines < 1;
		}
		my @out;
		push @out, $data for (1..$lines);
		return (1, @out);

It is now possible to have a 'handler' and any other code you like in
a command file, for instance (again blank.pl):

sub this {}

sub that {}

sub another {}

sub handle
{
		my ($self, $line) = @_;
		my $lines = 1;
		my $data = ' ';
		my @f = split /\s+/, $line;
		if (@f && $f[0] !~ /^\d+$/) {
			$data = shift @f;
			$data = $data x int(($self->width-1) / length($data));
			$data .= substr $data, 0, int(($self->width-1) % length($data))
		}
		if (@f && $f[0] =~ /^\d+$/) {
			$lines = shift @f;
			$lines = 9 if $lines > 9;
			$lines = 1 if $lines < 1;
		}
		my @out;
		push @out, $data for (1..$lines);
		return (1, @out);
}

The 'sub handle' being the cue that distiguishes one form from the other.

The first form has the 'sub handle { <code> }' wrapped around it so, internally
they are treated the same. Each command is placed in its own DXCommandmode sub
package with a standard set of packages "use"d in front of it.

For now (at least) any functions you declare are just that. "$self" is a DXCommandmode
not a blessed reference to this command's full package name, you cannot use things like

$self->this() or $self->that()

they must be called as local functions.

This may change in the future.

Conflicts:

	perl/DXChannel.pm
	perl/Version.pm

diff --git a/cmd/blank.pl b/cmd/blank.pl
index 5032edf0329c2c2d6216c2435a7e61c27314cff2..4a91b70fdc6374aa0cbd77fbc9b245b94748cf8f 100644 (file)
--- a/cmd/blank.pl
+++ b/cmd/blank.pl
@@ -6,20 +6,29 @@
 #
 #
 
 #
 #
 

-my ($self, $line) = @_;
-my $lines = 1;
-my $data = ' ';
-my @f = split /\s+/, $line;
-if (@f && $f[0] !~ /^\d+$/) {
-       $data = shift @f;
-       $data = $data x int(($self->width-1) / length($data));
-       $data .= substr $data, 0, int(($self->width-1) % length($data))
-}
-if (@f && $f[0] =~ /^\d+$/) {
-       $lines = shift @f;
-       $lines = 9 if $lines > 9;
-       $lines = 1 if $lines < 1;
+sub this {};
+
+sub that {};
+
+sub another {}
+
+sub handle
+{
+               my ($self, $line) = @_;
+               my $lines = 1;
+               my $data = ' ';
+               my @f = split /\s+/, $line;
+               if (@f && $f[0] !~ /^\d+$/) {
+                       $data = shift @f;
+                       $data = $data x int(($self->width-1) / length($data));
+                       $data .= substr $data, 0, int(($self->width-1) % length($data))
+               }
+               if (@f && $f[0] =~ /^\d+$/) {
+                       $lines = shift @f;
+                       $lines = 9 if $lines > 9;
+                       $lines = 1 if $lines < 1;
+               }
+               my @out;
+               push @out, $data for (1..$lines);
+               return (1, @out);

 }
 }

-my @out;
-push @out, $data for (1..$lines);
-return (1, @out);

diff --git a/perl/DXChannel.pm b/perl/DXChannel.pm
index 958fe61860b3cb69122df0101fe8741c6afcc805..a02edc9ee200c69c5624151dc52f4e278458cc7d 100644 (file)
--- a/perl/DXChannel.pm
+++ b/perl/DXChannel.pm
@@ -699,17 +699,14 @@ sub broadcast_list
 sub process
 {
        foreach my $dxchan (get_all()) {
 sub process
 {
        foreach my $dxchan (get_all()) {

-
+               next if $dxchan->{disconnecting};
+               

                while (my $data = shift @{$dxchan->{inqueue}}) {
                        my ($sort, $call, $line) = $dxchan->decode_input($data);
                        next unless defined $sort;
 
                        # do the really sexy console interface bit! (Who is going to do the TK interface then?)
                        dbg("<- $sort $call $line") if $sort ne 'D' && isdbg('chan');
                while (my $data = shift @{$dxchan->{inqueue}}) {
                        my ($sort, $call, $line) = $dxchan->decode_input($data);
                        next unless defined $sort;
 
                        # do the really sexy console interface bit! (Who is going to do the TK interface then?)
                        dbg("<- $sort $call $line") if $sort ne 'D' && isdbg('chan');

-                       if ($dxchan->{disconnecting}) {
-                               dbg('In disconnection, ignored');
-                               next;
-                       }

 
                        # handle A records
                        my $user = $dxchan->user;
 
                        # handle A records
                        my $user = $dxchan->user;

diff --git a/perl/DXCommandmode.pm b/perl/DXCommandmode.pm
index 798351773c998c62f603facd84c093c782873d34..0218aafefc8657655b25d98b7b75d9fa530b0685 100644 (file)
--- a/perl/DXCommandmode.pm
+++ b/perl/DXCommandmode.pm
@@ -51,7 +51,7 @@ $maxbadcount = 3;                             # no of bad words allowed before disconnection
 $msgpolltime = 3600;                   # the time between polls for new messages 
 $cmdimportdir = "$main::root/cmd_import"; # the base directory for importing command scripts 
                                           # this does not exist as default, you need to create it manually
 $msgpolltime = 3600;                   # the time between polls for new messages 
 $cmdimportdir = "$main::root/cmd_import"; # the base directory for importing command scripts 
                                           # this does not exist as default, you need to create it manually

-                                         #
+#

 
 #
 # obtain a new connection this is derived from dxchannel
 
 #
 # obtain a new connection this is derived from dxchannel


@@ -521,10 +521,10 @@ sub run_cmd
                        my $package = find_cmd_name($path, $fcmd);
                        return ($@) if $@;
                                
                        my $package = find_cmd_name($path, $fcmd);
                        return ($@) if $@;
                                

-                       if ($package && DXCommandmode->can($package)) {
+                       if ($package && $self->can("${package}::handle")) {

                                no strict 'refs';
                                dbg("cmd: package $package") if isdbg('command');
                                no strict 'refs';
                                dbg("cmd: package $package") if isdbg('command');

-                               eval { @ans = &$package($self, $args) };
+                               eval { @ans = &{"${package}::handle"}($self, $args) };

                                return (DXDebug::shortmess($@)) if $@;
                        } else {
                                dbg("cmd: $package not present") if isdbg('command');
                                return (DXDebug::shortmess($@)) if $@;
                        } else {
                                dbg("cmd: $package not present") if isdbg('command');


@@ -745,12 +745,14 @@ sub clear_cmd_cache
 {
        no strict 'refs';
        
 {
        no strict 'refs';
        

-       for (keys %Cache) {
-               undef *{$_} unless /cmd_cache/;
-               dbg("Undefining cmd $_") if isdbg('command');
+       for my $k (keys %Cache) {
+               unless ($k =~ /cmd_cache/) {
+                       dbg("Undefining cmd $k") if isdbg('command');
+                       undef $DXCommandmode::{"${k}::"};
+               }

        }
        %cmd_cache = ();
        }
        %cmd_cache = ();

-       %Cache = ();
+       %Cache = ( cmd_clear_cmd_cache  => $Cache{cmd_clear_cmd_cache} );

 }
 
 #
 }
 
 #


@@ -761,11 +763,10 @@ sub clear_cmd_cache
 # 
 # This has been nicked directly from the perlembed pages
 #
 # 
 # This has been nicked directly from the perlembed pages
 #

-

 #require Devel::Symdump;  
 
 sub valid_package_name {
 #require Devel::Symdump;  
 
 sub valid_package_name {

-       my($string) = @_;
+       my $string = shift;

        $string =~ s|([^A-Za-z0-9_/])|sprintf("_%2x",unpack("C",$1))|eg;
        
        $string =~ s|/|_|g;
        $string =~ s|([^A-Za-z0-9_/])|sprintf("_%2x",unpack("C",$1))|eg;
        
        $string =~ s|/|_|g;


@@ -788,7 +789,7 @@ sub find_cmd_name {
                return undef;
        }
        
                return undef;
        }
        

-       if(defined $Cache{$package}->{mtime} &&$Cache{$package}->{mtime} <= $mtime) {
+       if(exists $Cache{$package} && exists $Cache{$package}->{mtime} && $Cache{$package}->{mtime} <= $mtime) {

                #we have compiled this subroutine already,
                #it has not been updated on disk, nothing left to do
                #print STDERR "already compiled $package->handler\n";
                #we have compiled this subroutine already,
                #it has not been updated on disk, nothing left to do
                #print STDERR "already compiled $package->handler\n";


@@ -802,7 +803,14 @@ sub find_cmd_name {
                };
                
                #wrap the code into a subroutine inside our unique package
                };
                
                #wrap the code into a subroutine inside our unique package

-               my $eval = qq( sub $package { $sub } );
+               my $eval = qq(package DXCommandmode::$package; use POSIX qw{:math_h}; use DXLog; use DXDebug; use DXUser; use DXUtil; use Minimuf; use Sun; our \@ISA = qw{DXCommandmode}; );
+
+
+               if ($sub =~ m|\s*sub\s+handle\n|) {
+                       $eval .= $sub;
+               } else {
+                       $eval .= qq(sub handle { $sub });
+               }

                
                if (isdbg('eval')) {
                        my @list = split /\n/, $eval;
                
                if (isdbg('eval')) {
                        my @list = split /\n/, $eval;


@@ -817,7 +825,8 @@ sub find_cmd_name {
 
                if (exists $Cache{$package}) {
                        dbg("find_cmd_name: Redefining $package") if isdbg('command');
 
                if (exists $Cache{$package}) {
                        dbg("find_cmd_name: Redefining $package") if isdbg('command');

-                       undef *$package;
+                       undef $DXCommandmode::{"${package}::"};
+                       delete $Cache{$package};

                } else {
                        dbg("find_cmd_name: Defining $package") if isdbg('command');
                }
                } else {
                        dbg("find_cmd_name: Defining $package") if isdbg('command');
                }


@@ -825,10 +834,9 @@ sub find_cmd_name {
                eval $eval;
 
                $Cache{$package} = {mtime => $mtime } unless $@;
                eval $eval;
 
                $Cache{$package} = {mtime => $mtime } unless $@;

-           

        }
 
        }
 

-       return $package;
+       return "DXCommandmode::$package";

 }
 
 sub send
 }
 
 sub send

diff --git a/perl/DXUtil.pm b/perl/DXUtil.pm
index 14819ad1b146446d6bbe5ca36088bbfc4728cf6d..4e442140b82e9394422492bc639f5d3fd6ed8903 100644 (file)
--- a/perl/DXUtil.pm
+++ b/perl/DXUtil.pm
@@ -15,7 +15,7 @@ use Data::Dumper;
 
 use strict;
 
 
 use strict;
 

-use vars qw(@month %patmap @ISA @EXPORT);
+use vars qw(@month %patmap $pi $d2r $r2d @ISA @EXPORT);

 
 require Exporter;
 @ISA = qw(Exporter);
 
 require Exporter;
 @ISA = qw(Exporter);


@@ -24,7 +24,7 @@ require Exporter;
                         filecopy ptimelist
              print_all_fields cltounix unpad is_callsign is_long_callsign is_latlong
                         is_qra is_freq is_digits is_pctext is_pcflag insertitem deleteitem
                         filecopy ptimelist
              print_all_fields cltounix unpad is_callsign is_long_callsign is_latlong
                         is_qra is_freq is_digits is_pctext is_pcflag insertitem deleteitem

-                        is_prefix dd is_ipaddr
+                        is_prefix dd is_ipaddr $pi $d2r $r2d

             );
 
 
             );
 
 


@@ -36,6 +36,11 @@ require Exporter;
                   ']' => ']'
 );
 
                   ']' => ']'
 );
 

+$pi = 3.141592653589;
+$d2r = ($pi/180);
+$r2d = (180/$pi);
+
+

 # a full time for logging and other purposes
 sub atime
 {
 # a full time for logging and other purposes
 sub atime
 {

diff --git a/perl/Sun.pm b/perl/Sun.pm
index aaf85a33eeb18e569f00bdf2309afa28c717ef70..5190db184e58c2d311ce5ddf60ac3abd9d0a2873 100644 (file)
--- a/perl/Sun.pm
+++ b/perl/Sun.pm
@@ -33,12 +33,6 @@ require Exporter;
 
 use strict;
 
 
 use strict;
 

-use vars qw($pi $d2r $r2d);
- 
-$pi = 3.141592653589;
-$d2r = ($pi/180);
-$r2d = (180/$pi);
-

 use vars qw(%keps);
 use Keps;
 use DXVars;
 use vars qw(%keps);
 use Keps;
 use DXVars;

diff --git a/perl/Version.pm b/perl/Version.pm
index 99d8fc26c28b046f20cabf0cb9444c6607546b17..ba3dacd9412d41bbcb9a20fbdeec6603fd001f73 100644 (file)
--- a/perl/Version.pm
+++ b/perl/Version.pm
@@ -11,7 +11,7 @@ use vars qw($version $subversion $build $gitversion);
 
 $version = '1.55';
 $subversion = '0';
 
 $version = '1.55';
 $subversion = '0';

-$build = '115';
-$gitversion = '2321d9d';
+$build = '123';
+$gitversion = 'f67292b';

 
 1;
 
 1;