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 => 'Parent Node',
  57   call => 'Callsign',
  58   confmode => 'Conference Mode',
  59   here => 'Here?',
  60   dxprot => 'Channel ref',
  61   version => 'Node Version',
  62 );
  63
  64 sub AUTOLOAD
  65 {
  66   my $self = shift;
  67   my $name = $AUTOLOAD;
  68
  69   return if $name =~ /::DESTROY$/;
  70   $name =~ s/.*:://o;
  71
  72   die "Non-existant field '$AUTOLOAD'" if !$valid{$name};
  73   @_ ? $self->{$name} = shift : $self->{$name} ;
  74 }
  75
  76 #
  77 # USER special routines
  78 #
  79
  80 package DXUser;
  81
  82 @ISA = qw(DXCluster);
  83
  84 %users = ();
  85
  86 sub new
  87 {
  88   my ($pkg, $mynode, $call, $confmode, $here, $dxprot) = @_;
  89   my $self = $pkg->alloc($call, $confmode, $here, $dxprot);
  90   $self->{mynode} = $mynode;
  91
  92   $users{$call} = $self;
  93   return $self;
  94 }
  95
  96 sub delete
  97 {
  98   my $self = shift;
  99   $self->delcluster();              # out of the whole cluster table
 100   delete $users{$self->{call}};     # out of the users table
 101 }
 102
 103 sub count
 104 {
 105   return %users + 1;                 # + 1 for ME (naf eh!)
 106 }
 107
 108 #
 109 # NODE special routines
 110 #
 111
 112 package DXNode;
 113
 114 @ISA = qw(DXCluster);
 115
 116 %nodes = ();
 117
 118 sub new
 119 {
 120   my ($pkg, $call, $confmode, $here, $version, $dxprot) = @_;
 121   my $self = $pkg->alloc($call, $confmode, $here, $dxprot);
 122   $self->{version} = $version;
 123   $nodes{$call} = $self;
 124   return $self;
 125 }
 126
 127 # get a node
 128 sub get
 129 {
 130   my ($pkg, $call) = @_;
 131   return $nodes{$call};
 132 }
 133
 134 # get all the nodes
 135 sub get_all
 136 {
 137   my $list;
 138   my @out;
 139   foreach $list (values(%nodes)) {
 140     push @out, $list if $list->{version};
 141   }
 142   return @out;
 143 }
 144
 145 sub delete
 146 {
 147   my $self = shift;
 148   my $call = $self->call;
 149
 150   DXUser->delete($call);     # delete all the users one this node
 151   delete $nodes{$call};
 152 }
 153
 154 sub count
 155 {
 156   return %nodes + 1;           # + 1 for ME!
 157 }
 158 1;
 159 __END__