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