added support for subroutines in commands

[spider.git] / perl / DXCommandmode.pm

diff --git a/perl/DXCommandmode.pm b/perl/DXCommandmode.pm
index 87182fc69f08b44218f9f8fb2e9b29251469280d..d0af6bbb228b0d4954b1c1fa0e0ddcc7fbaed4f9 100644 (file)
--- a/perl/DXCommandmode.pm
+++ b/perl/DXCommandmode.pm
@@ -13,6 +13,10 @@ package DXCommandmode;
 
 @ISA = qw(DXChannel);
 
+use AnyEvent;
+use AnyEvent::Handle;
+use AnyEvent::Socket;
+
 use POSIX qw(:math_h);
 use DXUtil;
 use DXChannel;
@@ -32,7 +36,6 @@ use WCY;
 use Sun;
 use Internet;
 use Script;
-use Net::Telnet;
 use QSL;
 use DB_File;
 use VE7CC;
@@ -51,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
@@ -521,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');
@@ -745,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} );
 }
 
 #
@@ -761,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;
@@ -788,11 +792,11 @@ 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";
-               ;
+               dbg("find_cmd_name: $package cached") if isdbg('command');
        } else {
 
                my $sub = readfilestr($filename);
@@ -802,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;
@@ -817,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');
                }
@@ -825,10 +837,9 @@ sub find_cmd_name {
                eval $eval;
 
                $Cache{$package} = {mtime => $mtime } unless $@;
-           
        }
 
-       return $package;
+       return "DXCommandmode::$package";
 }
 
 sub send
@@ -1224,7 +1235,7 @@ sub send_motd
        }
        $motd = "${main::motd}_$self->{lang}" unless $motd && -e $motd;
        $motd = $main::motd unless $motd && -e $motd;
-       if ($self->conn->{csort} eq 'ax25') {
+       if ($self->conn->ax25) {
                if ($motd) {
                        $motd = "${motd}_ax25" if -e "${motd}_ax25";
                } else {
@@ -1233,5 +1244,50 @@ sub send_motd
        }
        $self->send_file($motd) if -e $motd;
 }
+
+sub http_get
+{
+       my $self = shift;
+       my ($host, $uri, $cb) = @_;
+
+       # store results here
+       my ($response, $header, $body);
+
+       my $handle;
+       $handle = AnyEvent::Handle->new(
+                                                                       connect  => [$host => 'http'],
+                                                                       on_error => sub {
+                                                                               $cb->("HTTP/1.0 500 $!");
+                                                                               $self->anyevent_del($handle);
+                                                                               $handle->destroy; # explicitly destroy handle
+                                                                       },
+                                                                       on_eof   => sub {
+                                                                               $cb->($response, $header, $body);
+                                                                               $self->anyevent_del($handle);
+                                                                               $handle->destroy; # explicitly destroy handle
+                                                                       }
+                                                                  );
+       $self->anyevent_add($handle);
+       $handle->push_write ("GET $uri HTTP/1.0\015\012\015\012");
+
+       # now fetch response status line
+       $handle->push_read (line => sub {
+                                                       my ($handle, $line) = @_;
+                                                       $response = $line;
+                                               });
+
+       # then the headers
+       $handle->push_read (line => "\015\012\015\012", sub {
+                                                       my ($handle, $line) = @_;
+                                                       $header = $line;
+                                               });
+
+       # and finally handle any remaining data as body
+       $handle->on_read (sub {
+                                                 $body .= $_[0]->rbuf;
+                                                 $_[0]->rbuf = "";
+                                         });
+}
+
 1;
 __END__