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