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