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