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   $self->{lang} = $main::lang;
 110   bless $self, $pkg;
 111   $u{call} = $self;
 112 }
 113
 114 #
 115 # get - get an existing user - this seems to return a different reference everytime it is
 116 #       called - see below
 117 #
 118
 119 sub get
 120 {
 121   my $pkg = shift;
 122   my $call = uc shift;
 123   $call =~ s/-\d+$//o;       # strip ssid
 124   return $u{$call};
 125 }
 126
 127 #
 128 # get all callsigns in the database
 129 #
 130
 131 sub get_all_calls
 132 {
 133   return (sort keys %u);
 134 }
 135
 136 #
 137 # get an existing either from the channel (if there is one) or from the database
 138 #
 139 # It is important to note that if you have done a get (for the channel say) and you
 140 # want access or modify that you must use this call (and you must NOT use get's all
 141 # over the place willy nilly!)
 142 #
 143
 144 sub get_current
 145 {
 146   my $pkg = shift;
 147   my $call = uc shift;
 148   $call =~ s/-\d+$//o;       # strip ssid
 149
 150   my $dxchan = DXChannel->get($call);
 151   return $dxchan->user if $dxchan;
 152   return $u{$call};
 153 }
 154
 155 #
 156 # put - put a user
 157 #
 158
 159 sub put
 160 {
 161   my $self = shift;
 162   my $call = $self->{call};
 163   $u{$call} = $self;
 164 }
 165
 166 #
 167 # del - delete a user
 168 #
 169
 170 sub del
 171 {
 172   my $self = shift;
 173   my $call = $self->{call};
 174   delete $u{$call};
 175 }
 176
 177 #
 178 # close - close down a user
 179 #
 180
 181 sub close
 182 {
 183   my $self = shift;
 184   $self->{lastin} = time;
 185   $self->put();
 186 }
 187
 188 #
 189 # return a list of valid elements
 190 #
 191
 192 sub fields
 193 {
 194   return keys(%valid);
 195 }
 196
 197 #
 198 # return a prompt for a field
 199 #
 200
 201 sub field_prompt
 202 {
 203   my ($self, $ele) = @_;
 204   return $valid{$ele};
 205 }
 206
 207 #
 208 # enter an element from input, returns 1 for success
 209 #
 210
 211 sub enter
 212 {
 213   my ($self, $ele, $value) = @_;
 214   return 0 if (!defined $valid{$ele});
 215   chomp $value;
 216   return 0 if $value eq "";
 217   if ($ele eq 'long') {
 218     my ($longd, $longm, $longl) = $value =~ /(\d+) (\d+) ([EWew])/;
 219         return 0 if (!$longl || $longd < 0 || $longd > 180 || $longm < 0 || $longm > 59);
 220         $longd += ($longm/60);
 221         $longd = 0-$longd if (uc $longl) eq 'W';
 222         $self->{'long'} = $longd;
 223         return 1;
 224   } elsif ($ele eq 'lat') {
 225     my ($latd, $latm, $latl) = $value =~ /(\d+) (\d+) ([NSns])/;
 226         return 0 if (!$latl || $latd < 0 || $latd > 90 || $latm < 0 || $latm > 59);
 227         $latd += ($latm/60);
 228         $latd = 0-$latd if (uc $latl) eq 'S';
 229         $self->{'lat'} = $latd;
 230         return 1;
 231   } elsif ($ele eq 'qra') {
 232     $self->{'qra'} = UC $value;
 233         return 1;
 234   } else {
 235     $self->{$ele} = $value;               # default action
 236         return 1;
 237   }
 238   return 0;
 239 }
 240
 241 # some variable accessors
 242 sub sort
 243 {
 244   my $self = shift;
 245   @_ ? $self->{sort} = shift : $self->{sort} ;
 246 }
 247 1;
 248 __END__