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