X-Git-Url: http://dxcluster.org/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl%2FDXUser.pm;h=9d534ae9d1835f6b2eaaeb4ab6b0fc33a2378260;hb=8ebfb28af6e8ec81acbd7de0f5e19fab4c32a8b6;hp=65948d59913ebf2e38251e6b2f06b18bad372ffe;hpb=337f38bfac57a5e5df34c63094fb869b0e2f6bee;p=spider.git

diff --git a/perl/DXUser.pm b/perl/DXUser.pm
index 65948d59..9d534ae9 100644
--- a/perl/DXUser.pm
+++ b/perl/DXUser.pm
@@ -11,60 +11,69 @@ package DXUser;
 require Exporter;
 @ISA = qw(Exporter);
 
-use MLDBM qw(DB_File);
+use DXLog;
+use DB_File;
+use Data::Dumper;
 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
-);
+		  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',
+		  pingint => '9,Node Ping interval',
+		 );
 
 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};
 }
 
 #
@@ -72,11 +81,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;
@@ -87,8 +102,8 @@ use strict;
 
 sub finish
 {
-  $dbm = undef;
-  untie %u;
+	undef $dbm;
+	untie %u;
 }
 
 #
@@ -97,20 +112,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;
+	$self->put;
+	return $self;
 }
 
 #
@@ -120,10 +135,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;
 }
 
 #
@@ -132,7 +148,7 @@ sub get
 
 sub get_all_calls
 {
-  return (sort keys %u);
+	return (sort keys %u);
 }
 
 #
@@ -145,13 +161,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;
 }
 
 #
@@ -160,9 +177,37 @@ sub get_current
 
 sub put
 {
-  my $self = shift;
-  my $call = $self->{call};
-  $u{$call} = $self;
+	my $self = shift;
+	confess "Trying to put nothing!" unless $self && ref $self;
+	my $call = $self->{call};
+	$u{$call} = $self->encode();
+}
+
+# 
+# create a string from a user reference
+#
+sub encode
+{
+	my $self = shift;
+	my $dd = new Data::Dumper([$self]);
+	$dd->Indent(0);
+	$dd->Terse(1);
+    $dd->Quotekeys($] < 5.005 ? 1 : 0);
+	return $dd->Dumpxs;
+}
+
+#
+# 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;
 }
 
 #
@@ -171,9 +216,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};
 }
 
 #
@@ -182,9 +227,9 @@ sub del
 
 sub close
 {
-  my $self = shift;
-  $self->{lastin} = time;
-  $self->put();
+	my $self = shift;
+	$self->{lastin} = time;
+	$self->put();
 }
 
 #
@@ -193,7 +238,7 @@ sub close
 
 sub fields
 {
-  return keys(%valid);
+	return keys(%valid);
 }
 
 #
@@ -263,15 +308,56 @@ 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', @_);
+}
+
+sub wanttalk
+{
+	return _want('talk', @_);
+}
+
 1;
 __END__