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