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