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