perl/DXCommandmode.pm

   1 #!/usr/bin/perl
   2 #
   3 # This module impliments the user facing command mode for a dx cluster
   4 #
   5 # Copyright (c) 1998 Dirk Koopman G1TLH
   6 #
   7 # $Id$
   8 #
   9
  10 package DXCommandmode;
  11
  12 #use POSIX;
  13
  14 @ISA = qw(DXChannel);
  15
  16 use POSIX qw(:math_h);
  17 use DXUtil;
  18 use DXChannel;
  19 use DXUser;
  20 use DXVars;
  21 use DXDebug;
  22 use DXM;
  23 use DXLog;
  24 use DXLogPrint;
  25 use DXBearing;
  26 use CmdAlias;
  27 use Filter;
  28 use Minimuf;
  29 use DXDb;
  30 use AnnTalk;
  31 use WCY;
  32 use Sun;
  33 use Internet;
  34 use Script;
  35 use Net::Telnet;
  36 use QSL;
  37 use DB_File;
  38 use VE7CC;
  39 use DXXml;
  40
  41 use strict;
  42 use vars qw(%Cache %cmd_cache $errstr %aliases $scriptbase $maxerrors %nothereslug
  43         $maxbadcount $msgpolltime $default_pagelth $cmdimportdir);
  44
  45 %Cache = ();                                    # cache of dynamically loaded routine's mod times
  46 %cmd_cache = ();                                # cache of short names
  47 $errstr = ();                                   # error string from eval
  48 %aliases = ();                                  # aliases for (parts of) commands
  49 $scriptbase = "$main::root/scripts"; # the place where all users start scripts go
  50 $maxerrors = 20;                                # the maximum number of concurrent errors allowed before disconnection
  51 $maxbadcount = 3;                               # no of bad words allowed before disconnection
  52 $msgpolltime = 3600;                    # the time between polls for new messages
  53 $cmdimportdir = "$main::root/cmd_import"; # the base directory for importing command scripts
  54                                           # this does not exist as default, you need to create it manually
  55                                           #
  56
  57 use vars qw($VERSION $BRANCH);
  58 $VERSION = sprintf( "%d.%03d", q$Revision$ =~ /(\d+)\.(\d+)/ );
  59 $BRANCH = sprintf( "%d.%03d", q$Revision$ =~ /\d+\.\d+\.(\d+)\.(\d+)/  || (0,0));
  60 $main::build += $VERSION;
  61 $main::branch += $BRANCH;
  62
  63 #
  64 # obtain a new connection this is derived from dxchannel
  65 #
  66
  67 sub new
  68 {
  69         my $self = DXChannel::alloc(@_);
  70
  71         # routing, this must go out here to prevent race condx
  72         my $pkg = shift;
  73         my $call = shift;
  74         my @rout = $main::routeroot->add_user($call, Route::here(1));
  75
  76         # ALWAYS output the user
  77         my $ref = Route::User::get($call);
  78         if ($ref) {
  79                 $main::me->route_pc16($main::mycall, undef, $main::routeroot, $ref);
  80                 $main::me->route_pc92a($main::mycall, undef, $ref);
  81         }
  82
  83         return $self;
  84 }
  85
  86 # this is how a a connection starts, you get a hello message and the motd with
  87 # possibly some other messages asking you to set various things up if you are
  88 # new (or nearly new and slacking) user.
  89
  90 sub start
  91 {
  92         my ($self, $line, $sort) = @_;
  93         my $user = $self->{user};
  94         my $call = $self->{call};
  95         my $name = $user->{name};
  96
  97         # log it
  98         my $host = $self->{conn}->{peerhost};
  99         $host ||= "AGW Port #$self->{conn}->{agwport}" if exists $self->{conn}->{agwport};
 100         $host ||= "unknown";
 101         LogDbg('DXCommand', "$call connected from $host");
 102
 103         $self->{name} = $name ? $name : $call;
 104         $self->send($self->msg('l2',$self->{name}));
 105         $self->state('prompt');         # a bit of room for further expansion, passwords etc
 106         $self->{priv} = $user->priv || 0;
 107         $self->{lang} = $user->lang || $main::lang || 'en';
 108         my $pagelth = $user->pagelth;
 109         $pagelth = $default_pagelth unless defined $pagelth;
 110         $self->{pagelth} = $pagelth;
 111         ($self->{width}) = $line =~ /width=(\d+)/; $line =~ s/\s*width=\d+\s*//;
 112         $self->{width} = 80 unless $self->{width} && $self->{width} > 80;
 113         $self->{consort} = $line;       # save the connection type
 114
 115         # set some necessary flags on the user if they are connecting
 116         $self->{beep} = $user->wantbeep;
 117         $self->{ann} = $user->wantann;
 118         $self->{wwv} = $user->wantwwv;
 119         $self->{wcy} = $user->wantwcy;
 120         $self->{talk} = $user->wanttalk;
 121         $self->{wx} = $user->wantwx;
 122         $self->{dx} = $user->wantdx;
 123         $self->{logininfo} = $user->wantlogininfo;
 124         $self->{ann_talk} = $user->wantann_talk;
 125         $self->{here} = 1;
 126         $self->{prompt} = $user->prompt if $user->prompt;
 127
 128         # sort out new dx spot stuff
 129         $user->wantdxcq(0) unless defined $user->{wantdxcq};
 130         $user->wantdxitu(0) unless defined $user->{wantdxitu};
 131         $user->wantusstate(0) unless defined $user->{wantusstate};
 132
 133         # sort out registration
 134         if ($main::reqreg == 1) {
 135                 $self->{registered} = $user->registered;
 136         } elsif ($main::reqreg == 2) {
 137                 $self->{registered} = !$user->registered;
 138         } else {
 139                 $self->{registered} = 1;
 140         }
 141
 142
 143         # decide which motd to send
 144         my $motd;
 145         unless ($self->{registered}) {
 146                 $motd = "${main::motd}_nor_$self->{lang}";
 147                 $motd = "${main::motd}_nor" unless -e $motd;
 148         }
 149         $motd = "${main::motd}_$self->{lang}" unless $motd && -e $motd;
 150         $motd = $main::motd unless $motd && -e $motd;
 151         $self->send_file($motd) if -e $motd;
 152
 153         # sort out privilege reduction
 154         $self->{priv} = 0 if $line =~ /^(ax|te)/ && !$self->conn->{usedpasswd};
 155
 156         # get the filters
 157         my $nossid = $call;
 158         $nossid =~ s/-\d+$//;
 159
 160         $self->{spotsfilter} = Filter::read_in('spots', $call, 0)
 161                 || Filter::read_in('spots', $nossid, 0)
 162                         || Filter::read_in('spots', 'user_default', 0);
 163         $self->{wwvfilter} = Filter::read_in('wwv', $call, 0)
 164                 || Filter::read_in('wwv', $nossid, 0)
 165                         || Filter::read_in('wwv', 'user_default', 0);
 166         $self->{wcyfilter} = Filter::read_in('wcy', $call, 0)
 167                 || Filter::read_in('wcy', $nossid, 0)
 168                         || Filter::read_in('wcy', 'user_default', 0);
 169         $self->{annfilter} = Filter::read_in('ann', $call, 0)
 170                 || Filter::read_in('ann', $nossid, 0)
 171                         || Filter::read_in('ann', 'user_default', 0) ;
 172
 173         # clean up qra locators
 174         my $qra = $user->qra;
 175         $qra = undef if ($qra && !DXBearing::is_qra($qra));
 176         unless ($qra) {
 177                 my $lat = $user->lat;
 178                 my $long = $user->long;
 179                 $user->qra(DXBearing::lltoqra($lat, $long)) if (defined $lat && defined $long);
 180         }
 181
 182         # decide on echo
 183         my $echo = $user->wantecho;
 184         unless ($echo) {
 185                 $self->send_now('E', "0");
 186                 $self->send($self->msg('echow'));
 187                 $self->conn->echo($echo) if $self->conn->can('echo');
 188         }
 189
 190         $self->tell_login('loginu');
 191         $self->tell_buddies('loginb');
 192
 193         # do we need to send a forward/opernam?
 194         my $lastoper = $user->lastoper || 0;
 195         my $homenode = $user->homenode || "";
 196         if ($homenode eq $main::mycall && $main::systime >= $lastoper + $DXUser::lastoperinterval) {
 197                 run_cmd($main::me, "forward/opernam $call");
 198                 $user->lastoper($main::systime + ((int rand(10)) * 86400));
 199         }
 200
 201         # run a script send the output to the punter
 202         my $script = new Script(lc $call) || new Script('user_default');
 203         $script->run($self) if $script;
 204
 205         # send cluster info
 206         my $info = Route::cluster();
 207         $self->send("Cluster:$info");
 208
 209         # send prompts for qth, name and things
 210         $self->send($self->msg('namee1')) if !$user->name;
 211         $self->send($self->msg('qthe1')) if !$user->qth;
 212         $self->send($self->msg('qll')) if !$user->qra || (!$user->lat && !$user->long);
 213         $self->send($self->msg('hnodee1')) if !$user->qth;
 214         $self->send($self->msg('m9')) if DXMsg::for_me($call);
 215
 216         # send out any buddy messages for other people that are online
 217         foreach my $call (@{$user->buddies}) {
 218                 my $ref = Route::User::get($call);
 219                 if ($ref) {
 220                         foreach my $node (@{$ref->parent}) {
 221                                 $self->send($self->msg($node eq $main::mycall ? 'loginb' : 'loginbn', $call, $node));
 222                         }
 223                 }
 224         }
 225
 226         $self->lastmsgpoll($main::systime);
 227         $self->prompt;
 228 }
 229
 230 #
 231 # This is the normal command prompt driver
 232 #
 233
 234 sub normal
 235 {
 236         my $self = shift;
 237         my $cmdline = shift;
 238         my @ans;
 239
 240         # save this for them's that need it
 241         my $rawline = $cmdline;
 242
 243         # remove leading and trailing spaces
 244         $cmdline =~ s/^\s*(.*)\s*$/$1/;
 245
 246         if ($self->{state} eq 'page') {
 247                 my $i = $self->{pagelth};
 248                 my $ref = $self->{pagedata};
 249                 my $tot = @$ref;
 250
 251                 # abort if we get a line starting in with a
 252                 if ($cmdline =~ /^a/io) {
 253                         undef $ref;
 254                         $i = 0;
 255                 }
 256
 257                 # send a tranche of data
 258                 while ($i-- > 0 && @$ref) {
 259                         my $line = shift @$ref;
 260                         $line =~ s/\s+$//o;     # why am having to do this?
 261                         $self->send($line);
 262                 }
 263
 264                 # reset state if none or else chuck out an intermediate prompt
 265                 if ($ref && @$ref) {
 266                         $tot -= $self->{pagelth};
 267                         $self->send($self->msg('page', $tot));
 268                 } else {
 269                         $self->state('prompt');
 270                 }
 271         } elsif ($self->{state} eq 'sysop') {
 272                 my $passwd = $self->{user}->passwd;
 273                 if ($passwd) {
 274                         my @pw = grep {$_ !~ /\s/} split //, $passwd;
 275                         my @l = @{$self->{passwd}};
 276                         my $str = "$pw[$l[0]].*$pw[$l[1]].*$pw[$l[2]].*$pw[$l[3]].*$pw[$l[4]]";
 277                         if ($cmdline =~ /$str/) {
 278                                 $self->{priv} = $self->{user}->priv;
 279                         } else {
 280                                 $self->send($self->msg('sorry'));
 281                         }
 282                 } else {
 283                         $self->send($self->msg('sorry'));
 284                 }
 285                 $self->state('prompt');
 286         } elsif ($self->{state} eq 'passwd') {
 287                 my $passwd = $self->{user}->passwd;
 288                 if ($passwd && $cmdline eq $passwd) {
 289                         $self->send($self->msg('pw1'));
 290                         $self->state('passwd1');
 291                 } else {
 292                         $self->conn->{echo} = $self->conn->{decho};
 293                         delete $self->conn->{decho};
 294                         $self->send($self->msg('sorry'));
 295                         $self->state('prompt');
 296                 }
 297         } elsif ($self->{state} eq 'passwd1') {
 298                 $self->{passwd} = $cmdline;
 299                 $self->send($self->msg('pw2'));
 300                 $self->state('passwd2');
 301         } elsif ($self->{state} eq 'passwd2') {
 302                 if ($cmdline eq $self->{passwd}) {
 303                         $self->{user}->passwd($cmdline);
 304                         $self->send($self->msg('pw3'));
 305                 } else {
 306                         $self->send($self->msg('pw4'));
 307                 }
 308                 $self->conn->{echo} = $self->conn->{decho};
 309                 delete $self->conn->{decho};
 310                 $self->state('prompt');
 311         } elsif ($self->{state} eq 'talk') {
 312                 if ($cmdline =~ m{^(?:/EX|/ABORT)}i) {
 313                         for (@{$self->{talklist}}) {
 314                                 $self->send_talks($_,  $self->msg('talkend'));
 315                         }
 316                         $self->state('prompt');
 317                         delete $self->{talklist};
 318                 } elsif ($cmdline =~ m|^/+\w+|) {
 319                         $cmdline =~ s|^/||;
 320                         my $sendit = $cmdline =~ s|^/+||;
 321                         my @in = $self->run_cmd($cmdline);
 322                         $self->send_ans(@in);
 323                         if ($sendit && $self->{talklist} && @{$self->{talklist}}) {
 324                                 foreach my $l (@in) {
 325                                         my @bad;
 326                                         if (@bad = BadWords::check($l)) {
 327                                                 $self->badcount(($self->badcount||0) + @bad);
 328                                                 LogDbg('DXCommand', "$self->{call} swore: $l with words:" . join(',', @bad) . ")");
 329                                         } else {
 330                                                 for (@{$self->{talklist}}) {
 331                                                         $self->send_talks($_, $l);
 332                                                 }
 333                                         }
 334                                 }
 335                         }
 336                         $self->send($self->talk_prompt);
 337                 } elsif ($self->{talklist} && @{$self->{talklist}}) {
 338                         # send what has been said to whoever is in this person's talk list
 339                         my @bad;
 340                         if (@bad = BadWords::check($cmdline)) {
 341                                 $self->badcount(($self->badcount||0) + @bad);
 342                                 LogDbg('DXCommand', "$self->{call} swore: $cmdline with words:" . join(',', @bad) . ")");
 343                         } else {
 344                                 for (@{$self->{talklist}}) {
 345                                         $self->send_talks($_, $rawline);
 346                                 }
 347                         }
 348                         $self->send($self->talk_prompt) if $self->{state} eq 'talk';
 349                 } else {
 350                         # for safety
 351                         $self->state('prompt');
 352                 }
 353         } elsif (my $func = $self->{func}) {
 354                 no strict 'refs';
 355                 my @ans;
 356                 if (ref $self->{edit}) {
 357                         eval { @ans = $self->{edit}->$func($self, $rawline)};
 358                 } else {
 359                         eval {  @ans = &{$self->{func}}($self, $rawline) };
 360                 }
 361                 if ($@) {
 362                         $self->send_ans("Syserr: on stored func $self->{func}", $@);
 363                         delete $self->{func};
 364                         $self->state('prompt');
 365                         undef $@;
 366                 }
 367                 $self->send_ans(@ans);
 368         } else {
 369                 $self->send_ans(run_cmd($self, $cmdline));
 370         }
 371
 372         # check for excessive swearing
 373         if ($self->{badcount} && $self->{badcount} >= $maxbadcount) {
 374                 LogDbg('DXCommand', "$self->{call} logged out for excessive swearing");
 375                 $self->disconnect;
 376                 return;
 377         }
 378
 379         # send a prompt only if we are in a prompt state
 380         $self->prompt() if $self->{state} =~ /^prompt/o;
 381 }
 382
 383 # send out the talk messages taking into account vias and connectivity
 384 sub send_talks
 385 {
 386         my ($self, $ent, $line) = @_;
 387
 388         my ($to, $via) = $ent =~ /(\S+)>(\S+)/;
 389         $to = $ent unless $to;
 390         my $call = $via ? $via : $to;
 391         my $clref = Route::get($call);
 392         my $dxchan = $clref->dxchan if $clref;
 393         if ($dxchan) {
 394                 $dxchan->talk($self->{call}, $to, $via, $line);
 395         } else {
 396                 $self->send($self->msg('disc2', $via ? $via : $to));
 397                 my @l = grep { $_ ne $ent } @{$self->{talklist}};
 398                 if (@l) {
 399                         $self->{talklist} = \@l;
 400                 } else {
 401                         delete $self->{talklist};
 402                         $self->state('prompt');
 403                 }
 404         }
 405 }
 406
 407 sub talk_prompt
 408 {
 409         my $self = shift;
 410         my @call;
 411         for (@{$self->{talklist}}) {
 412                 my ($to, $via) = /(\S+)>(\S+)/;
 413                 $to = $_ unless $to;
 414                 push @call, $to;
 415         }
 416         return $self->msg('talkprompt', join(',', @call));
 417 }
 418
 419 #
 420 # send a load of stuff to a command user with page prompting
 421 # and stuff
 422 #
 423
 424 sub send_ans
 425 {
 426         my $self = shift;
 427
 428         if ($self->{pagelth} && @_ > $self->{pagelth}) {
 429                 my $i;
 430                 for ($i = $self->{pagelth}; $i-- > 0; ) {
 431                         my $line = shift @_;
 432                         $line =~ s/\s+$//o;     # why am having to do this?
 433                         $self->send($line);
 434                 }
 435                 $self->{pagedata} =  [ @_ ];
 436                 $self->state('page');
 437                 $self->send($self->msg('page', scalar @_));
 438         } else {
 439                 for (@_) {
 440                         if (defined $_) {
 441                                 $self->send($_);
 442                         } else {
 443                                 $self->send('');
 444                         }
 445                 }
 446         }
 447 }
 448 #
 449 # this is the thing that runs the command, it is done like this for the
 450 # benefit of remote command execution
 451 #
 452
 453 sub run_cmd
 454 {
 455         my $self = shift;
 456         my $user = $self->{user};
 457         my $call = $self->{call};
 458         my $cmdline = shift;
 459         my @ans;
 460
 461
 462         return () if length $cmdline == 0;
 463
 464
 465         # split the command line up into parts, the first part is the command
 466         my ($cmd, $args) = split /\s+/, $cmdline, 2;
 467         $args = "" unless defined $args;
 468
 469         if ($cmd) {
 470                 # strip out // on command only
 471                 $cmd =~ s|//|/|g;
 472                 $cmd =~ s|^/||g;                # no leading / either
 473                 $cmd =~ s|[^-?\w/]||g;          # and no funny characters either
 474
 475                 my ($path, $fcmd);
 476
 477                 dbg("cmd: $cmd") if isdbg('command');
 478
 479                 # alias it if possible
 480                 my $acmd = CmdAlias::get_cmd($cmd);
 481                 if ($acmd) {
 482                         ($cmd, $args) = split /\s+/, "$acmd $args", 2;
 483                         $args = "" unless defined $args;
 484                         dbg("aliased cmd: $cmd $args") if isdbg('command');
 485                 }
 486
 487                 # first expand out the entry to a command
 488                 ($path, $fcmd) = search($main::localcmd, $cmd, "pl");
 489                 ($path, $fcmd) = search($main::cmd, $cmd, "pl") unless $path && $fcmd;
 490
 491                 if ($path && $cmd) {
 492                         dbg("path: $cmd cmd: $fcmd") if isdbg('command');
 493
 494                         my $package = find_cmd_name($path, $fcmd);
 495                         return ($@) if $@;
 496
 497                         if ($package) {
 498                                 no strict 'refs';
 499                                 dbg("package: $package") if isdbg('command');
 500                                 eval { @ans = &$package($self, $args) };
 501                                 return (DXDebug::shortmess($@)) if $@;
 502                         }
 503                 } else {
 504                         dbg("cmd: $cmd not found") if isdbg('command');
 505                         if (++$self->{errors} > $maxerrors) {
 506                                 $self->send($self->msg('e26'));
 507                                 $self->disconnect;
 508                                 return ();
 509                         } else {
 510                                 return ($self->msg('e1'));
 511                         }
 512                 }
 513         }
 514
 515         my $ok = shift @ans;
 516         if ($ok) {
 517                 delete $self->{errors};
 518         } else {
 519                 if (++$self->{errors} > $maxerrors) {
 520                         $self->send($self->msg('e26'));
 521                         $self->disconnect;
 522                         return ();
 523                 }
 524         }
 525         return map {s/([^\s])\s+$/$1/; $_} @ans;
 526 }
 527
 528 #
 529 # This is called from inside the main cluster processing loop and is used
 530 # for despatching commands that are doing some long processing job
 531 #
 532 sub process
 533 {
 534         my $t = time;
 535         my @dxchan = DXChannel::get_all();
 536         my $dxchan;
 537
 538         foreach $dxchan (@dxchan) {
 539                 next if $dxchan->sort ne 'U';
 540
 541                 # send a outstanding message prompt if required
 542                 if ($t >= $dxchan->lastmsgpoll + $msgpolltime) {
 543                         $dxchan->send($dxchan->msg('m9')) if DXMsg::for_me($dxchan->call);
 544                         $dxchan->lastmsgpoll($t);
 545                 }
 546
 547                 # send a prompt if no activity out on this channel
 548                 if ($t >= $dxchan->t + $main::user_interval) {
 549                         $dxchan->prompt() if $dxchan->{state} =~ /^prompt/o;
 550                         $dxchan->t($t);
 551                 }
 552         }
 553
 554         while (my ($k, $v) = each %nothereslug) {
 555                 if ($main::systime >= $v + 300) {
 556                         delete $nothereslug{$k};
 557                 }
 558         }
 559
 560         import_cmd();
 561 }
 562
 563 #
 564 # finish up a user context
 565 #
 566 sub disconnect
 567 {
 568         my $self = shift;
 569         my $call = $self->call;
 570
 571         return if $self->{disconnecting}++;
 572
 573         delete $self->{senddbg};
 574
 575         my $uref = Route::User::get($call);
 576         my @rout;
 577         if ($uref) {
 578                 @rout = $main::routeroot->del_user($uref);
 579                 dbg("B/C PC17 on $main::mycall for: $call") if isdbg('route');
 580
 581                 # issue a pc17 to everybody interested
 582                 $main::me->route_pc17($main::mycall, undef, $main::routeroot, $uref);
 583                 $main::me->route_pc92d($main::mycall, undef, $uref);
 584         } else {
 585                 confess "trying to disconnect a non existant user $call";
 586         }
 587
 588         # I was the last node visited
 589     $self->user->node($main::mycall);
 590
 591         # send info to all logged in thingies
 592         $self->tell_login('logoutu');
 593         $self->tell_buddies('logoutb');
 594
 595         LogDbg('DXCommand', "$call disconnected");
 596
 597         $self->SUPER::disconnect;
 598 }
 599
 600 #
 601 # short cut to output a prompt
 602 #
 603
 604 sub prompt
 605 {
 606         my $self = shift;
 607
 608         return if $self->{gtk};         # 'cos prompts are not a concept that applies here
 609
 610         my $call = $self->call;
 611         my $date = cldate($main::systime);
 612         my $time = ztime($main::systime);
 613         my $prompt = $self->{prompt} || $self->msg('pr');
 614
 615         $call = "($call)" unless $self->here;
 616         $prompt =~ s/\%C/$call/g;
 617         $prompt =~ s/\%D/$date/g;
 618         $prompt =~ s/\%T/$time/g;
 619         $prompt =~ s/\%M/$main::mycall/g;
 620
 621         $self->send($prompt);
 622 }
 623
 624 # broadcast a message to all users [except those mentioned after buffer]
 625 sub broadcast
 626 {
 627         my $pkg = shift;                        # ignored
 628         my $s = shift;                          # the line to be rebroadcast
 629
 630     foreach my $dxchan (DXChannel::get_all()) {
 631                 next unless $dxchan->{sort} eq 'U'; # only interested in user channels
 632                 next if grep $dxchan == $_, @_;
 633                 $dxchan->send($s);                      # send it
 634         }
 635 }
 636
 637 # gimme all the users
 638 sub get_all
 639 {
 640         return grep {$_->{sort} eq 'U'} DXChannel::get_all();
 641 }
 642
 643 # run a script for this user
 644 sub run_script
 645 {
 646         my $self = shift;
 647         my $silent = shift || 0;
 648
 649 }
 650
 651 #
 652 # search for the command in the cache of short->long form commands
 653 #
 654
 655 sub search
 656 {
 657         my ($path, $short_cmd, $suffix) = @_;
 658         my ($apath, $acmd);
 659
 660         # commands are lower case
 661         $short_cmd = lc $short_cmd;
 662         dbg("command: $path $short_cmd\n") if isdbg('command');
 663
 664         # do some checking for funny characters
 665         return () if $short_cmd =~ /\/$/;
 666
 667         # return immediately if we have it
 668         ($apath, $acmd) = split ',', $cmd_cache{$short_cmd} if $cmd_cache{$short_cmd};
 669         if ($apath && $acmd) {
 670                 dbg("cached $short_cmd = ($apath, $acmd)\n") if isdbg('command');
 671                 return ($apath, $acmd);
 672         }
 673
 674         # if not guess
 675         my @parts = split '/', $short_cmd;
 676         my $dirfn;
 677         my $curdir = $path;
 678
 679         while (my $p = shift @parts) {
 680                 opendir(D, $curdir) or confess "can't open $curdir $!";
 681                 my @ls = readdir D;
 682                 closedir D;
 683
 684                 # if this isn't the last part
 685                 if (@parts) {
 686                         my $found;
 687                         foreach my $l (sort @ls) {
 688                                 next if $l =~ /^\./;
 689                                 if ((-d "$curdir/$l") && $p eq substr($l, 0, length $p)) {
 690                                         dbg("got dir: $curdir/$l\n") if isdbg('command');
 691                                         $dirfn .= "$l/";
 692                                         $curdir .= "/$l";
 693                                         $found++;
 694                                         last;
 695                                 }
 696                         }
 697                         # only proceed if we find the directory asked for
 698                         return () unless $found;
 699                 } else {
 700                         foreach my $l (sort @ls) {
 701                                 next if $l =~ /^\./;
 702                                 next unless $l =~ /\.$suffix$/;
 703                                 if ($p eq substr($l, 0, length $p)) {
 704                                         $l =~ s/\.$suffix$//;
 705                                         $dirfn = "" unless $dirfn;
 706                                         $cmd_cache{$short_cmd} = join(',', ($path, "$dirfn$l")); # cache it
 707                                         dbg("got path: $path cmd: $dirfn$l\n") if isdbg('command');
 708                                         return ($path, "$dirfn$l");
 709                                 }
 710                         }
 711                 }
 712         }
 713
 714         return ();
 715 }
 716
 717 # clear the command name cache
 718 sub clear_cmd_cache
 719 {
 720         no strict 'refs';
 721
 722         for (keys %Cache) {
 723                 undef *{$_} unless /cmd_cache/;
 724                 dbg("Undefining cmd $_") if isdbg('command');
 725         }
 726         %cmd_cache = ();
 727         %Cache = ();
 728 }
 729
 730 #
 731 # the persistant execution of things from the command directories
 732 #
 733 #
 734 # This allows perl programs to call functions dynamically
 735 #
 736 # This has been nicked directly from the perlembed pages
 737 #
 738
 739 #require Devel::Symdump;
 740
 741 sub valid_package_name {
 742         my($string) = @_;
 743         $string =~ s|([^A-Za-z0-9_/])|sprintf("_%2x",unpack("C",$1))|eg;
 744
 745         $string =~ s|/|_|g;
 746         return "cmd_$string";
 747 }
 748
 749 #
 750 # this bit of magic finds a command in the offered directory
 751 sub find_cmd_name {
 752         my $path = shift;
 753         my $cmdname = shift;
 754         my $package = valid_package_name($cmdname);
 755         my $filename = "$path/$cmdname.pl";
 756         my $mtime = -M $filename;
 757
 758         # return if we can't find it
 759         $errstr = undef;
 760         unless (defined $mtime) {
 761                 $errstr = DXM::msg('e1');
 762                 return undef;
 763         }
 764
 765         if(defined $Cache{$package}->{mtime} &&$Cache{$package}->{mtime} <= $mtime) {
 766                 #we have compiled this subroutine already,
 767                 #it has not been updated on disk, nothing left to do
 768                 #print STDERR "already compiled $package->handler\n";
 769                 ;
 770         } else {
 771
 772                 my $sub = readfilestr($filename);
 773                 unless ($sub) {
 774                         $errstr = "Syserr: can't open '$filename' $!";
 775                         return undef;
 776                 };
 777
 778                 #wrap the code into a subroutine inside our unique package
 779                 my $eval = qq( sub $package { $sub } );
 780
 781                 if (isdbg('eval')) {
 782                         my @list = split /\n/, $eval;
 783                         my $line;
 784                         for (@list) {
 785                                 dbg($_ . "\n") if isdbg('eval');
 786                         }
 787                 }
 788
 789                 # get rid of any existing sub and try to compile the new one
 790                 no strict 'refs';
 791
 792                 if (exists $Cache{$package}) {
 793                         dbg("Redefining $package") if isdbg('command');
 794                         undef *$package;
 795                 } else {
 796                         dbg("Defining $package") if isdbg('command');
 797                 }
 798                 eval $eval;
 799
 800                 $Cache{$package} = {mtime => $mtime };
 801
 802         }
 803
 804         return $package;
 805 }
 806
 807 sub send
 808 {
 809         my $self = shift;
 810         if ($self->{gtk}) {
 811                 for (@_) {
 812                         $self->SUPER::send(dd(['cmd',$_]));
 813                 }
 814         } else {
 815                 $self->SUPER::send(@_);
 816         }
 817 }
 818
 819 sub local_send
 820 {
 821         my ($self, $let, $buf) = @_;
 822         if ($self->{state} eq 'prompt' || $self->{state} eq 'talk') {
 823                 if ($self->{enhanced}) {
 824                         $self->send_later($let, $buf);
 825                 } else {
 826                         $self->send($buf);
 827                 }
 828         } else {
 829                 $self->delay($buf);
 830         }
 831 }
 832
 833 # send a talk message here
 834 sub talk
 835 {
 836         my ($self, $from, $to, $via, $line) = @_;
 837         $line =~ s/\\5E/\^/g;
 838         if ($self->{talk}) {
 839                 if ($self->{gtk}) {
 840                         $self->local_send('T', dd(['talk',$to,$from,$via,$line]));
 841                 } else {
 842                         $self->local_send('T', "$to de $from: $line");
 843                 }
 844         }
 845         Log('talk', $to, $from, $via?$via:$main::mycall, $line);
 846         # send a 'not here' message if required
 847         unless ($self->{here} && $from ne $to) {
 848                 my $key = "$to$from";
 849                 unless (exists $nothereslug{$key}) {
 850                         my ($ref, $dxchan);
 851                         if (($ref = Route::get($from)) && ($dxchan = $ref->dxchan)) {
 852                                 my $name = $self->user->name || $to;
 853                                 my $s = $self->user->nothere || $dxchan->msg('nothere', $name);
 854                                 $nothereslug{$key} = $main::systime;
 855                                 $dxchan->talk($to, $from, undef, $s);
 856                         }
 857                 }
 858         }
 859 }
 860
 861 # send an announce
 862 sub announce
 863 {
 864         my $self = shift;
 865         my $line = shift;
 866         my $isolate = shift;
 867         my $to = shift;
 868         my $target = shift;
 869         my $text = shift;
 870         my ($filter, $hops);
 871
 872         if (!$self->{ann_talk} && $to ne $self->{call}) {
 873                 my $call = AnnTalk::is_talk_candidate($_[0], $text);
 874                 return if $call;
 875         }
 876
 877         if ($self->{annfilter}) {
 878                 ($filter, $hops) = $self->{annfilter}->it(@_ );
 879                 return unless $filter;
 880         }
 881
 882         unless ($self->{ann}) {
 883                 return if $_[0] ne $main::myalias && $_[0] ne $main::mycall;
 884         }
 885         return if $target eq 'SYSOP' && $self->{priv} < 5;
 886         my $buf;
 887         if ($self->{gtk}) {
 888                 $buf = dd(['ann', $to, $target, $text, @_])
 889         } else {
 890                 $buf = "$to$target de $_[0]: $text";
 891                 $buf =~ s/\%5E/^/g;
 892                 $buf .= "\a\a" if $self->{beep};
 893         }
 894         $self->local_send($target eq 'WX' ? 'W' : 'N', $buf);
 895 }
 896
 897 # send a chat
 898 sub chat
 899 {
 900         my $self = shift;
 901         my $line = shift;
 902         my $isolate = shift;
 903         my $target = shift;
 904         my $to = shift;
 905         my $text = shift;
 906         my ($filter, $hops);
 907
 908         return unless grep uc $_ eq $target, @{$self->{user}->{group}};
 909
 910         $text =~ s/^\#\d+ //;
 911         my $buf;
 912         if ($self->{gtk}) {
 913                 $buf = dd(['chat', $to, $target, $text, @_])
 914         } else {
 915                 $buf = "$target de $_[0]: $text";
 916                 $buf =~ s/\%5E/^/g;
 917                 $buf .= "\a\a" if $self->{beep};
 918         }
 919         $self->local_send('C', $buf);
 920 }
 921
 922 sub format_dx_spot
 923 {
 924         my $self = shift;
 925
 926         my $t = ztime($_[2]);
 927         my $loc = '';
 928         my $clth = $self->{consort} eq 'local' ? 29 : 30;
 929         my $comment = substr $_[3], 0, $clth;
 930         $comment .= ' ' x ($clth - length($comment));
 931         if ($self->{user}->wantgrid) {
 932                 my $ref = DXUser->get_current($_[4]);
 933                 if ($ref) {
 934                         $loc = $ref->qra || '';
 935                         $loc = ' ' . substr($loc, 0, 4) if $loc;
 936                 }
 937         }
 938
 939         if ($self->{user}->wantdxitu) {
 940                 $loc = ' ' . sprintf("%2d", $_[10]) if defined $_[10];
 941                 $comment = substr($comment, 0,  $self->{consort} eq 'local' ? 26 : 27) . ' ' . sprintf("%2d", $_[8]) if defined $_[8];
 942         } elsif ($self->{user}->wantdxcq) {
 943                 $loc = ' ' . sprintf("%2d", $_[11]) if defined $_[11];
 944                 $comment = substr($comment, 0,  $self->{consort} eq 'local' ? 26 : 27) . ' ' . sprintf("%2d", $_[9]) if defined $_[9];
 945         } elsif ($self->{user}->wantusstate) {
 946                 $loc = ' ' . $_[13] if $_[13];
 947                 $comment = substr($comment, 0,  $self->{consort} eq 'local' ? 26 : 27) . ' ' . $_[12] if $_[12];
 948         }
 949
 950         return sprintf "DX de %-7.7s%11.1f  %-12.12s %-s $t$loc", "$_[4]:", $_[0], $_[1], $comment;
 951 }
 952
 953 # send a dx spot
 954 sub dx_spot
 955 {
 956         my $self = shift;
 957         my $line = shift;
 958         my $isolate = shift;
 959         return unless $self->{dx};
 960
 961         my ($filter, $hops);
 962
 963         if ($self->{spotsfilter}) {
 964                 ($filter, $hops) = $self->{spotsfilter}->it(@_ );
 965                 return unless $filter;
 966         }
 967
 968         dbg('spot: "' . join('","', @_) . '"') if isdbg('dxspot');
 969
 970         my $buf;
 971         if ($self->{ve7cc}) {
 972                 $buf = VE7CC::dx_spot($self, @_);
 973         } elsif ($self->{gtk}) {
 974                 my ($dxloc, $byloc);
 975
 976                 my $ref = DXUser->get_current($_[4]);
 977                 if ($ref) {
 978                         $byloc = $ref->qra;
 979                         $byloc = substr($byloc, 0, 4) if $byloc;
 980                 }
 981
 982                 my $spot = $_[1];
 983                 $spot =~ s|/\w{1,4}$||;
 984                 $ref = DXUser->get_current($spot);
 985                 if ($ref) {
 986                         $dxloc = $ref->qra;
 987                         $dxloc = substr($dxloc, 0, 4) if $dxloc;
 988                 }
 989                 $buf = dd(['dx', @_, ($dxloc||''), ($byloc||'')]);
 990
 991         } else {
 992                 $buf = $self->format_dx_spot(@_);
 993                 $buf .= "\a\a" if $self->{beep};
 994                 $buf =~ s/\%5E/^/g;
 995         }
 996
 997         $self->local_send('X', $buf);
 998 }
 999
1000 sub wwv
1001 {
1002         my $self = shift;
1003         my $line = shift;
1004         my $isolate = shift;
1005         my ($filter, $hops);
1006
1007         return unless $self->{wwv};
1008
1009         if ($self->{wwvfilter}) {
1010                 ($filter, $hops) = $self->{wwvfilter}->it(@_[7..$#_] );
1011                 return unless $filter;
1012         }
1013
1014         my $buf;
1015         if ($self->{gtk}) {
1016                 $buf = dd(['wwv', @_])
1017         } else {
1018                 $buf = "WWV de $_[6] <$_[1]>:   SFI=$_[2], A=$_[3], K=$_[4], $_[5]";
1019                 $buf .= "\a\a" if $self->{beep};
1020         }
1021
1022         $self->local_send('V', $buf);
1023 }
1024
1025 sub wcy
1026 {
1027         my $self = shift;
1028         my $line = shift;
1029         my $isolate = shift;
1030         my ($filter, $hops);
1031
1032         return unless $self->{wcy};
1033
1034         if ($self->{wcyfilter}) {
1035                 ($filter, $hops) = $self->{wcyfilter}->it(@_ );
1036                 return unless $filter;
1037         }
1038
1039         my $buf;
1040         if ($self->{gtk}) {
1041                 $buf = dd(['wcy', @_])
1042         } else {
1043                 $buf = "WCY de $_[10] <$_[1]> : K=$_[4] expK=$_[5] A=$_[3] R=$_[6] SFI=$_[2] SA=$_[7] GMF=$_[8] Au=$_[9]";
1044                 $buf .= "\a\a" if $self->{beep};
1045         }
1046         $self->local_send('Y', $buf);
1047 }
1048
1049 # broadcast debug stuff to all interested parties
1050 sub broadcast_debug
1051 {
1052         my $s = shift;                          # the line to be rebroadcast
1053
1054         foreach my $dxchan (DXChannel::get_all) {
1055                 next unless $dxchan->{enhanced} && $dxchan->{senddbg};
1056                 if ($dxchan->{gtk}) {
1057                         $dxchan->send_later('L', dd(['db', $s]));
1058                 } else {
1059                         $dxchan->send_later('L', $s);
1060                 }
1061         }
1062 }
1063
1064 sub do_entry_stuff
1065 {
1066         my $self = shift;
1067         my $line = shift;
1068         my @out;
1069
1070         if ($self->state eq 'enterbody') {
1071                 my $loc = $self->{loc} || confess "local var gone missing" ;
1072                 if ($line eq "\032" || $line eq '%1A' || uc $line eq "/EX") {
1073                         no strict 'refs';
1074                         push @out, &{$loc->{endaction}}($self);          # like this for < 5.8.0
1075                         $self->func(undef);
1076                         $self->state('prompt');
1077                 } elsif ($line eq "\031" || uc $line eq "/ABORT" || uc $line eq "/QUIT") {
1078                         push @out, $self->msg('m10');
1079                         delete $loc->{lines};
1080                         delete $self->{loc};
1081                         $self->func(undef);
1082                         $self->state('prompt');
1083                 } else {
1084                         push @{$loc->{lines}}, length($line) > 0 ? $line : " ";
1085                         # i.e. it ain't and end or abort, therefore store the line
1086                 }
1087         } else {
1088                 confess "Invalid state $self->{state}";
1089         }
1090         return @out;
1091 }
1092
1093 sub store_startup_script
1094 {
1095         my $self = shift;
1096         my $loc = $self->{loc} || confess "local var gone missing" ;
1097         my @out;
1098         my $call = $loc->{call} || confess "callsign gone missing";
1099         confess "lines array gone missing" unless ref $loc->{lines};
1100         my $r = Script::store($call, $loc->{lines});
1101         if (defined $r) {
1102                 if ($r) {
1103                         push @out, $self->msg('m19', $call, $r);
1104                 } else {
1105                         push @out, $self->msg('m20', $call);
1106                 }
1107         } else {
1108                 push @out, "error opening startup script $call $!";
1109         }
1110         return @out;
1111 }
1112
1113 # Import any commands contained in any files in import_cmd directory
1114 #
1115 # If the filename has a recogisable callsign as some delimited part
1116 # of it, then this is the user the command will be run as.
1117 #
1118 sub import_cmd
1119 {
1120         # are there any to do in this directory?
1121         return unless -d $cmdimportdir;
1122         unless (opendir(DIR, $cmdimportdir)) {
1123                 LogDbg('err', "can\'t open $cmdimportdir $!");
1124                 return;
1125         }
1126
1127         my @names = readdir(DIR);
1128         closedir(DIR);
1129         my $name;
1130         foreach $name (@names) {
1131                 next if $name =~ /^\./;
1132
1133                 my $s = Script->new($name, $cmdimportdir);
1134                 if ($s) {
1135                         LogDbg('DXCommand', "Run import cmd file $name");
1136                         my @cat = split /[^A-Za-z0-9]+/, $name;
1137                         my ($call) = grep {is_callsign(uc $_)} @cat;
1138                         $call ||= $main::mycall;
1139                         $call = uc $call;
1140                         my @out;
1141
1142
1143                         $s->inscript(0);        # switch off script checks
1144
1145                         if ($call eq $main::mycall) {
1146                                 @out = $s->run($main::me, 1);
1147                         } else {
1148                                 my $dxchan = DXChannel::get($call);
1149                             if ($dxchan) {
1150                                         @out = $s->run($dxchan, 1);
1151                                 } else {
1152                                         my $u = DXUser->get($call);
1153                                         if ($u) {
1154                                                 $dxchan = $main::me;
1155                                                 my $old = $dxchan->{call};
1156                                                 my $priv = $dxchan->{priv};
1157                                                 my $user = $dxchan->{user};
1158                                                 $dxchan->{call} = $call;
1159                                                 $dxchan->{priv} = $u->priv;
1160                                                 $dxchan->{user} = $u;
1161                                                 @out = $s->run($dxchan, 1);
1162                                                 $dxchan->{call} = $call;
1163                                                 $dxchan->{priv} = $priv;
1164                                                 $dxchan->{user} = $user;
1165                                         } else {
1166                                                 LogDbg('err', "Trying to run import cmd for non-existant user $call");
1167                                         }
1168                                 }
1169                         }
1170                         $s->erase;
1171                         for (@out) {
1172                                 LogDbg('DXCommand', "Import cmd $name/$call: $_");
1173                         }
1174                 } else {
1175                         LogDbg('err', "Failed to open $cmdimportdir/$name $!");
1176                         unlink "$cmdimportdir/$name";
1177                 }
1178         }
1179 }
1180 1;
1181 __END__