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   wwv => '0,Want WWV,yesno',
  37   talk => '0,Want Talk,yesno',
  38   ann => '0,Want Announce,yesno',
  39   here => '0,Here Status,yesno',
  40   xpert => '0,Expert Status,yesno',
  41   bbs => '0,Home BBS',
  42   node => '0,Home Node',
  43   dx => '0,DX Spots,yesno',
  44 );
  45
  46 sub AUTOLOAD
  47 {
  48   my $self = shift;
  49   my $name = $AUTOLOAD;
  50
  51   return if $name =~ /::DESTROY$/;
  52   $name =~ s/.*:://o;
  53
  54   die "Non-existant field '$AUTOLOAD'" if !$valid{$name};
  55   if (@_) {
  56     $self->{$name} = shift;
  57         $self->put();
  58   }
  59   return $self->{$name};
  60 }
  61
  62 #
  63 # initialise the system
  64 #
  65 sub init
  66 {
  67   my ($pkg, $fn) = @_;
  68
  69   die "need a filename in User" if !$fn;
  70   $dbm = tie %u, MLDBM, $fn, O_CREAT|O_RDWR, 0666 or die "can't open user file: $fn ($!)";
  71   $filename = $fn;
  72 }
  73
  74 #
  75 # close the system
  76 #
  77
  78 sub finish
  79 {
  80   $dbm = undef;
  81   untie %u;
  82 }
  83
  84 #
  85 # new - create a new user
  86 #
  87
  88 sub new
  89 {
  90   my ($pkg, $call) = @_;
  91   die "can't create existing call $call in User\n!" if $u{$call};
  92
  93   my $self = {};
  94   $self->{call} = $call;
  95   bless $self, $pkg;
  96   $u{call} = $self;
  97 }
  98
  99 #
 100 # get - get an existing user
 101 #
 102
 103 sub get
 104 {
 105   my ($pkg, $call) = @_;
 106   return $u{$call};
 107 }
 108
 109 #
 110 # put - put a user
 111 #
 112
 113 sub put
 114 {
 115   my $self = shift;
 116   my $call = $self->{call};
 117   $u{$call} = $self;
 118 }
 119
 120 #
 121 # del - delete a user
 122 #
 123
 124 sub del
 125 {
 126   my $self = shift;
 127   my $call = $self->{call};
 128   delete $u{$call};
 129 }
 130
 131 #
 132 # close - close down a user
 133 #
 134
 135 sub close
 136 {
 137   my $self = shift;
 138   $self->{lastin} = time;
 139   $self->put();
 140 }
 141
 142 #
 143 # return a list of valid elements
 144 #
 145
 146 sub fields
 147 {
 148   return keys(%valid);
 149 }
 150
 151 #
 152 # return a prompt for a field
 153 #
 154
 155 sub field_prompt
 156 {
 157   my ($self, $ele) = @_;
 158   return $valid{$ele};
 159 }
 160
 161 #
 162 # enter an element from input, returns 1 for success
 163 #
 164
 165 sub enter
 166 {
 167   my ($self, $ele, $value) = @_;
 168   return 0 if (!defined $valid{$ele});
 169   chomp $value;
 170   return 0 if $value eq "";
 171   if ($ele eq 'long') {
 172     my ($longd, $longm, $longl) = $value =~ /(\d+) (\d+) ([EWew])/;
 173         return 0 if (!$longl || $longd < 0 || $longd > 180 || $longm < 0 || $longm > 59);
 174         $longd += ($longm/60);
 175         $longd = 0-$longd if (uc $longl) eq 'W';
 176         $self->{'long'} = $longd;
 177         return 1;
 178   } elsif ($ele eq 'lat') {
 179     my ($latd, $latm, $latl) = $value =~ /(\d+) (\d+) ([NSns])/;
 180         return 0 if (!$latl || $latd < 0 || $latd > 90 || $latm < 0 || $latm > 59);
 181         $latd += ($latm/60);
 182         $latd = 0-$latd if (uc $latl) eq 'S';
 183         $self->{'lat'} = $latd;
 184         return 1;
 185   } elsif ($ele eq 'qra') {
 186     $self->{'qra'} = UC $value;
 187         return 1;
 188   } else {
 189     $self->{$ele} = $value;               # default action
 190         return 1;
 191   }
 192   return 0;
 193 }
 194
 195 # some variable accessors
 196 sub sort
 197 {
 198   my $self = shift;
 199   @_ ? $self->{sort} = shift : $self->{sort} ;
 200 }
 201 1;
 202 __END__