From 85eea0e7a1a773e5da2422bd1b5ff77951f24e77 Mon Sep 17 00:00:00 2001 From: Dirk Koopman Date: Sun, 29 Jan 2012 18:02:02 +0000 Subject: [PATCH] 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 { }' 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. --- cmd/blank.pl | 41 +++++++++++++++++++++++++---------------- perl/DXChannel.pm | 8 +++----- perl/DXCommandmode.pm | 36 ++++++++++++++++++++++-------------- perl/DXUtil.pm | 9 +++++++-- perl/Sun.pm | 6 ------ perl/Version.pm | 4 ++-- 6 files changed, 59 insertions(+), 45 deletions(-) diff --git a/cmd/blank.pl b/cmd/blank.pl index 5032edf0..4a91b70f 100644 --- 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 517372fa..83845670 100644 --- 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 be9d652f..d0af6bbb 100644 --- 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 14819ad1..4e442140 100644 --- 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 aaf85a33..5190db18 100644 --- 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 1fe16bbc..ca438058 100644 --- 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; -- 2.43.0