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 => 'Callsign',
  24   alias => 'Real Callsign',
  25   name => 'Name',
  26   qth => 'Home QTH',
  27   lat => 'Latitude',
  28   long => 'Longtitude',
  29   qra => 'Locator',
  30   email => 'E-mail Address',
  31   priv => 'Privilege Level',
  32   lastin => 'Last Time in',
  33   passwd => 'Password',
  34   addr => 'Full Address',
  35   'sort' => 'Type of User',  # A - ak1a, U - User, S - spider cluster, B - BBS
  36 );
  37
  38 sub AUTOLOAD
  39 {
  40   my $self = shift;
  41   my $name = $AUTOLOAD;
  42
  43   return if $name =~ /::DESTROY$/;
  44   $name =~ s/.*:://o;
  45
  46   die "Non-existant field '$AUTOLOAD'" if !$valid{$name};
  47   @_ ? $self->{$name} = shift : $self->{$name} ;
  48 }
  49
  50 #
  51 # initialise the system
  52 #
  53 sub init
  54 {
  55   my ($pkg, $fn) = @_;
  56
  57   die "need a filename in User" if !$fn;
  58   $dbm = tie %u, MLDBM, $fn, O_CREAT|O_RDWR, 0666 or die "can't open user file: $fn ($!)";
  59   $filename = $fn;
  60 }
  61
  62 #
  63 # close the system
  64 #
  65
  66 sub finish
  67 {
  68   $dbm = undef;
  69   untie %u;
  70 }
  71
  72 #
  73 # new - create a new user
  74 #
  75
  76 sub new
  77 {
  78   my ($pkg, $call) = @_;
  79   die "can't create existing call $call in User\n!" if $u{$call};
  80
  81   my $self = {};
  82   $self->{call} = $call;
  83   bless $self, $pkg;
  84   $u{call} = $self;
  85 }
  86
  87 #
  88 # get - get an existing user
  89 #
  90
  91 sub get
  92 {
  93   my ($pkg, $call) = @_;
  94   return $u{$call};
  95 }
  96
  97 #
  98 # put - put a user
  99 #
 100
 101 sub put
 102 {
 103   my $self = shift;
 104   my $call = $self->{call};
 105   $u{$call} = $self;
 106 }
 107
 108 #
 109 # del - delete a user
 110 #
 111
 112 sub del
 113 {
 114   my $self = shift;
 115   my $call = $self->{call};
 116   delete $u{$call};
 117 }
 118
 119 #
 120 # close - close down a user
 121 #
 122
 123 sub close
 124 {
 125   my $self = shift;
 126   $self->{lastin} = time;
 127   $self->put();
 128 }
 129
 130 #
 131 # return a list of valid elements
 132 #
 133
 134 sub elements
 135 {
 136   return keys(%valid);
 137 }
 138
 139 #
 140 # return a prompt for a field
 141 #
 142
 143 sub prompt
 144 {
 145   my ($self, $ele) = @_;
 146   return $valid{$ele};
 147 }
 148
 149 #
 150 # enter an element from input, returns 1 for success
 151 #
 152
 153 sub enter
 154 {
 155   my ($self, $ele, $value) = @_;
 156   return 0 if (!defined $valid{$ele});
 157   chomp $value;
 158   return 0 if $value eq "";
 159   if ($ele eq 'long') {
 160     my ($longd, $longm, $longl) = $value =~ /(\d+) (\d+) ([EWew])/;
 161         return 0 if (!$longl || $longd < 0 || $longd > 180 || $longm < 0 || $longm > 59);
 162         $longd += ($longm/60);
 163         $longd = 0-$longd if (uc $longl) eq 'W';
 164         $self->{'long'} = $longd;
 165         return 1;
 166   } elsif ($ele eq 'lat') {
 167     my ($latd, $latm, $latl) = $value =~ /(\d+) (\d+) ([NSns])/;
 168         return 0 if (!$latl || $latd < 0 || $latd > 90 || $latm < 0 || $latm > 59);
 169         $latd += ($latm/60);
 170         $latd = 0-$latd if (uc $latl) eq 'S';
 171         $self->{'lat'} = $latd;
 172         return 1;
 173   } elsif ($ele eq 'qra') {
 174     $self->{'qra'} = UC $value;
 175         return 1;
 176   } else {
 177     $self->{$ele} = $value;               # default action
 178         return 1;
 179   }
 180   return 0;
 181 }
 182
 183 # some variable accessors
 184 sub sort
 185 {
 186   my $self = shift;
 187   @_ ? $self->{sort} = shift : $self->{sort} ;
 188 }
 189 1;
 190 __END__