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
  22 use strict;
  23
  24 #
  25 # obtain a new connection this is derived from dxchannel
  26 #
  27
  28 sub new
  29 {
  30   my $self = DXChannel::alloc(@_);
  31   $self->{sort} = 'A';   # in absence of how to find out what sort of an object I am
  32   return $self;
  33 }
  34
  35 # this is how a pc connection starts (for an incoming connection)
  36 # issue a PC38 followed by a PC18, then wait for a PC20 (remembering
  37 # all the crap that comes between).
  38 sub start
  39 {
  40   my ($self, $line) = shift;
  41   my $call = $self->call;
  42
  43   # remember type of connection
  44   $self->{consort} = $line;
  45
  46   # set unbuffered
  47   $self->send_now('B',"0");
  48
  49   # send initialisation string
  50   $self->send($self->pc38()) if DXNode->get_all();
  51   $self->send($self->pc18());
  52   $self->state('normal');
  53   $self->pc50_t(time);
  54 }
  55
  56 #
  57 # This is the normal pcxx despatcher
  58 #
  59 sub normal
  60 {
  61   my ($self, $line) = @_;
  62   my @field = split /[\^\~]/, $line;
  63
  64   # ignore any lines that don't start with PC
  65   return if !$field[0] =~ /^PC/;
  66
  67   # process PC frames
  68   my ($pcno) = $field[0] =~ /^PC(\d\d)/;          # just get the number
  69   return if $pcno < 10 || $pcno > 51;
  70
  71   SWITCH: {
  72     if ($pcno == 10) {last SWITCH;}
  73     if ($pcno == 11) {last SWITCH;}
  74     if ($pcno == 12) {last SWITCH;}
  75     if ($pcno == 13) {last SWITCH;}
  76     if ($pcno == 14) {last SWITCH;}
  77     if ($pcno == 15) {last SWITCH;}
  78     if ($pcno == 16) {last SWITCH;}
  79     if ($pcno == 17) {last SWITCH;}
  80     if ($pcno == 18) {last SWITCH;}
  81     if ($pcno == 19) {last SWITCH;}
  82     if ($pcno == 20) {              # send local configuration
  83
  84       # set our data (manually 'cos we only have a psuedo channel [at the moment])
  85           my $hops = $self->get_hops();
  86           $self->send("PC19^1^$main::mycall^0^$DXProt::myprot_version^$hops^");
  87
  88       # get all the local users and send them out
  89       my @list;
  90           for (@list = DXCommandmode::get_all(); @list; ) {
  91             @list = $self->pc16(@list);
  92             my $out = shift @list;
  93                 $self->send($out);
  94           }
  95           $self->send($self->pc22());
  96           return;
  97         }
  98     if ($pcno == 21) {last SWITCH;}
  99     if ($pcno == 22) {last SWITCH;}
 100     if ($pcno == 23) {last SWITCH;}
 101     if ($pcno == 24) {last SWITCH;}
 102     if ($pcno == 25) {last SWITCH;}
 103     if ($pcno == 26) {last SWITCH;}
 104     if ($pcno == 27) {last SWITCH;}
 105     if ($pcno == 28) {last SWITCH;}
 106     if ($pcno == 29) {last SWITCH;}
 107     if ($pcno == 30) {last SWITCH;}
 108     if ($pcno == 31) {last SWITCH;}
 109     if ($pcno == 32) {last SWITCH;}
 110     if ($pcno == 33) {last SWITCH;}
 111     if ($pcno == 34) {last SWITCH;}
 112     if ($pcno == 35) {last SWITCH;}
 113     if ($pcno == 36) {last SWITCH;}
 114     if ($pcno == 37) {last SWITCH;}
 115     if ($pcno == 38) {last SWITCH;}
 116     if ($pcno == 39) {last SWITCH;}
 117     if ($pcno == 40) {last SWITCH;}
 118     if ($pcno == 41) {last SWITCH;}
 119     if ($pcno == 42) {last SWITCH;}
 120     if ($pcno == 43) {last SWITCH;}
 121     if ($pcno == 44) {last SWITCH;}
 122     if ($pcno == 45) {last SWITCH;}
 123     if ($pcno == 46) {last SWITCH;}
 124     if ($pcno == 47) {last SWITCH;}
 125     if ($pcno == 48) {last SWITCH;}
 126     if ($pcno == 49) {last SWITCH;}
 127     if ($pcno == 50) {
 128           last SWITCH;
 129         }
 130     if ($pcno == 51) {              # incoming ping requests/answers
 131
 132           # is it for us?
 133           if ($field[1] eq $main::mycall) {
 134             my $flag = $field[3];
 135             $flag ^= 1;
 136             $self->send($self->pc51($field[2], $field[1], $flag));
 137           } else {
 138             # route down an appropriate thingy
 139                 $self->route($field[1], $line);
 140           }
 141           return;
 142         }
 143   }
 144
 145   # if get here then rebroadcast the thing with its Hop count decremented (if
 146   # the is one). If it has a hop count and it decrements to zero then don't
 147   # rebroadcast it.
 148   #
 149   # NOTE - don't arrive here UNLESS YOU WANT this lump of protocol to be
 150   #        REBROADCAST!!!!
 151   #
 152
 153   my $hopfield = pop @field;
 154   push @field, $hopfield;
 155
 156   if ($hopfield =~ /H\d\d./o) {
 157     my ($hops) = $hopfield =~ /H(\d+)/o;
 158         $hops--;
 159         if ($hops > 0) {
 160           $line =~ s/\^H\d+(\^\~.)$/\^H$hops$1/;       # change the hop count
 161           DXProt->broadcast($line, $self);             # send it to everyone but me
 162         }
 163   }
 164 }
 165
 166 #
 167 # This is called from inside the main cluster processing loop and is used
 168 # for despatching commands that are doing some long processing job
 169 #
 170 sub process
 171 {
 172   my $t = time;
 173   my @chan = DXChannel->get_all();
 174   my $chan;
 175
 176   foreach $chan (@chan) {
 177     next if !$chan->is_ak1a();
 178
 179     # send a pc50 out on this channel
 180     if ($t >= $chan->pc50_t + $DXProt::pc50_interval) {
 181       $chan->send(pc50());
 182           $chan->pc50_t($t);
 183         }
 184   }
 185 }
 186
 187 #
 188 # finish up a pc context
 189 #
 190 sub finish
 191 {
 192
 193 }
 194
 195 #
 196 # add a (local) user to the cluster
 197 #
 198
 199 sub adduser
 200 {
 201
 202 }
 203
 204 #
 205 # delete a (local) user to the cluster
 206 #
 207
 208 sub deluser
 209 {
 210
 211 }
 212
 213 #
 214 # add a (locally connected) node to the cluster
 215 #
 216
 217 sub addnode
 218 {
 219
 220 }
 221
 222 #
 223 # delete a (locally connected) node to the cluster
 224 #
 225 sub delnode
 226 {
 227
 228 }
 229
 230 #
 231 # some active measures
 232 #
 233
 234 #
 235 # route a message down an appropriate interface for a callsign
 236 #
 237 # expects $self to indicate 'from' and is called $self->route(from, pcline);
 238 #
 239 sub route
 240 {
 241
 242 }
 243
 244 # broadcast a message to all clusters [except those mentioned after buffer]
 245 sub broadcast
 246 {
 247   my $pkg = shift;                # ignored
 248   my $s = shift;                  # the line to be rebroadcast
 249   my @except = @_;                # to all channels EXCEPT these (dxchannel refs)
 250   my @chan = DXChannel->get_all();
 251   my ($chan, $except);
 252
 253 L: foreach $chan (@chan) {
 254      next if !$chan->sort eq 'A';  # only interested in ak1a channels
 255          foreach $except (@except) {
 256            next L if $except == $chan;  # ignore channels in the 'except' list
 257          }
 258          chan->send($s);              # send it
 259   }
 260 }
 261
 262 #
 263 # gimme all the ak1a nodes
 264 #
 265 sub get_all
 266 {
 267   my @list = DXChannel->get_all();
 268   my $ref;
 269   my @out;
 270   foreach $ref (@list) {
 271     push @out, $ref if $ref->sort eq 'A';
 272   }
 273   return @out;
 274 }
 275
 276 #
 277 # obtain the hops from the list for this callsign and pc no
 278 #
 279
 280 sub get_hops
 281 {
 282   my ($self, $pcno) = @_;
 283   return "H$DXProt::def_hopcount";       # for now
 284 }
 285
 286 #
 287 # All the PCxx generation routines
 288 #
 289
 290 #
 291 # add one or more users (I am expecting references that have 'call',
 292 # 'confmode' & 'here' method)
 293 #
 294 # NOTE this sends back a list containing the PC string (first element)
 295 # and the rest of the users not yet processed
 296 #
 297 sub pc16
 298 {
 299   my $self = shift;
 300   my @list = @_;       # list of users
 301   my @out = ('PC16', $main::mycall);
 302   my $i;
 303
 304   for ($i = 0; @list && $i < $DXProt::pc16_max_users; $i++) {
 305     my $ref = shift @list;
 306         my $call = $ref->call;
 307         my $s = sprintf "%s %s %d", $call, $ref->confmode ? '*' : '-', $ref->here;
 308         push @out, $s;
 309   }
 310   push @out, $self->get_hops();
 311   my $str = join '^', @out;
 312   $str .= '^';
 313   return ($str, @list);
 314 }
 315
 316 # Request init string
 317 sub pc18
 318 {
 319   return "PC18^wot a load of twaddle^$DXProt::myprot_version^~";
 320 }
 321
 322 #
 323 # add one or more nodes
 324 #
 325 # NOTE this sends back a list containing the PC string (first element)
 326 # and the rest of the nodes not yet processed (as PC16)
 327 #
 328 sub pc19
 329 {
 330   my $self = shift;
 331   my @list = @_;       # list of users
 332   my @out = ('PC19', $main::mycall);
 333   my $i;
 334
 335   for ($i = 0; @list && $i < $DXProt::pc19_max_nodes; $i++) {
 336     my $ref = shift @list;
 337         push @out, $ref->here, $ref->call, $ref->confmode, $ref->pcversion;
 338   }
 339   push @out, $self->get_hops();
 340   my $str = join '^', @out;
 341   $str .= '^';
 342   return ($str, @list);
 343 }
 344
 345 # end of Rinit phase
 346 sub pc20
 347 {
 348   return 'PC20^';
 349 }
 350
 351 # delete a node
 352 sub pc21
 353 {
 354   my ($self, $ref, $reason) = @_;
 355   my $call = $ref->call;
 356   my $hops = $self->get_hops();
 357   return "PC21^$call^$reason^$hops^";
 358 }
 359
 360 # end of init phase
 361 sub pc22
 362 {
 363   return 'PC22^';
 364 }
 365
 366 # send all the DX clusters I reckon are connected
 367 sub pc38
 368 {
 369   my @list = DXNode->get_all();
 370   my $list;
 371   my @nodes;
 372
 373   foreach $list (@list) {
 374     push @nodes, $list->call;
 375   }
 376   return "PC38^" . join(',', @nodes) . "^~";
 377 }
 378
 379 # periodic update of users, plus keep link alive device (always H99)
 380 sub pc50
 381 {
 382   my $n = DXNodeuser->count;
 383   return "PC50^$main::mycall^$n^H99^";
 384 }
 385
 386 # generate pings
 387 sub pc51
 388 {
 389   my ($self, $to, $from, $val) = @_;
 390   return "PC51^$to^$from^$val^";
 391 }
 392 1;
 393 __END__