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 Carp;
  20 use DXDebug;
  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 sub DESTROY
  96 {
  97   my $self = shift;
  98   dbg('cluster', "destroying $self->{call}\n");
  99 }
 100
 101 no strict;
 102 sub AUTOLOAD
 103 {
 104   my $self = shift;
 105   my $name = $AUTOLOAD;
 106
 107   return if $name =~ /::DESTROY$/;
 108   $name =~ s/.*:://o;
 109
 110   confess "Non-existant field '$AUTOLOAD'" if !$valid{$name};
 111   @_ ? $self->{$name} = shift : $self->{$name} ;
 112 }
 113
 114 #
 115 # USER special routines
 116 #
 117
 118 package DXNodeuser;
 119
 120 @ISA = qw(DXCluster);
 121
 122 use DXDebug;
 123
 124 use strict;
 125 use vars qw($users);
 126
 127 $users = 0;
 128
 129 sub new
 130 {
 131   my ($pkg, $dxchan, $node, $call, $confmode, $here) = @_;
 132
 133   die "tried to add $call when it already exists" if DXCluster->get($call);
 134
 135   my $self = $pkg->alloc($dxchan, $call, $confmode, $here);
 136   $self->{mynode} = $node;
 137   $node->{list}->{$call} = $self;     # add this user to the list on this node
 138   $users++;
 139   dbg('cluster', "allocating user $call to $node->{call} in cluster\n");
 140   return $self;
 141 }
 142
 143 sub del
 144 {
 145   my $self = shift;
 146   my $call = $self->{call};
 147   my $node = $self->{mynode};
 148
 149   delete $node->{list}->{$call};
 150   delete $DXCluster::cluster{$call};     # remove me from the cluster table
 151   dbg('cluster', "deleting user $call from $node->{call} in cluster\n");
 152   $users-- if $users > 0;
 153 }
 154
 155 sub count
 156 {
 157   return $users;                 # + 1 for ME (naf eh!)
 158 }
 159
 160 no strict;
 161
 162 #
 163 # NODE special routines
 164 #
 165
 166 package DXNode;
 167
 168 @ISA = qw(DXCluster);
 169
 170 use DXDebug;
 171
 172 use strict;
 173 use vars qw($nodes);
 174
 175 $nodes = 0;
 176
 177 sub new
 178 {
 179   my ($pkg, $dxchan, $call, $confmode, $here, $pcversion) = @_;
 180   my $self = $pkg->alloc($dxchan, $call, $confmode, $here);
 181   $self->{pcversion} = $pcversion;
 182   $self->{list} = { } ;
 183   $nodes++;
 184   dbg('cluster', "allocating node $call to cluster\n");
 185   return $self;
 186 }
 187
 188 # get all the nodes
 189 sub get_all
 190 {
 191   my $list;
 192   my @out;
 193   foreach $list (values(%DXCluster::cluster)) {
 194     push @out, $list if $list->{pcversion};
 195   }
 196   return @out;
 197 }
 198
 199 sub del
 200 {
 201   my $self = shift;
 202   my $call = $self->{call};
 203   my $ref;
 204
 205   # delete all the listed calls
 206   foreach $ref (values %{$self->{list}}) {
 207     $ref->del();      # this also takes them out of this list
 208   }
 209   dbg('cluster', "deleting node $call from cluster\n");
 210   $nodes-- if $nodes > 0;
 211 }
 212
 213 sub update_users
 214 {
 215   my $self = shift;
 216   if (%{$self->{list}}) {
 217     $self->{users} = scalar %{$self->{list}};
 218   } else {
 219     $self->{users} = shift;
 220   }
 221 }
 222
 223 sub count
 224 {
 225   return $nodes;           # + 1 for ME!
 226 }
 227
 228 sub dolist
 229 {
 230
 231 }
 232 1;
 233 __END__