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 my $users = 0;
 126
 127 sub new
 128 {
 129   my ($pkg, $dxchan, $node, $call, $confmode, $here) = @_;
 130
 131   die "tried to add $call when it already exists" if DXCluster->get($call);
 132
 133   my $self = $pkg->alloc($dxchan, $call, $confmode, $here);
 134   $self->{mynode} = $node;
 135   $node->{list}->{$call} = $self;     # add this user to the list on this node
 136   $users++;
 137   dbg('cluster', "allocating user $call to $node->{call} in cluster\n");
 138   return $self;
 139 }
 140
 141 sub del
 142 {
 143   my $self = shift;
 144   my $call = $self->{call};
 145   my $node = $self->{mynode};
 146
 147   delete $node->{list}->{$call};
 148   delete $DXCluster::cluster{$call};     # remove me from the cluster table
 149   dbg('cluster', "deleting user $call from $node->{call} in cluster\n");
 150   $users-- if $users > 0;
 151 }
 152
 153 sub count
 154 {
 155   return $users;                 # + 1 for ME (naf eh!)
 156 }
 157
 158 no strict;
 159
 160 #
 161 # NODE special routines
 162 #
 163
 164 package DXNode;
 165
 166 @ISA = qw(DXCluster);
 167
 168 use DXDebug;
 169
 170 use strict;
 171 my $nodes = 0;
 172
 173 sub new
 174 {
 175   my ($pkg, $dxchan, $call, $confmode, $here, $pcversion) = @_;
 176   my $self = $pkg->alloc($dxchan, $call, $confmode, $here);
 177   $self->{version} = $pcversion;
 178   $self->{list} = { } ;
 179   $nodes++;
 180   dbg('cluster', "allocating node $call to cluster\n");
 181   return $self;
 182 }
 183
 184 # get all the nodes
 185 sub get_all
 186 {
 187   my $list;
 188   my @out;
 189   foreach $list (values(%DXCluster::cluster)) {
 190     push @out, $list if $list->{pcversion};
 191   }
 192   return @out;
 193 }
 194
 195 sub del
 196 {
 197   my $self = shift;
 198   my $call = $self->{call};
 199   my $ref;
 200
 201   # delete all the listed calls
 202   foreach $ref (values %{$self->{list}}) {
 203     $ref->del();      # this also takes them out of this list
 204   }
 205   dbg('cluster', "deleting node $call from cluster\n");
 206   $nodes-- if $nodes > 0;
 207 }
 208
 209 sub update_users
 210 {
 211   my $self = shift;
 212   if (%{$self->{list}}) {
 213     $self->{users} = scalar %{$self->{list}};
 214   } else {
 215     $self->{users} = shift;
 216   }
 217 }
 218
 219 sub count
 220 {
 221   return $nodes;           # + 1 for ME!
 222 }
 223
 224 sub dolist
 225 {
 226
 227 }
 228 1;
 229 __END__