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