]> dxcluster.org Git - spider.git/blob - perl/DXProt.pm
added new debugging to daily file logging
[spider.git] / perl / DXProt.pm
1 #!/usr/bin/perl
2 #
3 # This module impliments the protocal mode for a dx cluster
4 #
5 # Copyright (c) 1998 Dirk Koopman G1TLH
6 #
7 # $Id$
8
9
10 package DXProt;
11
12 @ISA = qw(DXChannel);
13
14 use DXUtil;
15 use DXChannel;
16 use DXUser;
17 use DXM;
18 use DXCluster;
19 use DXProtVars;
20 use DXCommandmode;
21 use Spot;
22 use DXProtout;
23 use Carp;
24
25 use strict;
26 use vars qw($me $pc11_max_age $pc11_dup_age %dup $last_hour);
27
28 $me = undef;                # the channel id for this cluster
29 $pc11_max_age = 1*3600;     # the maximum age for an incoming 'real-time' pc11
30 $pc11_dup_age = 24*3600;    # the maximum time to keep the dup list for
31 %dup = ();                  # the pc11 and 26 dup hash 
32 $last_hour = time;          # last time I did an hourly periodic update
33
34 sub init
35 {
36   my $user = DXUser->get($main::mycall);
37   $me = DXProt->new($main::mycall, undef, $user); 
38 #  $me->{sort} = 'M';    # M for me
39 }
40
41 #
42 # obtain a new connection this is derived from dxchannel
43 #
44
45 sub new 
46 {
47   my $self = DXChannel::alloc(@_);
48   $self->{sort} = 'A';   # in absence of how to find out what sort of an object I am
49   return $self;
50 }
51
52 # this is how a pc connection starts (for an incoming connection)
53 # issue a PC38 followed by a PC18, then wait for a PC20 (remembering
54 # all the crap that comes between).
55 sub start
56 {
57   my ($self, $line) = shift;
58   my $call = $self->call;
59   
60   # remember type of connection
61   $self->{consort} = $line;
62
63   # set unbuffered
64   $self->send_now('B',"0");
65   
66   # send initialisation string
67   $self->send(pc38()) if DXNode->get_all();
68   $self->send(pc18());
69   $self->state('init');
70   $self->pc50_t(time);
71 }
72
73 #
74 # This is the normal pcxx despatcher
75 #
76 sub normal
77 {
78   my ($self, $line) = @_;
79   my @field = split /[\^\~]/, $line;
80   
81   # ignore any lines that don't start with PC
82   return if !$field[0] =~ /^PC/;
83
84   # process PC frames
85   my ($pcno) = $field[0] =~ /^PC(\d\d)/;          # just get the number
86   return if $pcno < 10 || $pcno > 51;
87   
88   SWITCH: {
89     if ($pcno == 10) {             # incoming talk
90
91       # is it for me or one of mine?
92           my $call = ($field[5] gt ' ') ? $field[5] : $field[2];
93           if ($call eq $main::mycall || grep $_ eq $call, get_all_user_calls()) {
94             
95                 # yes, it is
96                 my $text = unpad($field[3]);
97                 my $ref = DXChannel->get($call);
98                 $ref->send("$call de $field[1]: $text") if $ref;
99           } else {
100             route($field[2], $line);       # relay it on its way
101           }
102           return;
103         }
104         
105     if ($pcno == 11 || $pcno == 26) {             # dx spot
106
107       # if this is a 'nodx' node then ignore it
108           last SWITCH if grep $field[7] =~ /^$_/,  @DXProt::nodx_node;
109           
110       # convert the date to a unix date
111           my $d = cltounix($field[3], $field[4]);
112           return if !$d || ($pcno == 11 && $d < $main::systime - $pc11_max_age);  # bang out (and don't pass on) if date is invalid or the spot is too old
113           
114           # strip off the leading & trailing spaces from the comment
115           my $text = unpad($field[5]);
116           
117           # store it away
118           my $spotter = $field[6];
119           $spotter =~ s/-\d+$//o;         # strip off the ssid from the spotter
120
121       # do some de-duping
122           my $dupkey = "$field[1]$field[2]$d$text$field[6]";
123           return if $dup{$dupkey};
124           $dup{$dupkey} = $d;
125           
126           my $spot = Spot::add($field[1], $field[2], $d, $text, $spotter);
127           
128           # send orf to the users
129       if ($spot && $pcno == 11) {
130             my $buf = Spot::formatb($field[1], $field[2], $d, $text, $spotter);
131         broadcast_users("$buf\a\a");
132           }
133           
134           last SWITCH;
135         }
136         
137     if ($pcno == 12) {             # announces
138         
139           if ($field[2] eq '*' || $field[2] eq $main::mycall) {
140
141         # strip leading and trailing stuff
142             my $text = unpad($field[3]);
143                 my $target;
144                 my @list;
145                 
146             if ($field[4] eq '*') {          # sysops
147                   $target = "To Sysops";
148                   @list = map { $_->priv >= 5 ? $_ : () } get_all_users();
149                 } elsif ($field[4] gt ' ') {     # speciality list handling
150                   my ($name) = split /\./, $field[4]; 
151           $target = "To $name";          # put the rest in later (if bothered) 
152         } 
153                 
154         $target = "WX" if $field[6] eq '1';
155                 $target = "To All" if !$target;
156                 
157                 if (@list > 0) {
158                   broadcast_list("$target de $field[1]: $text", @list);
159                 } else {
160                   broadcast_users("$target de $field[1]: $text");
161                 }
162                 
163                 return if $field[2] eq $main::mycall;   # it's routed to me
164           } else {
165             route($field[2], $line);
166                 return;                     # only on a routed one
167           }
168           
169           last SWITCH;
170         }
171         
172     if ($pcno == 13) {last SWITCH;}
173     if ($pcno == 14) {last SWITCH;}
174     if ($pcno == 15) {last SWITCH;}
175         
176     if ($pcno == 16) {              # add a user
177           my $node = DXCluster->get($field[1]);
178           last SWITCH if !$node;        # ignore if havn't seen a PC19 for this one yet
179           my $i;
180           
181           for ($i = 2; $i < $#field; $i++) {
182             my ($call, $confmode, $here) = $field[$i] =~ /^(\w+) (-) (\d)/o;
183                 next if length $call < 3;
184                 next if !$confmode;
185                 $call = uc $call;
186         $call =~ s/-\d+$//o;        # remove ssid
187                 next if DXCluster->get($call);    # we already have this (loop?)
188                 
189                 $confmode = $confmode eq '*';
190                 DXNodeuser->new($self, $node, $call, $confmode, $here);
191                 
192                 # add this station to the user database, if required
193                 my $user = DXUser->get_current($call);
194                 $user = DXUser->new($call) if !$user;
195                 $user->node($node->call) if !$user->node;
196                 $user->put;
197           }
198           
199           # queue up any messages (look for privates only)
200           DXMsg::queue_msg(1) if $self->state eq 'normal';     
201           last SWITCH;
202         }
203         
204     if ($pcno == 17) {              # remove a user
205           my $ref = DXCluster->get($field[1]);
206           $ref->del() if $ref;
207           last SWITCH;
208         }
209         
210     if ($pcno == 18) {              # link request
211           $self->send_local_config();
212           $self->send(pc20());
213       $self->state('init');     
214           last SWITCH;
215         }
216         
217     if ($pcno == 19) {               # incoming cluster list
218       my $i;
219           for ($i = 1; $i < $#field-1; $i += 4) {
220             my $here = $field[$i];
221             my $call = uc $field[$i+1];
222                 my $confmode = $field[$i+2] eq '*';
223                 my $ver = $field[$i+3];
224
225                 # now check the call over
226                 next if DXCluster->get($call);   # we already have this
227                 
228                 # check for sane parameters
229                 next if $ver < 5000;             # only works with version 5 software
230                 next if length $call < 3;        # min 3 letter callsigns
231         DXNode->new($self, $call, $confmode, $here, $ver);
232
233         # unbusy and stop and outgoing mail (ie if somehow we receive another PC19 without a disconnect)
234                 my $mref = DXMsg::get_busy($call);
235                 $mref->stop_msg($self) if $mref;
236           }
237           
238           # queue up any messages
239           DXMsg::queue_msg() if $self->state eq 'normal';     
240           last SWITCH;
241         }
242         
243     if ($pcno == 20) {              # send local configuration
244           $self->send_local_config();
245           $self->send(pc22());
246           $self->state('normal');
247           
248           # queue mail
249           DXMsg::queue_msg();
250           return;
251         }
252         
253     if ($pcno == 21) {             # delete a cluster from the list
254           my $call = uc $field[1];
255           if ($call ne $main::mycall) {              # don't allow malicious buggers to disconnect me!
256             my $ref = DXCluster->get($call);
257             $ref->del() if $ref;
258           }
259           last SWITCH;
260         }
261         
262     if ($pcno == 22) {last SWITCH;}
263
264     if ($pcno == 23 || $pcno == 27) {  # WWV info
265           Geomag::update(@field[1..$#field]);
266       last SWITCH;
267         }
268
269     if ($pcno == 24) {             # set here status
270           my $call = uc $field[1];
271           $call =~ s/-\d+//o;
272           my $ref = DXCluster->get($call);
273           $ref->here($field[2]) if $ref;
274           last SWITCH;
275         }
276         
277     if ($pcno == 25) {last SWITCH;}
278
279     if (($pcno >= 28 && $pcno <= 33) || $pcno == 40 || $pcno == 42) {   # mail/file handling
280           DXMsg::process($self, $line);
281           return;
282         }
283         
284     if ($pcno == 34 || $pcno == 36) {   # remote commands (incoming)
285           last SWITCH;
286         }
287         
288     if ($pcno == 35) {                  # remote command replies
289           last SWITCH;
290         }
291         
292     if ($pcno == 37) {last SWITCH;}
293     
294         if ($pcno == 38) {                  # node connected list from neighbour
295           return;
296         }
297
298     if ($pcno == 39) {              # incoming disconnect
299       $self->disconnect();
300           return;
301         }
302         
303     if ($pcno == 41) {              # user info
304       # add this station to the user database, if required
305           $field[1] =~ s/-\d+$//o;
306           my $user = DXUser->get_current($field[1]);
307           $user = DXUser->new($field[1]) if !$user;
308           
309           if ($field[2] == 1) {
310             $user->name($field[3]);
311           } elsif ($field[2] == 2) {
312             $user->qth($field[3]);
313           } elsif ($field[2] == 3) {
314         my ($latd, $latm, $latl, $longd, $longm, $longl) = split /\s+/, $field[3];
315                 $longd += ($longm/60);
316                 $longd = 0-$longd if (uc $longl) eq 'W'; 
317                 $user->long($longd);
318                 $latd += ($latm/60);
319                 $latd = 0-$latd if (uc $latl) eq 'S';
320                 $user->lat($latd);
321           } elsif ($field[2] == 4) {
322             $user->node($field[3]);
323           }
324           $user->put;
325           last SWITCH;
326         }
327     if ($pcno == 43) {last SWITCH;}
328     if ($pcno == 44) {last SWITCH;}
329     if ($pcno == 45) {last SWITCH;}
330     if ($pcno == 46) {last SWITCH;}
331     if ($pcno == 47) {last SWITCH;}
332     if ($pcno == 48) {last SWITCH;}
333     if ($pcno == 49) {last SWITCH;}
334         
335     if ($pcno == 50) {              # keep alive/user list
336           my $ref = DXCluster->get($field[1]);
337           $ref->update_users($field[2]) if $ref;
338           last SWITCH;
339         }
340         
341     if ($pcno == 51) {              # incoming ping requests/answers
342           
343           # is it for us?
344           if ($field[1] eq $main::mycall) {
345             my $flag = $field[3];
346             $flag ^= 1;
347             $self->send($self->pc51($field[2], $field[1], $flag));
348           } else {
349             # route down an appropriate thingy
350                 route($field[1], $line);
351           }
352           return;
353         }
354   }
355   
356   # if get here then rebroadcast the thing with its Hop count decremented (if
357   # there is one). If it has a hop count and it decrements to zero then don't
358   # rebroadcast it.
359   #
360   # NOTE - don't arrive here UNLESS YOU WANT this lump of protocol to be
361   #        REBROADCAST!!!!
362   #
363   
364   my $hops;
365   if (($hops) = $line =~ /H(\d+)\^\~?$/o) {
366         my $newhops = $hops - 1;
367         if ($newhops > 0) {
368           $line =~ s/\^H$hops(\^\~?)$/\^H$newhops$1/;       # change the hop count
369           broadcast_ak1a($line, $self);             # send it to everyone but me
370         }
371   }
372 }
373
374 #
375 # This is called from inside the main cluster processing loop and is used
376 # for despatching commands that are doing some long processing job
377 #
378 sub process
379 {
380   my $t = time;
381   my @chan = DXChannel->get_all();
382   my $chan;
383   
384   foreach $chan (@chan) {
385     next if !$chan->is_ak1a();
386
387     # send a pc50 out on this channel
388     if ($t >= $chan->pc50_t + $DXProt::pc50_interval) {
389       $chan->send(pc50());
390           $chan->pc50_t($t);
391         }
392   }
393   
394   my $key;
395   my $val;
396   my $cutoff;
397   if ($main::systime - 3600 > $last_hour) {
398     $cutoff  = $main::systime - $pc11_dup_age;
399         while (($key, $val) = each %dup) {
400           delete $dup{$key} if $val < $cutoff;
401         }
402         $last_hour = $main::systime;
403   }
404 }
405
406 #
407 # finish up a pc context
408 #
409 sub finish
410 {
411   my $self = shift;
412   my $ref = DXCluster->get($self->call);
413
414   # unbusy and stop and outgoing mail
415   my $mref = DXMsg::get_busy($self->call);
416   $mref->stop_msg($self) if $mref;
417   
418   # broadcast to all other nodes that all the nodes connected to via me are gone
419   my @gonenodes = map { $_->dxchan == $self ? $_ : () } DXNode::get_all();
420   my $node;
421
422   foreach $node (@gonenodes) {
423     next if $node->call eq $self->call; 
424     broadcast_ak1a(pc21($node->call, 'Gone'), $self);    # done like this 'cos DXNodes don't have a pc21 method
425         $node->del();
426   }
427
428   # now broadcast to all other ak1a nodes that I have gone
429   broadcast_ak1a(pc21($self->call, 'Gone.'), $self);
430   $ref->del() if $ref;
431 }
432
433 #
434 # some active measures
435 #
436
437 sub send_local_config
438 {
439   my $self = shift;
440   my $n;
441
442   # send our nodes
443   my @nodes = DXNode::get_all();
444   
445   # create a list of all the nodes that are not connected to this connection
446   @nodes = map { $_->dxchan != $self ? $_ : () } @nodes;
447   $self->send($me->pc19(@nodes));
448           
449   # get all the users connected on the above nodes and send them out
450   foreach $n (@nodes) {
451     my @users = values %{$n->list};
452     $self->send(DXProt::pc16($n, @users));
453   }
454 }
455
456 #
457 # route a message down an appropriate interface for a callsign
458 #
459 # is called route(to, pcline);
460 #
461 sub route
462 {
463   my ($call, $line) = @_;
464   my $cl = DXCluster->get($call);
465   if ($cl) {
466     my $hops;
467         my $dxchan = $cl->{dxchan};
468         if (($hops) = $line =~ /H(\d+)\^\~?$/o) {
469           my $newhops = $hops - 1;
470           if ($newhops > 0) {
471             $line =~ s/\^H$hops(\^\~?)$/\^H$newhops$1/;       # change the hop count
472                 $dxchan->send($line) if $dxchan;
473           }
474         } else {
475           $dxchan->send($line) if $dxchan;                    # for them wot don't have Hops
476         }
477   }
478 }
479
480 # broadcast a message to all clusters [except those mentioned after buffer]
481 sub broadcast_ak1a
482 {
483   my $s = shift;                  # the line to be rebroadcast
484   my @except = @_;                # to all channels EXCEPT these (dxchannel refs)
485   my @chan = get_all_ak1a();
486   my $chan;
487   
488   foreach $chan (@chan) {
489      next if grep $chan == $_, @except;
490          $chan->send($s);              # send it if it isn't the except list
491   }
492 }
493
494 # broadcast to all users
495 sub broadcast_users
496 {
497   my $s = shift;                  # the line to be rebroadcast
498   my @except = @_;                # to all channels EXCEPT these (dxchannel refs)
499   my @chan = get_all_users();
500   my $chan;
501   
502   foreach $chan (@chan) {
503     next if grep $chan == $_, @except;
504         $chan->send($s);              # send it if it isn't the except list
505   }
506 }
507
508 # broadcast to a list of users
509 sub broadcast_list
510 {
511   my $s = shift;
512   my $chan;
513   
514   foreach $chan (@_) {
515         $chan->send($s);              # send it 
516   }
517 }
518
519 #
520 # gimme all the ak1a nodes
521 #
522 sub get_all_ak1a
523 {
524   my @list = DXChannel->get_all();
525   my $ref;
526   my @out;
527   foreach $ref (@list) {
528     push @out, $ref if $ref->is_ak1a;
529   }
530   return @out;
531 }
532
533 # return a list of all users
534 sub get_all_users
535 {
536   my @list = DXChannel->get_all();
537   my $ref;
538   my @out;
539   foreach $ref (@list) {
540     push @out, $ref if $ref->is_user;
541   }
542   return @out;
543 }
544
545 # return a list of all user callsigns
546 sub get_all_user_calls
547 {
548   my @list = DXChannel->get_all();
549   my $ref;
550   my @out;
551   foreach $ref (@list) {
552     push @out, $ref->call if $ref->is_user;
553   }
554   return @out;
555 }
556
557 #
558 # obtain the hops from the list for this callsign and pc no 
559 #
560
561 sub get_hops
562 {
563   my ($pcno) = @_;
564   my $hops = $DXProt::hopcount{$pcno};
565   $hops = $DXProt::def_hopcount if !$hops;
566   return "H$hops";       
567 }
568
569 # remove leading and trailing spaces from an input string
570 sub unpad
571 {
572   my $s = shift;
573   $s =~ s/^\s+|\s+$//;
574   return $s;
575 }
576 1;
577 __END__