perl/DXUser.pm

   1 #
   2 # DX cluster user routines
   3 #
   4 # Copyright (c) 1998 - Dirk Koopman G1TLH
   5 #
   6 # $Id$
   7 #
   8
   9 package DXUser;
  10
  11 require Exporter;
  12 @ISA = qw(Exporter);
  13
  14 use MLDBM qw(DB_File);
  15 use Fcntl;
  16 use Carp;
  17
  18 %u = undef;
  19 $dbm = undef;
  20 $filename = undef;
  21
  22 # hash of valid elements and a simple prompt
  23 %valid = (
  24   call => '0,Callsign',
  25   alias => '0,Real Callsign',
  26   name => '0,Name',
  27   qth => '0,Home QTH',
  28   lat => '0,Latitude,slat',
  29   long => '0,Longitude,slong',
  30   qra => '0,Locator',
  31   email => '0,E-mail Address',
  32   priv => '9,Privilege Level',
  33   lastin => '0,Last Time in,cldatetime',
  34   passwd => '9,Password',
  35   addr => '0,Full Address',
  36   sort => '0,Type of User',                # A - ak1a, U - User, S - spider cluster, B - BBS
  37   xpert => '0,Expert Status,yesno',
  38   bbs => '0,Home BBS',
  39   node => '0,Home Node',
  40   lockout => '9,Locked out?,yesno',        # won't let them in at all
  41   dxok => '9,DX Spots?,yesno',            # accept his dx spots?
  42   annok => '9,Announces?,yesno',            # accept his announces?
  43   reg => '0,Registered?,yesno',            # is this user registered?
  44 );
  45
  46 sub AUTOLOAD
  47 {
  48   my $self = shift;
  49   my $name = $AUTOLOAD;
  50
  51   return if $name =~ /::DESTROY$/;
  52   $name =~ s/.*:://o;
  53
  54   confess "Non-existant field '$AUTOLOAD'" if !$valid{$name};
  55   if (@_) {
  56     $self->{$name} = shift;
  57         $self->put();
  58   }
  59   return $self->{$name};
  60 }
  61
  62 #
  63 # initialise the system
  64 #
  65 sub init
  66 {
  67   my ($pkg, $fn) = @_;
  68
  69   die "need a filename in User" if !$fn;
  70   $dbm = tie %u, MLDBM, $fn, O_CREAT|O_RDWR, 0666 or die "can't open user file: $fn ($!)";
  71   $filename = $fn;
  72 }
  73
  74 #
  75 # close the system
  76 #
  77
  78 sub finish
  79 {
  80   $dbm = undef;
  81   untie %u;
  82 }
  83
  84 #
  85 # new - create a new user
  86 #
  87
  88 sub new
  89 {
  90   my ($pkg, $call) = @_;
  91   die "can't create existing call $call in User\n!" if $u{$call};
  92
  93   my $self = {};
  94   $self->{call} = $call;
  95   $self->{sort} = 'U';
  96   $self->{dxok} = 1;
  97   $self->{annok} = 1;
  98   bless $self, $pkg;
  99   $u{call} = $self;
 100 }
 101
 102 #
 103 # get - get an existing user - this seems to return a different reference everytime it is
 104 #       called - see below
 105 #
 106
 107 sub get
 108 {
 109   my ($pkg, $call) = @_;
 110   return $u{$call};
 111 }
 112
 113 #
 114 # get an existing either from the channel (if there is one) or from the database
 115 #
 116 # It is important to note that if you have done a get (for the channel say) and you
 117 # want access or modify that you must use this call (and you must NOT use get's all
 118 # over the place willy nilly!)
 119 #
 120
 121 sub get_current
 122 {
 123   my ($pkg, $call) = @_;
 124   my $dxchan = DXChannel->get($call);
 125   return $dxchan->user if $dxchan;
 126   return $u{$call};
 127 }
 128
 129 #
 130 # put - put a user
 131 #
 132
 133 sub put
 134 {
 135   my $self = shift;
 136   my $call = $self->{call};
 137   $u{$call} = $self;
 138 }
 139
 140 #
 141 # del - delete a user
 142 #
 143
 144 sub del
 145 {
 146   my $self = shift;
 147   my $call = $self->{call};
 148   delete $u{$call};
 149 }
 150
 151 #
 152 # close - close down a user
 153 #
 154
 155 sub close
 156 {
 157   my $self = shift;
 158   $self->{lastin} = time;
 159   $self->put();
 160 }
 161
 162 #
 163 # return a list of valid elements
 164 #
 165
 166 sub fields
 167 {
 168   return keys(%valid);
 169 }
 170
 171 #
 172 # return a prompt for a field
 173 #
 174
 175 sub field_prompt
 176 {
 177   my ($self, $ele) = @_;
 178   return $valid{$ele};
 179 }
 180
 181 #
 182 # enter an element from input, returns 1 for success
 183 #
 184
 185 sub enter
 186 {
 187   my ($self, $ele, $value) = @_;
 188   return 0 if (!defined $valid{$ele});
 189   chomp $value;
 190   return 0 if $value eq "";
 191   if ($ele eq 'long') {
 192     my ($longd, $longm, $longl) = $value =~ /(\d+) (\d+) ([EWew])/;
 193         return 0 if (!$longl || $longd < 0 || $longd > 180 || $longm < 0 || $longm > 59);
 194         $longd += ($longm/60);
 195         $longd = 0-$longd if (uc $longl) eq 'W';
 196         $self->{'long'} = $longd;
 197         return 1;
 198   } elsif ($ele eq 'lat') {
 199     my ($latd, $latm, $latl) = $value =~ /(\d+) (\d+) ([NSns])/;
 200         return 0 if (!$latl || $latd < 0 || $latd > 90 || $latm < 0 || $latm > 59);
 201         $latd += ($latm/60);
 202         $latd = 0-$latd if (uc $latl) eq 'S';
 203         $self->{'lat'} = $latd;
 204         return 1;
 205   } elsif ($ele eq 'qra') {
 206     $self->{'qra'} = UC $value;
 207         return 1;
 208   } else {
 209     $self->{$ele} = $value;               # default action
 210         return 1;
 211   }
 212   return 0;
 213 }
 214
 215 # some variable accessors
 216 sub sort
 217 {
 218   my $self = shift;
 219   @_ ? $self->{sort} = shift : $self->{sort} ;
 220 }
 221 1;
 222 __END__