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
  20 use strict;
  21
  22 my %cluster = ();            # this is where we store the dxcluster database
  23
  24 my %valid = (
  25   mynode => '0,Parent Node',
  26   call => '0,Callsign',
  27   confmode => '0,Conference Mode,yesno',
  28   here => '0,Here?,yesno',
  29   dxchan => '5,Channel ref',
  30   pcversion => '5,Node Version',
  31 );
  32
  33 sub alloc
  34 {
  35   my ($pkg, $call, $confmode, $here, $dxchan) = @_;
  36   die "$call is already alloced" if $cluster{$call};
  37   my $self = {};
  38   $self->{call} = $call;
  39   $self->{confmode} = $confmode;
  40   $self->{here} = $here;
  41   $self->{dxchan} = $dxchan;
  42
  43   $cluster{$call} = bless $self, $pkg;
  44   return $self;
  45 }
  46
  47 # search for a call in the cluster
  48 sub get
  49 {
  50   my ($pkg, $call) = @_;
  51   return $cluster{$call};
  52 }
  53
  54 # get all
  55 sub get_all
  56 {
  57   return values(%cluster);
  58 }
  59
  60 sub delcluster;
  61 {
  62   my $self = shift;
  63   delete $cluster{$self->{call}};
  64 }
  65
  66
  67 # return a prompt for a field
  68 sub field_prompt
  69 {
  70   my ($self, $ele) = @_;
  71   return $valid{$ele};
  72 }
  73
  74 no strict;
  75 sub AUTOLOAD
  76 {
  77   my $self = shift;
  78   my $name = $AUTOLOAD;
  79
  80   return if $name =~ /::DESTROY$/;
  81   $name =~ s/.*:://o;
  82
  83   die "Non-existant field '$AUTOLOAD'" if !$valid{$name};
  84   @_ ? $self->{$name} = shift : $self->{$name} ;
  85 }
  86
  87 #
  88 # USER special routines
  89 #
  90
  91 package DXNodeuser;
  92
  93 @ISA = qw(DXCluster);
  94
  95 use strict;
  96 my %users = ();
  97
  98 sub new
  99 {
 100   my ($pkg, $mynode, $call, $confmode, $here, $dxchan) = @_;
 101   my $self = $pkg->alloc($call, $confmode, $here, $dxchan);
 102   $self->{mynode} = $mynode;
 103
 104   $users{$call} = $self;
 105   return $self;
 106 }
 107
 108 sub delete
 109 {
 110   my $self = shift;
 111   $self->delcluster();              # out of the whole cluster table
 112   delete $users{$self->{call}};     # out of the users table
 113 }
 114
 115 sub count
 116 {
 117   return %users + 1;                 # + 1 for ME (naf eh!)
 118 }
 119
 120 no strict;
 121
 122 #
 123 # NODE special routines
 124 #
 125
 126 package DXNode;
 127
 128 @ISA = qw(DXCluster);
 129
 130 use strict;
 131 my %nodes = ();
 132
 133 sub new
 134 {
 135   my ($pkg, $call, $confmode, $here, $pcversion, $dxchan) = @_;
 136   my $self = $pkg->alloc($call, $confmode, $here, $dxchan);
 137   $self->{version} = $pcversion;
 138   $nodes{$call} = $self;
 139   return $self;
 140 }
 141
 142 # get a node
 143 sub get
 144 {
 145   my ($pkg, $call) = @_;
 146   return $nodes{$call};
 147 }
 148
 149 # get all the nodes
 150 sub get_all
 151 {
 152   my $list;
 153   my @out;
 154   foreach $list (values(%nodes)) {
 155     push @out, $list if $list->{pcversion};
 156   }
 157   return @out;
 158 }
 159
 160 sub delete
 161 {
 162   my $self = shift;
 163   my $call = $self->call;
 164
 165   DXUser->delete($call);     # delete all the users one this node
 166   delete $nodes{$call};
 167 }
 168
 169 sub count
 170 {
 171   return %nodes + 1;           # + 1 for ME!
 172 }
 173 1;
 174 __END__