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