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