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