fleshed out some commands (particularly flag setting and unsetting)

[spider.git] / perl / DXUser.pm

diff --git a/perl/DXUser.pm b/perl/DXUser.pm
index 6f7756ffd5c4f7965aeed905588e6edcb4bfe563..b593a6b2ad7f22eb33982e275a1aed51923259fd 100644 (file)
--- a/perl/DXUser.pm
+++ b/perl/DXUser.pm
@@ -1,19 +1,64 @@
 #
 # DX cluster user routines
 #
+# Copyright (c) 1998 - Dirk Koopman G1TLH
+#
+# $Id$
+#
 
 package DXUser;
 
 require Exporter;
 @ISA = qw(Exporter);
 
-use MLDBM;
+use MLDBM qw(DB_File);
 use Fcntl;
 
 %u = undef;
 $dbm = undef;
 $filename = undef;
 
+# hash of valid elements and a simple prompt
+%valid = (
+  call => '0,Callsign',
+  alias => '0,Real Callsign',
+  name => '0,Name',
+  qth => '0,Home QTH',
+  lat => '0,Latitude,slat',
+  long => '0,Longitude,slong',
+  qra => '0,Locator',
+  email => '0,E-mail Address',
+  priv => '9,Privilege Level',
+  lastin => '0,Last Time in,cldatetime',
+  passwd => '9,Password',
+  addr => '0,Full Address',
+  sort => '0,Type of User',  # A - ak1a, U - User, S - spider cluster, B - BBS
+  wwv => '0,Want WWV,yesno',
+  talk => '0,Want Talk,yesno',
+  ann => '0,Want Announce,yesno',
+  here => '0,Here Status,yesno',
+  xpert => '0,Expert Status,yesno',
+  bbs => '0,Home BBS',
+  node => '0,Home Node',
+  dx => '0,DX Spots,yesno',
+);
+
+sub AUTOLOAD
+{
+  my $self = shift;
+  my $name = $AUTOLOAD;
+  
+  return if $name =~ /::DESTROY$/;
+  $name =~ s/.*:://o;
+  
+  die "Non-existant field '$AUTOLOAD'" if !$valid{$name};
+  if (@_) {
+    $self->{$name} = shift;
+       $self->put();
+  }
+  return $self->{$name};
+}
+
 #
 # initialise the system
 #
@@ -21,8 +66,8 @@ sub init
 {
   my ($pkg, $fn) = @_;
   
-  die "need a filename in User\n" if !$fn;
-  $dbm = tie %u, MLDBM, $fn, O_CREAT|O_RDWR, 0666 or die "can't open user file: $fn ($!)\n";
+  die "need a filename in User" if !$fn;
+  $dbm = tie %u, MLDBM, $fn, O_CREAT|O_RDWR, 0666 or die "can't open user file: $fn ($!)";
   $filename = $fn;
 }
 
@@ -42,12 +87,12 @@ sub finish
 
 sub new
 {
-  my ($call) = @_;
+  my ($pkg, $call) = @_;
   die "can't create existing call $call in User\n!" if $u{$call};
 
   my $self = {};
   $self->{call} = $call;
-  bless $self;
+  bless $self, $pkg;
   $u{call} = $self;
 }
 
@@ -57,7 +102,7 @@ sub new
 
 sub get
 {
-  my ($call) = @_;
+  my ($pkg, $call) = @_;
   return $u{$call};
 }
 
@@ -94,5 +139,64 @@ sub close
   $self->put();
 }
 
+#
+# return a list of valid elements 
+# 
+
+sub fields
+{
+  return keys(%valid);
+}
+
+#
+# return a prompt for a field
+#
+
+sub field_prompt
+{ 
+  my ($self, $ele) = @_;
+  return $valid{$ele};
+}
+
+#
+# enter an element from input, returns 1 for success
+#
+
+sub enter
+{
+  my ($self, $ele, $value) = @_;
+  return 0 if (!defined $valid{$ele});
+  chomp $value;
+  return 0 if $value eq "";
+  if ($ele eq 'long') {
+    my ($longd, $longm, $longl) = $value =~ /(\d+) (\d+) ([EWew])/;
+       return 0 if (!$longl || $longd < 0 || $longd > 180 || $longm < 0 || $longm > 59);
+       $longd += ($longm/60);
+       $longd = 0-$longd if (uc $longl) eq 'W'; 
+       $self->{'long'} = $longd;
+       return 1;
+  } elsif ($ele eq 'lat') {
+    my ($latd, $latm, $latl) = $value =~ /(\d+) (\d+) ([NSns])/;
+       return 0 if (!$latl || $latd < 0 || $latd > 90 || $latm < 0 || $latm > 59);
+       $latd += ($latm/60);
+       $latd = 0-$latd if (uc $latl) eq 'S';
+       $self->{'lat'} = $latd;
+       return 1;
+  } elsif ($ele eq 'qra') {
+    $self->{'qra'} = UC $value;
+       return 1;
+  } else {
+    $self->{$ele} = $value;               # default action
+       return 1;
+  }
+  return 0;
+}
+
+# some variable accessors
+sub sort
+{
+  my $self = shift;
+  @_ ? $self->{sort} = shift : $self->{sort} ;
+}
 1;
 __END__