X-Git-Url: http://dxcluster.org/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl%2FDXUser.pm;h=554a9930cdfc35ee6174c18a9893774fdd827cd7;hb=6b19958cbe351af8d5462f4e0e03b87875eec16a;hp=e1b44dfad41f94109d6771820c5700ae36b86bf3;hpb=69c8aeb338cc485103e289fbab7ec4e7e056ed20;p=spider.git

diff --git a/perl/DXUser.pm b/perl/DXUser.pm
index e1b44dfa..554a9930 100644
--- a/perl/DXUser.pm
+++ b/perl/DXUser.pm
@@ -11,61 +11,66 @@ package DXUser;
 require Exporter;
 @ISA = qw(Exporter);
 
-use MLDBM qw(DB_File);
+use DB_File;
 use Fcntl;
 use Carp;
 
 use strict;
 use vars qw(%u $dbm $filename %valid);
 
-%u = undef;
+%u = ();
 $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
-  xpert => '0,Expert Status,yesno',
-  bbs => '0,Home BBS',
-  node => '0,Last Node',
-  homenode => '0,Home Node',
-  lockout => '9,Locked out?,yesno',        # won't let them in at all
-  dxok => '9,DX Spots?,yesno',            # accept his dx spots?
-  annok => '9,Announces?,yesno',            # accept his announces?
-  reg => '0,Registered?,yesno',            # is this user registered?
-  lang => '0,Language',
-  hmsgno => '0,Highest Msgno',
-  group => '0,Access Group,parray',               # used to create a group of users/nodes for some purpose or other
-  isolate => '9,Isolate network,yesno',
-);
+		  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
+		  xpert => '0,Expert Status,yesno',
+		  bbs => '0,Home BBS',
+		  node => '0,Last Node',
+		  homenode => '0,Home Node',
+		  lockout => '9,Locked out?,yesno',	# won't let them in at all
+		  dxok => '9,DX Spots?,yesno', # accept his dx spots?
+		  annok => '9,Announces?,yesno', # accept his announces?
+		  reg => '0,Registered?,yesno',	# is this user registered?
+		  lang => '0,Language',
+		  hmsgno => '0,Highest Msgno',
+		  group => '0,Access Group,parray',	# used to create a group of users/nodes for some purpose or other
+		  isolate => '9,Isolate network,yesno',
+		  wantbeep => '0,Rec Beep,yesno',
+		  wantann => '0,Rec Announce,yesno',
+		  wantwwv => '0,Rec WWV,yesno',
+		  wanttalk => '0,Rec Talk,yesno',
+		  wantwx => '0,Rec WX,yesno',
+		  wantdx => '0,Rec DX Spots,yesno',
+		 );
 
 no strict;
 sub AUTOLOAD
 {
-  my $self = shift;
-  my $name = $AUTOLOAD;
+	my $self = shift;
+	my $name = $AUTOLOAD;
   
-  return if $name =~ /::DESTROY$/;
-  $name =~ s/.*:://o;
+	return if $name =~ /::DESTROY$/;
+	$name =~ s/.*:://o;
   
-  confess "Non-existant field '$AUTOLOAD'" if !$valid{$name};
-  if (@_) {
-    $self->{$name} = shift;
-	$self->put();
-  }
-  return $self->{$name};
+	confess "Non-existant field '$AUTOLOAD'" if !$valid{$name};
+	if (@_) {
+		$self->{$name} = shift;
+	}
+	return $self->{$name};
 }
 
 #
@@ -73,11 +78,17 @@ sub AUTOLOAD
 #
 sub init
 {
-  my ($pkg, $fn) = @_;
+	my ($pkg, $fn, $mode) = @_;
   
-  confess "need a filename in User" if !$fn;
-  $dbm = tie (%u, MLDBM, $fn, O_CREAT|O_RDWR, 0666) or confess "can't open user file: $fn ($!)";
-  $filename = $fn;
+	confess "need a filename in User" if !$fn;
+	$fn .= ".v2";
+	if ($mode) {
+		$dbm = tie (%u, 'DB_File', $fn, O_CREAT|O_RDWR, 0666, $DB_BTREE) or confess "can't open user file: $fn ($!)";
+	} else {
+		$dbm = tie (%u, 'DB_File', $fn, O_RDONLY, 0666, $DB_BTREE) or confess "can't open user file: $fn ($!)";
+	}
+	
+	$filename = $fn;
 }
 
 use strict;
@@ -88,8 +99,8 @@ use strict;
 
 sub finish
 {
-  $dbm = undef;
-  untie %u;
+	undef $dbm;
+	untie %u;
 }
 
 #
@@ -98,20 +109,20 @@ sub finish
 
 sub new
 {
-  my $pkg = shift;
-  my $call = uc shift;
-#  $call =~ s/-\d+$//o;
+	my $pkg = shift;
+	my $call = uc shift;
+	#  $call =~ s/-\d+$//o;
   
-  confess "can't create existing call $call in User\n!" if $u{$call};
-
-  my $self = {};
-  $self->{call} = $call;
-  $self->{sort} = 'U';
-  $self->{dxok} = 1;
-  $self->{annok} = 1;
-  $self->{lang} = $main::lang;
-  bless $self, $pkg;
-  $u{call} = $self;
+	confess "can't create existing call $call in User\n!" if $u{$call};
+
+	my $self = bless {}, $pkg;
+	$self->{call} = $call;
+	$self->{'sort'} = 'U';
+	$self->{dxok} = 1;
+	$self->{annok} = 1;
+	$self->{lang} = $main::lang;
+	$u{call} = $self->encode();
+	return $self;
 }
 
 #
@@ -121,10 +132,11 @@ sub new
 
 sub get
 {
-  my $pkg = shift;
-  my $call = uc shift;
-#  $call =~ s/-\d+$//o;       # strip ssid
-  return $u{$call};
+	my $pkg = shift;
+	my $call = uc shift;
+	#  $call =~ s/-\d+$//o;       # strip ssid
+	my $s = $u{$call};
+	return $s ?  decode($s) : undef;
 }
 
 #
@@ -133,7 +145,7 @@ sub get
 
 sub get_all_calls
 {
-  return (sort keys %u);
+	return (sort keys %u);
 }
 
 #
@@ -146,13 +158,14 @@ sub get_all_calls
 
 sub get_current
 {
-  my $pkg = shift;
-  my $call = uc shift;
-#  $call =~ s/-\d+$//o;       # strip ssid
+	my $pkg = shift;
+	my $call = uc shift;
+	#  $call =~ s/-\d+$//o;       # strip ssid
   
-  my $dxchan = DXChannel->get($call);
-  return $dxchan->user if $dxchan;
-  return $u{$call};
+	my $dxchan = DXChannel->get($call);
+	return $dxchan->user if $dxchan;
+	my $s = $u{$call};
+	return $s ? decode($s) : undef;
 }
 
 #
@@ -161,9 +174,52 @@ sub get_current
 
 sub put
 {
-  my $self = shift;
-  my $call = $self->{call};
-  $u{$call} = $self;
+	my $self = shift;
+	my $call = $self->{call};
+	$u{$call} = $self->encode();
+}
+
+# 
+# create a string from a user reference
+#
+sub encode
+{
+	my $self = shift;
+	my $out;
+	my $f;
+
+	$out = "bless( { ";
+	for $f (sort keys %$self) {
+		my $val = $$self{$f};
+	    if (ref $val) {          # it's an array (we think)
+			$out .= "'$f'=>[ ";
+			foreach (@$val) {
+				my $s = $_;
+				$out .= "'$s',";
+			}
+			$out .= " ],";
+	    } else {
+			$val =~ s/'/\\'/og;
+			$val =~ s/\@/\\@/og;
+			$out .= "'$f'=>q{$val},";
+		}
+	}
+	$out .= " }, 'DXUser')";
+	return $out;
+}
+
+#
+# create a hash from a string
+#
+sub decode
+{
+	my $s = shift;
+	my $ref;
+	$s = '$ref = ' . $s;
+	eval { $s; };
+	Log('DXUser', $@) if $@;
+	$ref = undef if $@;
+	return $ref;
 }
 
 #
@@ -172,9 +228,9 @@ sub put
 
 sub del
 {
-  my $self = shift;
-  my $call = $self->{call};
-  delete $u{$call};
+	my $self = shift;
+	my $call = $self->{call};
+	delete $u{$call};
 }
 
 #
@@ -183,9 +239,9 @@ sub del
 
 sub close
 {
-  my $self = shift;
-  $self->{lastin} = time;
-  $self->put();
+	my $self = shift;
+	$self->{lastin} = time;
+	$self->put();
 }
 
 #
@@ -194,7 +250,7 @@ sub close
 
 sub fields
 {
-  return keys(%valid);
+	return keys(%valid);
 }
 
 #
@@ -264,15 +320,51 @@ sub new_group
 
 sub field_prompt
 { 
-  my ($self, $ele) = @_;
-  return $valid{$ele};
+	my ($self, $ele) = @_;
+	return $valid{$ele};
 }
 
 # some variable accessors
 sub sort
 {
-  my $self = shift;
-  @_ ? $self->{sort} = shift : $self->{sort} ;
+	my $self = shift;
+	@_ ? $self->{'sort'} = shift : $self->{'sort'} ;
+}
+
+# some accessors
+sub _want
+{
+	my $n = shift;
+	my $self = shift;
+	my $s = "want$n";
+	return $self->{$n} = shift if @_;
+	return defined $self->{$n} ? $self->{$n} : 1;
+}
+
+sub wantbeep
+{
+	return _want('beep', @_);
+}
+
+sub wantann
+{
+	return _want('ann', @_);
+}
+
+sub wantwwv
+{
+	return _want('wwv', @_);
 }
+
+sub wantwx
+{
+	return _want('wx', @_);
+}
+
+sub wantdx
+{
+	return _want('dx', @_);
+}
+
 1;
 __END__