fix free talking in command mode
[spider.git] / perl / DXCommandmode.pm
index 7b69ad22c1b17d4e462f588b196418e5121c04d0..71efaef733d2db6d0c0f68b51384bb74d0b87535 100644 (file)
@@ -9,10 +9,11 @@
 
 package DXCommandmode;
 
-use POSIX;
+#use POSIX;
 
 @ISA = qw(DXChannel);
 
+use POSIX qw(:math_h);
 use DXUtil;
 use DXChannel;
 use DXUser;
@@ -35,9 +36,11 @@ use Net::Telnet;
 use QSL;
 use DB_File;
 use VE7CC;
+use DXXml;
 
 use strict;
-use vars qw(%Cache %cmd_cache $errstr %aliases $scriptbase $maxerrors %nothereslug $maxbadcount $msgpolltime);
+use vars qw(%Cache %cmd_cache $errstr %aliases $scriptbase $maxerrors %nothereslug
+       $maxbadcount $msgpolltime $default_pagelth $cmdimportdir);
 
 %Cache = ();                                   # cache of dynamically loaded routine's mod times
 %cmd_cache = ();                               # cache of short names
@@ -47,13 +50,12 @@ $scriptbase = "$main::root/scripts"; # the place where all users start scripts g
 $maxerrors = 20;                               # the maximum number of concurrent errors allowed before disconnection
 $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
+                                         #
 
 use vars qw($VERSION $BRANCH);
-$VERSION = sprintf( "%d.%03d", q$Revision$ =~ /(\d+)\.(\d+)/ );
-$BRANCH = sprintf( "%d.%03d", q$Revision$ =~ /\d+\.\d+\.(\d+)\.(\d+)/  || (0,0));
-$main::build += $VERSION;
-$main::branch += $BRANCH;
+($VERSION, $BRANCH) = dxver(q$Revision$);
 
 #
 # obtain a new connection this is derived from dxchannel
@@ -70,7 +72,10 @@ sub new
 
        # ALWAYS output the user
        my $ref = Route::User::get($call);
-       $main::me->route_pc16($main::mycall, undef, $main::routeroot, $ref) if $ref;
+       if ($ref) {
+               $main::me->route_pc16($main::mycall, undef, $main::routeroot, $ref);
+               $main::me->route_pc92a($main::mycall, undef, $main::routeroot, $ref);
+       }
 
        return $self;
 }
@@ -87,15 +92,19 @@ sub start
        my $name = $user->{name};
        
        # log it
-       my $host = $self->{conn}->{peerhost} || "unknown";
-       Log('DXCommand', "$call connected from $host");
+       my $host = $self->{conn}->{peerhost};
+       $host ||= "AGW Port #$self->{conn}->{agwport}" if exists $self->{conn}->{agwport};
+       $host ||= "unknown";
+       LogDbg('DXCommand', "$call connected from $host");
 
        $self->{name} = $name ? $name : $call;
        $self->send($self->msg('l2',$self->{name}));
        $self->state('prompt');         # a bit of room for further expansion, passwords etc
        $self->{priv} = $user->priv || 0;
        $self->{lang} = $user->lang || $main::lang || 'en';
-       $self->{pagelth} = $user->pagelth || 20;
+       my $pagelth = $user->pagelth;
+       $pagelth = $default_pagelth unless defined $pagelth;
+       $self->{pagelth} = $pagelth;
        ($self->{width}) = $line =~ /width=(\d+)/; $line =~ s/\s*width=\d+\s*//;
        $self->{width} = 80 unless $self->{width} && $self->{width} > 80;
        $self->{consort} = $line;       # save the connection type
@@ -129,7 +138,12 @@ sub start
 
 
        # decide which motd to send
-       my $motd = "${main::motd}_nor" unless $self->{registered};
+       my $motd;
+       unless ($self->{registered}) {
+               $motd = "${main::motd}_nor_$self->{lang}";
+               $motd = "${main::motd}_nor" unless -e $motd;
+       }
+       $motd = "${main::motd}_$self->{lang}" unless $motd && -e $motd;
        $motd = $main::motd unless $motd && -e $motd;
        $self->send_file($motd) if -e $motd;
 
@@ -137,10 +151,21 @@ sub start
        $self->{priv} = 0 if $line =~ /^(ax|te)/ && !$self->conn->{usedpasswd};
 
        # get the filters
-       $self->{spotsfilter} = Filter::read_in('spots', $call, 0) || Filter::read_in('spots', 'user_default', 0);
-       $self->{wwvfilter} = Filter::read_in('wwv', $call, 0) || Filter::read_in('wwv', 'user_default', 0);
-       $self->{wcyfilter} = Filter::read_in('wcy', $call, 0) || Filter::read_in('wcy', 'user_default', 0);
-       $self->{annfilter} = Filter::read_in('ann', $call, 0) || Filter::read_in('ann', 'user_default', 0) ;
+       my $nossid = $call;
+       $nossid =~ s/-\d+$//;
+       
+       $self->{spotsfilter} = Filter::read_in('spots', $call, 0) 
+               || Filter::read_in('spots', $nossid, 0)
+                       || Filter::read_in('spots', 'user_default', 0);
+       $self->{wwvfilter} = Filter::read_in('wwv', $call, 0) 
+               || Filter::read_in('wwv', $nossid, 0) 
+                       || Filter::read_in('wwv', 'user_default', 0);
+       $self->{wcyfilter} = Filter::read_in('wcy', $call, 0) 
+               || Filter::read_in('wcy', $nossid, 0) 
+                       || Filter::read_in('wcy', 'user_default', 0);
+       $self->{annfilter} = Filter::read_in('ann', $call, 0) 
+               || Filter::read_in('ann', $nossid, 0) 
+                       || Filter::read_in('ann', 'user_default', 0) ;
 
        # clean up qra locators
        my $qra = $user->qra;
@@ -160,6 +185,7 @@ sub start
        }
        
        $self->tell_login('loginu');
+       $self->tell_buddies('loginb');
        
        # do we need to send a forward/opernam?
        my $lastoper = $user->lastoper || 0;
@@ -177,12 +203,23 @@ sub start
        my $info = Route::cluster();
        $self->send("Cluster:$info");
 
-       # send prompts and things
+       # send prompts for qth, name and things
        $self->send($self->msg('namee1')) if !$user->name;
        $self->send($self->msg('qthe1')) if !$user->qth;
        $self->send($self->msg('qll')) if !$user->qra || (!$user->lat && !$user->long);
        $self->send($self->msg('hnodee1')) if !$user->qth;
        $self->send($self->msg('m9')) if DXMsg::for_me($call);
+
+       # send out any buddy messages for other people that are online
+       foreach my $call (@{$user->buddies}) {
+               my $ref = Route::User::get($call);
+               if ($ref) {
+                       foreach my $node (@{$ref->parent}) {
+                               $self->send($self->msg($node eq $main::mycall ? 'loginb' : 'loginbn', $call, $node));
+                       } 
+               }
+       }
+
        $self->lastmsgpoll($main::systime);
        $self->prompt;
 }
@@ -285,7 +322,7 @@ sub normal
                                        my @bad;
                                        if (@bad = BadWords::check($l)) {
                                                $self->badcount(($self->badcount||0) + @bad);
-                                               Log('DXCommand', "$self->{call} swore: $l");
+                                               LogDbg('DXCommand', "$self->{call} swore: $l with words:" . join(',', @bad) . ")");
                                        } else {
                                                for (@{$self->{talklist}}) {
                                                        $self->send_talks($_, $l);
@@ -299,7 +336,7 @@ sub normal
                        my @bad;
                        if (@bad = BadWords::check($cmdline)) {
                                $self->badcount(($self->badcount||0) + @bad);
-                               Log('DXCommand', "$self->{call} swore: $cmdline");
+                               LogDbg('DXCommand', "$self->{call} swore: $cmdline with words:" . join(',', @bad) . ")");
                        } else {
                                for (@{$self->{talklist}}) {
                                        $self->send_talks($_, $rawline);
@@ -331,7 +368,7 @@ sub normal
 
        # check for excessive swearing
        if ($self->{badcount} && $self->{badcount} >= $maxbadcount) {
-               Log('DXCommand', "$self->{call} logged out for excessive swearing");
+               LogDbg('DXCommand', "$self->{call} logged out for excessive swearing");
                $self->disconnect;
                return;
        }
@@ -347,11 +384,11 @@ sub send_talks
        
        my ($to, $via) = $ent =~ /(\S+)>(\S+)/;
        $to = $ent unless $to;
-       my $call = $via ? $via : $to;
+       my $call = $via && $via ne '*' ? $via : $to;
        my $clref = Route::get($call);
        my $dxchan = $clref->dxchan if $clref;
        if ($dxchan) {
-               $dxchan->talk($self->{call}, $to, $via, $line);
+               $dxchan->talk($self->{call}, $to, undef, $line);
        } else {
                $self->send($self->msg('disc2', $via ? $via : $to));
                my @l = grep { $_ ne $ent } @{$self->{talklist}};
@@ -420,7 +457,8 @@ sub run_cmd
        
 
        return () if length $cmdline == 0;
-               
+       
+       
        # split the command line up into parts, the first part is the command
        my ($cmd, $args) = split /\s+/, $cmdline, 2;
        $args = "" unless defined $args;
@@ -428,6 +466,8 @@ sub run_cmd
        if ($cmd) {
                # strip out // on command only
                $cmd =~ s|//|/|g;
+               $cmd =~ s|^/||g;                # no leading / either
+               $cmd =~ s|[^-?\w/]||g;          # and no funny characters either
                                        
                my ($path, $fcmd);
                        
@@ -443,7 +483,7 @@ sub run_cmd
                        
                # first expand out the entry to a command
                ($path, $fcmd) = search($main::localcmd, $cmd, "pl");
-               ($path, $fcmd) = search($main::cmd, $cmd, "pl") if !$path || !$fcmd;
+               ($path, $fcmd) = search($main::cmd, $cmd, "pl") unless $path && $fcmd;
 
                if ($path && $cmd) {
                        dbg("path: $cmd cmd: $fcmd") if isdbg('command');
@@ -489,7 +529,7 @@ sub run_cmd
 sub process
 {
        my $t = time;
-       my @dxchan = DXChannel->get_all();
+       my @dxchan = DXChannel::get_all();
        my $dxchan;
        
        foreach $dxchan (@dxchan) {
@@ -513,6 +553,8 @@ sub process
                        delete $nothereslug{$k};
                }
        }
+
+       import_cmd();
 }
 
 #
@@ -535,6 +577,7 @@ sub disconnect
 
                # issue a pc17 to everybody interested
                $main::me->route_pc17($main::mycall, undef, $main::routeroot, $uref);
+               $main::me->route_pc92d($main::mycall, undef, $main::routeroot, $uref);
        } else {
                confess "trying to disconnect a non existant user $call";
        }
@@ -544,8 +587,9 @@ sub disconnect
                
        # send info to all logged in thingies
        $self->tell_login('logoutu');
+       $self->tell_buddies('logoutb');
 
-       Log('DXCommand', "$call disconnected");
+       LogDbg('DXCommand', "$call disconnected");
 
        $self->SUPER::disconnect;
 }
@@ -557,6 +601,9 @@ sub disconnect
 sub prompt
 {
        my $self = shift;
+
+       return if $self->{gtk};         # 'cos prompts are not a concept that applies here
+       
        my $call = $self->call;
        my $date = cldate($main::systime);
        my $time = ztime($main::systime);
@@ -577,7 +624,7 @@ sub broadcast
        my $pkg = shift;                        # ignored
        my $s = shift;                          # the line to be rebroadcast
        
-    foreach my $dxchan (DXChannel->get_all()) {
+    foreach my $dxchan (DXChannel::get_all()) {
                next unless $dxchan->{sort} eq 'U'; # only interested in user channels  
                next if grep $dxchan == $_, @_;
                $dxchan->send($s);                      # send it
@@ -587,7 +634,7 @@ sub broadcast
 # gimme all the users
 sub get_all
 {
-       return grep {$_->{sort} eq 'U'} DXChannel->get_all();
+       return grep {$_->{sort} eq 'U'} DXChannel::get_all();
 }
 
 # run a script for this user
@@ -625,40 +672,42 @@ sub search
        my @parts = split '/', $short_cmd;
        my $dirfn;
        my $curdir = $path;
-       my $p;
-       my $i;
-       my @lparts;
-       
-       for ($i = 0; $i < @parts; $i++) {
-               my  $p = $parts[$i];
-               opendir(D, $curdir) or confess "can't open $curdir $!";
-               my @ls = readdir D;
-               closedir D;
-               my $l;
-               foreach $l (sort @ls) {
-                       next if $l =~ /^\./;
-                       if ($i < $#parts) {             # we are dealing with directories
-                               if ((-d "$curdir/$l") && $p eq substr($l, 0, length $p)) {
-                                       dbg("got dir: $curdir/$l\n") if isdbg('command');
-                                       $dirfn .= "$l/";
-                                       $curdir .= "/$l";
-                                       last;
-                               }
-                       } else {                        # we are dealing with commands
-                               @lparts = split /\./, $l;                  
-                               next if $lparts[$#lparts] ne $suffix;        # only look for .$suffix files
-                               if ($p eq substr($l, 0, length $p)) {
-                                       pop @lparts; #  remove the suffix
-                                       $l = join '.', @lparts;
-                                       #                 chop $dirfn;               # remove trailing /
-                                       $dirfn = "" unless $dirfn;
-                                       $cmd_cache{$short_cmd} = join(',', ($path, "$dirfn$l")); # cache it
-                                       dbg("got path: $path cmd: $dirfn$l\n") if isdbg('command');
-                                       return ($path, "$dirfn$l"); 
-                               }
-                       }
-               }
-       }
+       
+        while (my $p = shift @parts) {
+                opendir(D, $curdir) or confess "can't open $curdir $!";
+                my @ls = readdir D;
+                closedir D;
+
+                # if this isn't the last part
+                if (@parts) {
+                        my $found;
+                        foreach my $l (sort @ls) {
+                                next if $l =~ /^\./;
+                                if ((-d "$curdir/$l") && $p eq substr($l, 0, length $p)) {
+                                        dbg("got dir: $curdir/$l\n") if isdbg('command');
+                                        $dirfn .= "$l/";
+                                        $curdir .= "/$l";
+                                        $found++;
+                                        last;
+                                }
+                        }
+                        # only proceed if we find the directory asked for
+                        return () unless $found;
+                } else {
+                        foreach my $l (sort @ls) {
+                                next if $l =~ /^\./;
+                                next unless $l =~ /\.$suffix$/;
+                                if ($p eq substr($l, 0, length $p)) {
+                                        $l =~ s/\.$suffix$//;
+                                        $dirfn = "" unless $dirfn;
+                                        $cmd_cache{$short_cmd} = join(',', ($path, "$dirfn$l")); # cache it
+                                        dbg("got path: $path cmd: $dirfn$l\n") if isdbg('command');
+                                        return ($path, "$dirfn$l");
+                                }
+                        }
+                }
+        }
+
        return ();  
 }  
 
@@ -752,6 +801,18 @@ sub find_cmd_name {
        return $package;
 }
 
+sub send
+{
+       my $self = shift;
+       if ($self->{gtk}) {
+               for (@_) {
+                       $self->SUPER::send(dd(['cmd',$_]));
+               }
+       } else {
+               $self->SUPER::send(@_);
+       }
+}
+
 sub local_send
 {
        my ($self, $let, $buf) = @_;
@@ -771,7 +832,13 @@ sub talk
 {
        my ($self, $from, $to, $via, $line) = @_;
        $line =~ s/\\5E/\^/g;
-       $self->local_send('T', "$to de $from: $line") if $self->{talk};
+       if ($self->{talk}) {
+               if ($self->{gtk}) {
+                       $self->local_send('T', dd(['talk',$to,$from,$via,$line]));
+               } else {
+                       $self->local_send('T', "$to de $from: $line");
+               }
+       }
        Log('talk', $to, $from, $via?$via:$main::mycall, $line);
        # send a 'not here' message if required
        unless ($self->{here} && $from ne $to) {
@@ -813,9 +880,14 @@ sub announce
                return if $_[0] ne $main::myalias && $_[0] ne $main::mycall;
        }
        return if $target eq 'SYSOP' && $self->{priv} < 5;
-       my $buf = "$to$target de $_[0]: $text";
-       $buf =~ s/\%5E/^/g;
-       $buf .= "\a\a" if $self->{beep};
+       my $buf;
+       if ($self->{gtk}) {
+               $buf = dd(['ann', $to, $target, $text, @_])
+       } else {
+               $buf = "$to$target de $_[0]: $text";
+               $buf =~ s/\%5E/^/g;
+               $buf .= "\a\a" if $self->{beep};
+       }
        $self->local_send($target eq 'WX' ? 'W' : 'N', $buf);
 }
 
@@ -833,9 +905,14 @@ sub chat
        return unless grep uc $_ eq $target, @{$self->{user}->{group}};
        
        $text =~ s/^\#\d+ //;
-       my $buf = "$target de $_[0]: $text";
-       $buf =~ s/\%5E/^/g;
-       $buf .= "\a\a" if $self->{beep};
+       my $buf;
+       if ($self->{gtk}) {
+               $buf = dd(['chat', $to, $target, $text, @_])
+       } else {
+               $buf = "$target de $_[0]: $text";
+               $buf =~ s/\%5E/^/g;
+               $buf .= "\a\a" if $self->{beep};
+       }
        $self->local_send('C', $buf);
 }
 
@@ -890,6 +967,24 @@ sub dx_spot
        my $buf;
        if ($self->{ve7cc}) {
                $buf = VE7CC::dx_spot($self, @_);
+       } elsif ($self->{gtk}) {
+               my ($dxloc, $byloc);
+
+               my $ref = DXUser->get_current($_[4]);
+               if ($ref) {
+                       $byloc = $ref->qra;
+                       $byloc = substr($byloc, 0, 4) if $byloc;
+               }
+
+               my $spot = $_[1];
+               $spot =~ s|/\w{1,4}$||;
+               $ref = DXUser->get_current($spot);
+               if ($ref) {
+                       $dxloc = $ref->qra;
+                       $dxloc = substr($dxloc, 0, 4) if $dxloc;
+               }
+               $buf = dd(['dx', @_, ($dxloc||''), ($byloc||'')]);
+               
        } else {
                $buf = $self->format_dx_spot(@_);
                $buf .= "\a\a" if $self->{beep};
@@ -909,12 +1004,18 @@ sub wwv
        return unless $self->{wwv};
        
        if ($self->{wwvfilter}) {
-               ($filter, $hops) = $self->{wwvfilter}->it(@_ );
+               ($filter, $hops) = $self->{wwvfilter}->it(@_[7..$#_] );
                return unless $filter;
        }
 
-       my $buf = "WWV de $_[6] <$_[1]>:   SFI=$_[2], A=$_[3], K=$_[4], $_[5]";
-       $buf .= "\a\a" if $self->{beep};
+       my $buf;
+       if ($self->{gtk}) {
+               $buf = dd(['wwv', @_])
+       } else {
+               $buf = "WWV de $_[6] <$_[1]>:   SFI=$_[2], A=$_[3], K=$_[4], $_[5]";
+               $buf .= "\a\a" if $self->{beep};
+       }
+       
        $self->local_send('V', $buf);
 }
 
@@ -932,8 +1033,13 @@ sub wcy
                return unless $filter;
        }
 
-       my $buf = "WCY de $_[10] <$_[1]> : K=$_[4] expK=$_[5] A=$_[3] R=$_[6] SFI=$_[2] SA=$_[7] GMF=$_[8] Au=$_[9]";
-       $buf .= "\a\a" if $self->{beep};
+       my $buf;
+       if ($self->{gtk}) {
+               $buf = dd(['wcy', @_])
+       } else {
+               $buf = "WCY de $_[10] <$_[1]> : K=$_[4] expK=$_[5] A=$_[3] R=$_[6] SFI=$_[2] SA=$_[7] GMF=$_[8] Au=$_[9]";
+               $buf .= "\a\a" if $self->{beep};
+       }
        $self->local_send('Y', $buf);
 }
 
@@ -942,9 +1048,13 @@ sub broadcast_debug
 {
        my $s = shift;                          # the line to be rebroadcast
        
-       foreach my $dxchan (DXChannel->get_all) {
+       foreach my $dxchan (DXChannel::get_all) {
                next unless $dxchan->{enhanced} && $dxchan->{senddbg};
-               $dxchan->send_later('L', $s);
+               if ($dxchan->{gtk}) {
+                       $dxchan->send_later('L', dd(['db', $s]));
+               } else {
+                       $dxchan->send_later('L', $s);
+               }
        }
 }
 
@@ -958,7 +1068,7 @@ sub do_entry_stuff
                my $loc = $self->{loc} || confess "local var gone missing" ;
                if ($line eq "\032" || $line eq '%1A' || uc $line eq "/EX") {
                        no strict 'refs';
-                       push @out, $loc->{endaction}($self);
+                       push @out, &{$loc->{endaction}}($self);          # like this for < 5.8.0
                        $self->func(undef);
                        $self->state('prompt');
                } elsif ($line eq "\031" || uc $line eq "/ABORT" || uc $line eq "/QUIT") {
@@ -997,5 +1107,79 @@ sub store_startup_script
        return @out;
 }
 
+# Import any commands contained in any files in import_cmd directory
+#
+# If the filename has a recogisable callsign as some delimited part
+# of it, then this is the user the command will be run as. 
+#
+sub import_cmd
+{
+       # are there any to do in this directory?
+       return unless -d $cmdimportdir;
+       unless (opendir(DIR, $cmdimportdir)) {
+               LogDbg('err', "can\'t open $cmdimportdir $!");
+               return;
+       } 
+
+       my @names = readdir(DIR);
+       closedir(DIR);
+       my $name;
+       foreach $name (@names) {
+               next if $name =~ /^\./;
+
+               my $s = Script->new($name, $cmdimportdir);
+               if ($s) {
+                       LogDbg('DXCommand', "Run import cmd file $name");
+                       my @cat = split /[^A-Za-z0-9]+/, $name;
+                       my ($call) = grep {is_callsign(uc $_)} @cat;
+                       $call ||= $main::mycall;
+                       $call = uc $call;
+                       my @out;
+                       
+                       
+                       $s->inscript(0);        # switch off script checks
+                       
+                       if ($call eq $main::mycall) {
+                               @out = $s->run($main::me, 1);
+                       } else {
+                               my $dxchan = DXChannel::get($call);
+                           if ($dxchan) {
+                                       @out = $s->run($dxchan, 1);
+                               } else {
+                                       my $u = DXUser->get($call);
+                                       if ($u) {
+                                               $dxchan = $main::me;
+                                               my $old = $dxchan->{call};
+                                               my $priv = $dxchan->{priv};
+                                               my $user = $dxchan->{user};
+                                               $dxchan->{call} = $call;
+                                               $dxchan->{priv} = $u->priv;
+                                               $dxchan->{user} = $u;
+                                               @out = $s->run($dxchan, 1);
+                                               $dxchan->{call} = $call;
+                                               $dxchan->{priv} = $priv;
+                                               $dxchan->{user} = $user;
+                                       } else {
+                                               LogDbg('err', "Trying to run import cmd for non-existant user $call");
+                                       }
+                               }
+                       }
+                       $s->erase;
+                       for (@out) {
+                               LogDbg('DXCommand', "Import cmd $name/$call: $_");
+                       }
+               } else {
+                       LogDbg('err', "Failed to open $cmdimportdir/$name $!");
+                       unlink "$cmdimportdir/$name";
+               }
+       }
+}
+
+sub print_find_reply
+{
+       my ($self, $node, $target, $flag, $ms) = @_;
+       my $sort = $flag == 2 ? "External" : "Local";
+       $self->send("$sort $target found at $node in $ms ms" );
+}
 1;
 __END__