perl/DXCluster.pm

   1 #
   2 # DX database control routines
   3 #
   4 # This manages the on-line cluster user 'database'
   5 #
   6 # This should all be pretty trees and things, but for now I
   7 # just can't be bothered. If it becomes an issue I shall
   8 # address it.
   9 #
  10 # Copyright (c) 1998 - Dirk Koopman G1TLH
  11 #
  12 # $Id$
  13 #
  14
  15 package DXCluster;
  16
  17 use DXDebug;
  18 use DXUtil;
  19
  20 use strict;
  21 use vars qw(%cluster %valid);
  22
  23 %cluster = ();                                  # this is where we store the dxcluster database
  24
  25 %valid = (
  26                   mynode => '0,Parent Node',
  27                   call => '0,Callsign',
  28                   confmode => '0,Conference Mode,yesno',
  29                   here => '0,Here?,yesno',
  30                   dxchancall => '5,Channel Call',
  31                   pcversion => '5,Node Version',
  32                   list => '5,User List,DXCluster::dolist',
  33                   users => '0,No of Users',
  34                  );
  35
  36 use vars qw($VERSION $BRANCH);
  37 $VERSION = sprintf( "%d.%03d", q$Revision$ =~ /(\d+)\.(\d+)/ );
  38 $BRANCH = sprintf( "%d.%03d", q$Revision$ =~ /\d+\.\d+\.(\d+)\.(\d+)/ ) || 0;
  39 $main::build += $VERSION;
  40 $main::branch += $BRANCH;
  41
  42 sub alloc
  43 {
  44         my ($pkg, $dxchan, $call, $confmode, $here) = @_;
  45         die "$call is already alloced" if $cluster{$call};
  46         my $self = {};
  47         $self->{call} = $call;
  48         $self->{confmode} = $confmode;
  49         $self->{here} = $here;
  50         $self->{dxchancall} = $dxchan->call;
  51
  52         $cluster{$call} = bless $self, $pkg;
  53         return $self;
  54 }
  55
  56 # get an entry exactly as it is
  57 sub get_exact
  58 {
  59         my ($pkg, $call) = @_;
  60
  61         # belt and braces
  62         $call = uc $call;
  63
  64         # search for 'as is' only
  65         return $cluster{$call};
  66 }
  67
  68 #
  69 # search for a call in the cluster
  70 # taking into account SSIDs
  71 #
  72 sub get
  73 {
  74         my ($pkg, $call) = @_;
  75
  76         # belt and braces
  77         $call = uc $call;
  78
  79         # search for 'as is'
  80         my $ref = $cluster{$call};
  81         return $ref if $ref;
  82
  83         # search for the unSSIDed one
  84         $call =~ s/-\d+$//o;
  85         $ref = $cluster{$call};
  86         return $ref if $ref;
  87
  88         # search for the SSIDed one
  89         my $i;
  90         for ($i = 1; $i < 17; $i++) {
  91                 $ref = $cluster{"$call-$i"};
  92                 return $ref if $ref;
  93         }
  94         return undef;
  95 }
  96
  97 # get all
  98 sub get_all
  99 {
 100         return values(%cluster);
 101 }
 102
 103 # return a prompt for a field
 104 sub field_prompt
 105 {
 106         my ($self, $ele) = @_;
 107         return $valid{$ele};
 108 }
 109 #
 110 # return a list of valid elements
 111 #
 112
 113 sub fields
 114 {
 115         return keys(%valid);
 116 }
 117
 118 # this expects a reference to a list in a node NOT a ref to a node
 119 sub dolist
 120 {
 121         my $self = shift;
 122         my $out;
 123         my $ref;
 124
 125         foreach my $call (keys %{$self}) {
 126                 $ref = $$self{$call};
 127                 my $s = $ref->{call};
 128                 $s = "($s)" if !$ref->{here};
 129                 $out .= "$s ";
 130         }
 131         chop $out;
 132         return $out;
 133 }
 134
 135 # this expects a reference to a node
 136 sub showcall
 137 {
 138         my $self = shift;
 139         return $self->{call};
 140 }
 141
 142 # the answer required by show/cluster
 143 sub cluster
 144 {
 145         my $users = DXCommandmode::get_all();
 146         my $uptime = main::uptime();
 147         my $tot = $DXNode::users;
 148
 149         return " $DXNode::nodes nodes, $users local / $tot total users  Max users $DXNode::maxusers  Uptime $uptime";
 150 }
 151
 152 sub mynode
 153 {
 154         my $self = shift;
 155         my $noderef = shift;
 156
 157         if ($noderef) {
 158                 $self->{mynode} = $noderef->call;
 159         } else {
 160                 $noderef = DXCluster->get_exact($self->{mynode});
 161                 unless ($noderef) {
 162                         my $mynode = $self->{mynode};
 163                         my $call = $self->{call};
 164                         dbg("parent node $mynode has disappeared from $call") if isdbg('err');
 165                 }
 166         }
 167         return $noderef;
 168 }
 169
 170 sub dxchan
 171 {
 172         my $self = shift;
 173         my $dxchan = shift;
 174
 175         if ($dxchan) {
 176                 $self->{dxchancall} = $dxchan->call;
 177         } else {
 178                 $dxchan = DXChannel->get($self->{dxchancall});
 179                 unless ($dxchan) {
 180                         my $dxcall = $self->{dxchancall};
 181                         my $call = $self->{call};
 182                         dbg("parent dxchan $dxcall has disappeared from $call") if isdbg('err');
 183                 }
 184         }
 185         return $dxchan;
 186 }
 187
 188 no strict;
 189 sub AUTOLOAD
 190 {
 191         my $self = shift;
 192         my $name = $AUTOLOAD;
 193
 194         return if $name =~ /::DESTROY$/;
 195         $name =~ s/.*:://o;
 196
 197         confess "Non-existant field '$AUTOLOAD'" if !$valid{$name};
 198         # this clever line of code creates a subroutine which takes over from autoload
 199         # from OO Perl - Conway
 200         *{$AUTOLOAD} = sub {@_ > 1 ? $_[0]->{$name} = $_[1] : $_[0]->{$name}} ;
 201         @_ ? $self->{$name} = shift : $self->{$name} ;
 202 }
 203
 204 #
 205 # USER special routines
 206 #
 207
 208 package DXNodeuser;
 209
 210 @ISA = qw(DXCluster);
 211
 212 use DXDebug;
 213
 214 use strict;
 215
 216 sub new
 217 {
 218         my ($pkg, $dxchan, $node, $call, $confmode, $here) = @_;
 219
 220         die "tried to add $call when it already exists" if DXCluster->get_exact($call);
 221
 222         my $self = $pkg->alloc($dxchan, $call, $confmode, $here);
 223         $self->{mynode} = $node->call;
 224         $node->add_user($call, $self);
 225         dbg("allocating user $call to $node->{call} in cluster\n") if isdbg('cluster');
 226         return $self;
 227 }
 228
 229 sub del
 230 {
 231         my $self = shift;
 232         my $call = $self->{call};
 233         my $node = $self->mynode;
 234
 235         $node->del_user($call);
 236         dbg("deleting user $call from $node->{call} in cluster\n") if isdbg('cluster');
 237 }
 238
 239 sub count
 240 {
 241         return $DXNode::users;          # + 1 for ME (naf eh!)
 242 }
 243
 244 no strict;
 245
 246 #
 247 # NODE special routines
 248 #
 249
 250 package DXNode;
 251
 252 @ISA = qw(DXCluster);
 253
 254 use DXDebug;
 255
 256 use strict;
 257 use vars qw($nodes $users $maxusers);
 258
 259 $nodes = 0;
 260 $users = 0;
 261 $maxusers = 0;
 262
 263
 264 sub new
 265 {
 266         my ($pkg, $dxchan, $call, $confmode, $here, $pcversion) = @_;
 267         my $self = $pkg->alloc($dxchan, $call, $confmode, $here);
 268         $self->{pcversion} = $pcversion;
 269         $self->{list} = { } ;
 270         $self->{mynode} = $self->call;  # for sh/station
 271         $self->{users} = 0;
 272         $nodes++;
 273         dbg("allocating node $call to cluster\n") if isdbg('cluster');
 274         return $self;
 275 }
 276
 277 # get all the nodes
 278 sub get_all
 279 {
 280         my $list;
 281         my @out;
 282         foreach $list (values(%DXCluster::cluster)) {
 283                 push @out, $list if $list->{pcversion};
 284         }
 285         return @out;
 286 }
 287
 288 sub del
 289 {
 290         my $self = shift;
 291         my $call = $self->{call};
 292         my $ref;
 293
 294         # delete all the listed calls
 295         foreach $ref (values %{$self->{list}}) {
 296                 $ref->del();                    # this also takes them out of this list
 297         }
 298         delete $DXCluster::cluster{$call}; # remove me from the cluster table
 299         dbg("deleting node $call from cluster\n") if isdbg('cluster');
 300         $users -= $self->{users};    # it may be PC50 updated only therefore > 0
 301         $users = 0 if $users < 0;
 302         $nodes--;
 303         $nodes = 0 if $nodes < 0;
 304 }
 305
 306 sub add_user
 307 {
 308         my $self = shift;
 309         my $call = shift;
 310         my $ref = shift;
 311
 312         $self->{list}->{$call} = $ref; # add this user to the list on this node
 313         $self->{users} = keys %{$self->{list}};
 314         $users++;
 315         $maxusers = $users+$nodes if $users+$nodes > $maxusers;
 316 }
 317
 318 sub del_user
 319 {
 320         my $self = shift;
 321         my $call = shift;
 322
 323         delete $self->{list}->{$call};
 324         delete $DXCluster::cluster{$call}; # remove me from the cluster table
 325         $self->{users} = keys %{$self->{list}};
 326         $users--;
 327         $users = 0, warn "\$users gone neg, reset" if $users < 0;
 328         $maxusers = $users+$nodes if $users+$nodes > $maxusers;
 329 }
 330
 331 sub update_users
 332 {
 333         my $self = shift;
 334         my $count = shift;
 335         $count = 0 unless $count;
 336
 337         $users -= $self->{users};
 338         $self->{users} = $count unless keys %{$self->{list}};
 339         $users += $self->{users};
 340         $maxusers = $users+$nodes if $users+$nodes > $maxusers;
 341 }
 342
 343 sub count
 344 {
 345         return $nodes;                          # + 1 for ME!
 346 }
 347
 348 sub dolist
 349 {
 350
 351 }
 352
 353 sub DESTROY
 354 {
 355         my $self = shift;
 356         undef $self->{list} if $self->{list};
 357 }
 358
 359
 360 1;
 361 __END__