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.

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 517372fa9446b49aba4799c3528483dddb203381..8384567003685d54e1a5dfe155095e2a91e573db 100644 (file)
--- a/perl/DXChannel.pm
+++ b/perl/DXChannel.pm
@@ -707,17 +707,15 @@ sub broadcast_list
 sub process
 {
        foreach my $dxchan (values %channels) {
-
+               
+               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');
-                       if ($dxchan->{disconnecting}) {
-                               dbg('In disconnection, ignored');
-                               next;
-                       }
 
                        # handle A records
                        my $user = $dxchan->user;

diff --git a/perl/DXCommandmode.pm b/perl/DXCommandmode.pm
index be9d652f12aa6c4a06b8eb6eb0d2edde5d0de79d..d0af6bbb228b0d4954b1c1fa0e0ddcc7fbaed4f9 100644 (file)
--- a/perl/DXCommandmode.pm
+++ b/perl/DXCommandmode.pm
@@ -54,7 +54,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
-                                         #
+#
 
 #
 # obtain a new connection this is derived from dxchannel
@@ -524,10 +524,10 @@ sub run_cmd
                        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');
-                               eval { @ans = &$package($self, $args) };
+                               eval { @ans = &{"${package}::handle"}($self, $args) };
                                return (DXDebug::shortmess($@)) if $@;
                        } else {
                                dbg("cmd: $package not present") if isdbg('command');
@@ -748,12 +748,14 @@ sub clear_cmd_cache
 {
        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 = ();
-       %Cache = ();
+       %Cache = ( cmd_clear_cmd_cache  => $Cache{cmd_clear_cmd_cache} );
 }
 
 #
@@ -764,11 +766,10 @@ sub clear_cmd_cache
 # 
 # This has been nicked directly from the perlembed pages
 #
-
 #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;
@@ -791,7 +792,7 @@ sub find_cmd_name {
                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";
@@ -805,7 +806,14 @@ sub find_cmd_name {
                };
                
                #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;
@@ -820,7 +828,8 @@ sub find_cmd_name {
 
                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');
                }
@@ -828,10 +837,9 @@ sub find_cmd_name {
                eval $eval;
 
                $Cache{$package} = {mtime => $mtime } unless $@;
-           
        }
 
-       return $package;
+       return "DXCommandmode::$package";
 }
 
 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 vars qw(@month %patmap @ISA @EXPORT);
+use vars qw(@month %patmap $pi $d2r $r2d @ISA @EXPORT);
 
 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
-                        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
 {

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 vars qw($pi $d2r $r2d);
- 
-$pi = 3.141592653589;
-$d2r = ($pi/180);
-$r2d = (180/$pi);
-
 use vars qw(%keps);
 use Keps;
 use DXVars;

diff --git a/perl/Version.pm b/perl/Version.pm
index 1fe16bbc9472fdaca0040ff1c4309053265f1623..ca438058c3cb7bd39658ee8423eaab67f40b74b4 100644 (file)
--- a/perl/Version.pm
+++ b/perl/Version.pm
@@ -11,7 +11,7 @@ use vars qw($version $subversion $build $gitversion);
 
 $version = '1.56';
 $subversion = '0';
-$build = '17';
-$gitversion = '281b5d6';
+$build = '19';
+$gitversion = '6d73d85';
 
 1;