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 Exporter;
  18 @ISA = qw(Exporter);
  19 use DXDebug;
  20 use Carp;
  21
  22 use strict;
  23 use vars qw(%cluster %valid);
  24
  25 %cluster = ();            # this is where we store the dxcluster database
  26
  27 %valid = (
  28   mynode => '0,Parent Node,showcall',
  29   call => '0,Callsign',
  30   confmode => '0,Conference Mode,yesno',
  31   here => '0,Here?,yesno',
  32   dxchan => '5,Channel ref',
  33   pcversion => '5,Node Version',
  34   list => '5,User List,dolist',
  35   users => '0,No of Users',
  36 );
  37
  38 sub alloc
  39 {
  40   my ($pkg, $dxchan, $call, $confmode, $here) = @_;
  41   die "$call is already alloced" if $cluster{$call};
  42   my $self = {};
  43   $self->{call} = $call;
  44   $self->{confmode} = $confmode;
  45   $self->{here} = $here;
  46   $self->{dxchan} = $dxchan;
  47
  48   $cluster{$call} = bless $self, $pkg;
  49   return $self;
  50 }
  51
  52 # search for a call in the cluster
  53 sub get
  54 {
  55   my ($pkg, $call) = @_;
  56   return $cluster{$call};
  57 }
  58
  59 # get all
  60 sub get_all
  61 {
  62   return values(%cluster);
  63 }
  64
  65 # return a prompt for a field
  66 sub field_prompt
  67 {
  68   my ($self, $ele) = @_;
  69   return $valid{$ele};
  70 }
  71
  72 # this expects a reference to a list in a node NOT a ref to a node
  73 sub dolist
  74 {
  75   my $self = shift;
  76   my $out;
  77   my $ref;
  78
  79   foreach $ref (@{$self}) {
  80     my $s = $ref->{call};
  81         $s = "($s)" if !$ref->{here};
  82         $out .= "$s ";
  83   }
  84   chop $out;
  85   return $out;
  86 }
  87
  88 # this expects a reference to a node
  89 sub showcall
  90 {
  91   my $self = shift;
  92   return $self->{call};
  93 }
  94
  95 # the answer required by show/cluster
  96 sub cluster
  97 {
  98         my $users = DXCommandmode::get_all();
  99         my $uptime = main::uptime();
 100
 101         return " $DXNode::nodes nodes, $users local / $DXNode::users total users  Max users $DXNode::maxusers  Uptime $uptime";
 102 }
 103
 104 sub DESTROY
 105 {
 106   my $self = shift;
 107   dbg('cluster', "destroying $self->{call}\n");
 108 }
 109
 110 no strict;
 111 sub AUTOLOAD
 112 {
 113   my $self = shift;
 114   my $name = $AUTOLOAD;
 115
 116   return if $name =~ /::DESTROY$/;
 117   $name =~ s/.*:://o;
 118
 119   confess "Non-existant field '$AUTOLOAD'" if !$valid{$name};
 120   @_ ? $self->{$name} = shift : $self->{$name} ;
 121 }
 122
 123 #
 124 # USER special routines
 125 #
 126
 127 package DXNodeuser;
 128
 129 @ISA = qw(DXCluster);
 130
 131 use DXDebug;
 132
 133 use strict;
 134
 135 sub new
 136 {
 137   my ($pkg, $dxchan, $node, $call, $confmode, $here) = @_;
 138
 139   die "tried to add $call when it already exists" if DXCluster->get($call);
 140
 141   my $self = $pkg->alloc($dxchan, $call, $confmode, $here);
 142   $self->{mynode} = $node;
 143   $node->{list}->{$call} = $self;     # add this user to the list on this node
 144   dbg('cluster', "allocating user $call to $node->{call} in cluster\n");
 145   $node->update_users;
 146   return $self;
 147 }
 148
 149 sub del
 150 {
 151   my $self = shift;
 152   my $call = $self->{call};
 153   my $node = $self->{mynode};
 154
 155   delete $node->{list}->{$call};
 156   delete $DXCluster::cluster{$call};     # remove me from the cluster table
 157   dbg('cluster', "deleting user $call from $node->{call} in cluster\n");
 158   $node->update_users;
 159 }
 160
 161 sub count
 162 {
 163   return $DXNode::users;                 # + 1 for ME (naf eh!)
 164 }
 165
 166 no strict;
 167
 168 #
 169 # NODE special routines
 170 #
 171
 172 package DXNode;
 173
 174 @ISA = qw(DXCluster);
 175
 176 use DXDebug;
 177
 178 use strict;
 179 use vars qw($nodes $users $maxusers);
 180
 181 $nodes = 0;
 182 $users = 0;
 183 $maxusers = 0;
 184
 185
 186 sub new
 187 {
 188   my ($pkg, $dxchan, $call, $confmode, $here, $pcversion) = @_;
 189   my $self = $pkg->alloc($dxchan, $call, $confmode, $here);
 190   $self->{pcversion} = $pcversion;
 191   $self->{list} = { } ;
 192   $nodes++;
 193   dbg('cluster', "allocating node $call to cluster\n");
 194   return $self;
 195 }
 196
 197 # get all the nodes
 198 sub get_all
 199 {
 200   my $list;
 201   my @out;
 202   foreach $list (values(%DXCluster::cluster)) {
 203     push @out, $list if $list->{pcversion};
 204   }
 205   return @out;
 206 }
 207
 208 sub del
 209 {
 210   my $self = shift;
 211   my $call = $self->{call};
 212   my $ref;
 213
 214   # delete all the listed calls
 215   foreach $ref (values %{$self->{list}}) {
 216     $ref->del();      # this also takes them out of this list
 217   }
 218   delete $DXCluster::cluster{$call};     # remove me from the cluster table
 219   dbg('cluster', "deleting node $call from cluster\n");
 220   $nodes-- if $nodes > 0;
 221 }
 222
 223 sub update_users
 224 {
 225   my $self = shift;
 226   my $count = shift;
 227   $users -= $self->{users};
 228   if ((keys %{$self->{list}})) {
 229     $self->{users} = (keys %{$self->{list}});
 230   } else {
 231     $self->{users} = $count;
 232   }
 233   $users += $self->{users};
 234   $maxusers = $users+$nodes if $users+$nodes > $maxusers;
 235 }
 236
 237 sub count
 238 {
 239   return $nodes;           # + 1 for ME!
 240 }
 241
 242 sub dolist
 243 {
 244
 245 }
 246 1;
 247 __END__