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   hmsgno => '0,Highest Msgno',
  49 );
  50
  51 no strict;
  52 sub AUTOLOAD
  53 {
  54   my $self = shift;
  55   my $name = $AUTOLOAD;
  56
  57   return if $name =~ /::DESTROY$/;
  58   $name =~ s/.*:://o;
  59
  60   confess "Non-existant field '$AUTOLOAD'" if !$valid{$name};
  61   if (@_) {
  62     $self->{$name} = shift;
  63         $self->put();
  64   }
  65   return $self->{$name};
  66 }
  67
  68 #
  69 # initialise the system
  70 #
  71 sub init
  72 {
  73   my ($pkg, $fn) = @_;
  74
  75   confess "need a filename in User" if !$fn;
  76   $dbm = tie (%u, MLDBM, $fn, O_CREAT|O_RDWR, 0666) or confess "can't open user file: $fn ($!)";
  77   $filename = $fn;
  78 }
  79
  80 use strict;
  81
  82 #
  83 # close the system
  84 #
  85
  86 sub finish
  87 {
  88   $dbm = undef;
  89   untie %u;
  90 }
  91
  92 #
  93 # new - create a new user
  94 #
  95
  96 sub new
  97 {
  98   my $pkg = shift;
  99   my $call = uc shift;
 100   $call =~ s/-\d+//o;
 101
 102   confess "can't create existing call $call in User\n!" if $u{$call};
 103
 104   my $self = {};
 105   $self->{call} = $call;
 106   $self->{sort} = 'U';
 107   $self->{dxok} = 1;
 108   $self->{annok} = 1;
 109   bless $self, $pkg;
 110   $u{call} = $self;
 111 }
 112
 113 #
 114 # get - get an existing user - this seems to return a different reference everytime it is
 115 #       called - see below
 116 #
 117
 118 sub get
 119 {
 120   my $pkg = shift;
 121   my $call = uc shift;
 122   $call =~ s/-\d+$//o;       # strip ssid
 123   return $u{$call};
 124 }
 125
 126 #
 127 # get all callsigns in the database
 128 #
 129
 130 sub get_all_calls
 131 {
 132   return (sort keys %u);
 133 }
 134
 135 #
 136 # get an existing either from the channel (if there is one) or from the database
 137 #
 138 # It is important to note that if you have done a get (for the channel say) and you
 139 # want access or modify that you must use this call (and you must NOT use get's all
 140 # over the place willy nilly!)
 141 #
 142
 143 sub get_current
 144 {
 145   my $pkg = shift;
 146   my $call = uc shift;
 147   $call =~ s/-\d+$//o;       # strip ssid
 148
 149   my $dxchan = DXChannel->get($call);
 150   return $dxchan->user if $dxchan;
 151   return $u{$call};
 152 }
 153
 154 #
 155 # put - put a user
 156 #
 157
 158 sub put
 159 {
 160   my $self = shift;
 161   my $call = $self->{call};
 162   $u{$call} = $self;
 163 }
 164
 165 #
 166 # del - delete a user
 167 #
 168
 169 sub del
 170 {
 171   my $self = shift;
 172   my $call = $self->{call};
 173   delete $u{$call};
 174 }
 175
 176 #
 177 # close - close down a user
 178 #
 179
 180 sub close
 181 {
 182   my $self = shift;
 183   $self->{lastin} = time;
 184   $self->put();
 185 }
 186
 187 #
 188 # return a list of valid elements
 189 #
 190
 191 sub fields
 192 {
 193   return keys(%valid);
 194 }
 195
 196 #
 197 # return a prompt for a field
 198 #
 199
 200 sub field_prompt
 201 {
 202   my ($self, $ele) = @_;
 203   return $valid{$ele};
 204 }
 205
 206 #
 207 # enter an element from input, returns 1 for success
 208 #
 209
 210 sub enter
 211 {
 212   my ($self, $ele, $value) = @_;
 213   return 0 if (!defined $valid{$ele});
 214   chomp $value;
 215   return 0 if $value eq "";
 216   if ($ele eq 'long') {
 217     my ($longd, $longm, $longl) = $value =~ /(\d+) (\d+) ([EWew])/;
 218         return 0 if (!$longl || $longd < 0 || $longd > 180 || $longm < 0 || $longm > 59);
 219         $longd += ($longm/60);
 220         $longd = 0-$longd if (uc $longl) eq 'W';
 221         $self->{'long'} = $longd;
 222         return 1;
 223   } elsif ($ele eq 'lat') {
 224     my ($latd, $latm, $latl) = $value =~ /(\d+) (\d+) ([NSns])/;
 225         return 0 if (!$latl || $latd < 0 || $latd > 90 || $latm < 0 || $latm > 59);
 226         $latd += ($latm/60);
 227         $latd = 0-$latd if (uc $latl) eq 'S';
 228         $self->{'lat'} = $latd;
 229         return 1;
 230   } elsif ($ele eq 'qra') {
 231     $self->{'qra'} = UC $value;
 232         return 1;
 233   } else {
 234     $self->{$ele} = $value;               # default action
 235         return 1;
 236   }
 237   return 0;
 238 }
 239
 240 # some variable accessors
 241 sub sort
 242 {
 243   my $self = shift;
 244   @_ ? $self->{sort} = shift : $self->{sort} ;
 245 }
 246 1;
 247 __END__