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