added new DXUser with homemade data->ref and ref->data routines

added import, export and convert users programs

Changes

@@ -1,3 +1,7 @@
+02Mar99========================================================================
+1. Changed DXUser so that it uses a homemade import/export hash routine 
+2. DXUser now uses a DB_BTREE file
+3. Added export_users.pl, import_users.pl and convert_users.pl
 25Feb99========================================================================
 1. added NL language stuff.
 2. added set/language

cmd/show/wwv.pl

@@ -26,7 +26,8 @@ while ($f = shift @f) {                 # next field
 	}
 }
 
-$to = 10 if !$to;
+$from = 1 unless $from;
+$to = 10 unless $to;
 
 push @out, "Date        Hour   SFI   A   K Forecast                               Logger";
 my @in = Geomag::search($from, $to, $main::systime);

perl/DXUser.pm

@@ -11,7 +11,7 @@ package DXUser;
 require Exporter;
 @ISA = qw(Exporter);
 
-use MLDBM qw(DB_File);
+use DB_File;
 use Fcntl;
 use Carp;
 
@@ -76,10 +76,11 @@ sub init
 	my ($pkg, $fn, $mode) = @_;
   
 	confess "need a filename in User" if !$fn;
+	$fn .= ".new";
 	if ($mode) {
-		$dbm = tie (%u, MLDBM, $fn, O_CREAT|O_RDWR, 0666) or confess "can't open user file: $fn ($!)";
+		$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, MLDBM, $fn, O_RDONLY) or confess "can't open user file: $fn ($!)";
+		$dbm = tie (%u, 'DB_File', $fn, O_RDONLY, 0666, $DB_BTREE) or confess "can't open user file: $fn ($!)";
 	}
 	
 	$filename = $fn;
@@ -93,7 +94,6 @@ use strict;
 
 sub finish
 {
-	$dbm = undef;
 	untie %u;
 }
 
@@ -115,7 +115,7 @@ sub new
 	$self->{dxok} = 1;
 	$self->{annok} = 1;
 	$self->{lang} = $main::lang;
-	$u{call} = $self;
+	$u{call} = $self->encode();
 	return $self;
 }
 
@@ -129,7 +129,8 @@ sub get
 	my $pkg = shift;
 	my $call = uc shift;
 	#  $call =~ s/-\d+$//o;       # strip ssid
-	return $u{$call};
+	my $s = $u{$call};
+	return $s ?  decode($s) : undef;
 }
 
 #
@@ -157,7 +158,8 @@ sub get_current
   
 	my $dxchan = DXChannel->get($call);
 	return $dxchan->user if $dxchan;
-	return $u{$call};
+	my $s = $u{$call};
+	return $s ? decode($s) : undef;
 }
 
 #
@@ -168,7 +170,49 @@ sub put
 {
 	my $self = shift;
 	my $call = $self->{call};
-	$u{$call} = $self;
+	$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;
+	confess $@ if $@;
+	return $ref;
 }
 
 #

perl/DXUser_old.pm

@@ -0,0 +1,323 @@
+#
+# DX cluster user routines
+#
+# Copyright (c) 1998 - Dirk Koopman G1TLH
+#
+# $Id$
+#
+
+package DXUser;
+
+require Exporter;
+@ISA = qw(Exporter);
+
+use MLDBM qw(DB_File);
+use Fcntl;
+use Carp;
+
+use strict;
+use vars qw(%u $dbm $filename %valid);
+
+%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',
+		 );
+
+no strict;
+sub AUTOLOAD
+{
+	my $self = shift;
+	my $name = $AUTOLOAD;
+  
+	return if $name =~ /::DESTROY$/;
+	$name =~ s/.*:://o;
+  
+	confess "Non-existant field '$AUTOLOAD'" if !$valid{$name};
+	if (@_) {
+		$self->{$name} = shift;
+		#	$self->put();
+	}
+	return $self->{$name};
+}
+
+#
+# initialise the system
+#
+sub init
+{
+	my ($pkg, $fn, $mode) = @_;
+  
+	confess "need a filename in User" if !$fn;
+	if ($mode) {
+		$dbm = tie (%u, MLDBM, $fn, O_CREAT|O_RDWR, 0666) or confess "can't open user file: $fn ($!)";
+	} else {
+		$dbm = tie (%u, MLDBM, $fn, O_RDONLY) or confess "can't open user file: $fn ($!)";
+	}
+	
+	$filename = $fn;
+}
+
+use strict;
+
+#
+# close the system
+#
+
+sub finish
+{
+	untie %u;
+}
+
+#
+# new - create a new user
+#
+
+sub new
+{
+	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 = bless {}, $pkg;
+	$self->{call} = $call;
+	$self->{'sort'} = 'U';
+	$self->{dxok} = 1;
+	$self->{annok} = 1;
+	$self->{lang} = $main::lang;
+	$u{call} = $self;
+	return $self;
+}
+
+#
+# get - get an existing user - this seems to return a different reference everytime it is
+#       called - see below
+#
+
+sub get
+{
+	my $pkg = shift;
+	my $call = uc shift;
+	#  $call =~ s/-\d+$//o;       # strip ssid
+	return $u{$call};
+}
+
+#
+# get all callsigns in the database 
+#
+
+sub get_all_calls
+{
+	return (sort keys %u);
+}
+
+#
+# get an existing either from the channel (if there is one) or from the database
+#
+# It is important to note that if you have done a get (for the channel say) and you
+# want access or modify that you must use this call (and you must NOT use get's all
+# over the place willy nilly!)
+#
+
+sub get_current
+{
+	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};
+}
+
+#
+# put - put a user
+#
+
+sub put
+{
+	my $self = shift;
+	my $call = $self->{call};
+	$u{$call} = $self;
+}
+
+# 
+# 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;
+			$out .= "'$f'=>'$val',";
+		}
+	}
+	$out .= " }, 'DXUser')";
+	return $out;
+}
+
+#
+# create a hash from a string
+#
+sub decode
+{
+	my $s = shift;
+	my $ref;
+	$s = '$ref = ' . $s;
+	eval $s;
+	confess $@ if $@;
+	return $ref;
+}
+
+#
+# del - delete a user
+#
+
+sub del
+{
+	my $self = shift;
+	my $call = $self->{call};
+	delete $u{$call};
+}
+
+#
+# close - close down a user
+#
+
+sub close
+{
+	my $self = shift;
+	$self->{lastin} = time;
+	$self->put();
+}
+
+#
+# return a list of valid elements 
+# 
+
+sub fields
+{
+	return keys(%valid);
+}
+
+#
+# group handling
+#
+
+# add one or more groups
+sub add_group
+{
+	my $self = shift;
+	my $ref = $self->{group} || [ 'local' ];
+	$self->{group} = $ref if !$self->{group};
+	push @$ref, @_ if @_;
+}
+
+# remove one or more groups
+sub del_group
+{
+	my $self = shift;
+	my $ref = $self->{group} || [ 'local' ];
+	my @in = @_;
+	
+	$self->{group} = $ref if !$self->{group};
+	
+	@$ref = map { my $a = $_; return (grep { $_ eq $a } @in) ? () : $a } @$ref;
+}
+
+# does this thing contain all the groups listed?
+sub union
+{
+	my $self = shift;
+	my $ref = $self->{group};
+	my $n;
+	
+	return 0 if !$ref || @_ == 0;
+	return 1 if @$ref == 0 && @_ == 0;
+	for ($n = 0; $n < @_; ) {
+		for (@$ref) {
+			my $a = $_;
+			$n++ if grep $_ eq $a, @_; 
+		}
+	}
+	return $n >= @_;
+}
+
+# simplified group test just for one group
+sub in_group
+{
+	my $self = shift;
+	my $s = shift;
+	my $ref = $self->{group};
+	
+	return 0 if !$ref;
+	return grep $_ eq $s, $ref;
+}
+
+# set up a default group (only happens for them's that connect direct)
+sub new_group
+{
+	my $self = shift;
+	$self->{group} = [ 'local' ];
+}
+
+#
+# return a prompt for a field
+#
+
+sub field_prompt
+{ 
+	my ($self, $ele) = @_;
+	return $valid{$ele};
+}
+
+# some variable accessors
+sub sort
+{
+	my $self = shift;
+	@_ ? $self->{'sort'} = shift : $self->{'sort'} ;
+}
+1;
+__END__

perl/cluster.pl

@@ -14,6 +14,8 @@ require 5.004;
 
 # make sure that modules are searched in the order local then perl
 BEGIN {
+	umask 002;
+	
 	# root of directory tree for this system
 	$root = "/spider"; 
 	$root = $ENV{'DXSPIDER_ROOT'} if $ENV{'DXSPIDER_ROOT'};
@@ -171,6 +173,7 @@ sub cease
 	Msg->event_loop(1, 0.05);
 	Msg->event_loop(1, 0.05);
 	Log('cluster', "DXSpider V$version stopped");
+	DXUser::finish();
 	unlink $lockfn;
 	exit(0);
 }

perl/convert_users.pl

@@ -0,0 +1,155 @@
+#!/usr/bin/perl
+#
+# Export the user file in a form that can be directly imported
+# back with a do statement
+#
+
+require 5.004;
+
+# search local then perl directories
+BEGIN {
+	umask 002;
+	
+	# root of directory tree for this system
+	$root = "/spider"; 
+	$root = $ENV{'DXSPIDER_ROOT'} if $ENV{'DXSPIDER_ROOT'};
+	
+	unshift @INC, "$root/perl";	# this IS the right way round!
+	unshift @INC, "$root/local";
+}
+
+use DXVars;
+use DB_File;
+use Fcntl;
+use Carp;
+
+$userfn = $ARGV[0] if @ARGV;
+unless ($userfn) {
+	croak "need a filename";
+}
+
+DXUser->init($userfn);
+unlink "$userfn.asc";
+open OUT, ">$userfn.asc" or die;
+
+%newu = ();
+$t = scalar localtime;
+print OUT "#!/usr/bin/perl
+#
+# The exported userfile for a DXSpider System
+# 
+# Input file: $userfn
+#       Time: $t
+#
+
+package DXUser;
+
+%u = (
+";
+
+@all = DXUser::get_all_calls();
+
+for $a (@all) {
+	my $ref = DXUser->get($a);
+	my $s = $ref->encode();
+	print OUT "'$a' => q{$s},\n" if $a;
+	$count++;
+}
+
+DXUser->finish();
+
+print OUT ");
+#
+# there were $count records
+#\n";
+
+	close(OUT);
+
+exit(0);
+
+
+package DXUser;
+
+
+use MLDBM qw(DB_File);
+use Fcntl;
+use Carp;
+
+#
+# initialise the system
+#
+sub init
+{
+	my ($pkg, $fn, $mode) = @_;
+  
+	confess "need a filename in User" if !$fn;
+	if ($mode) {
+		$dbm = tie (%u, MLDBM, $fn, O_CREAT|O_RDWR, 0666) or confess "can't open user file: $fn ($!)";
+	} else {
+		$dbm = tie (%u, MLDBM, $fn, O_RDONLY) or confess "can't open user file: $fn ($!)";
+	}
+	
+	$filename = $fn;
+}
+
+#
+# close the system
+#
+
+sub finish
+{
+	untie %u;
+}
+
+#
+# get - get an existing user - this seems to return a different reference everytime it is
+#       called - see below
+#
+
+sub get
+{
+	my $pkg = shift;
+	my $call = uc shift;
+	#  $call =~ s/-\d+$//o;       # strip ssid
+	return $u{$call};
+}
+
+#
+# get all callsigns in the database 
+#
+
+sub get_all_calls
+{
+	return (sort keys %u);
+}
+
+
+# 
+# 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'=>'$val',";
+		}
+	}
+	$out .= " }, 'DXUser')";
+	return $out;
+}
+

perl/export_user.pl

@@ -24,7 +24,7 @@ $userfn = $ARGV[0] if @ARGV;
 DXUser->init($userfn);
 
 @all = DXUser::get_all_calls();
-$t = scalar time;
+$t = scalar localtime;
 print "#!/usr/bin/perl
 #
 # The exported userfile for a DXSpider System
@@ -40,15 +40,9 @@ package DXUser;
 
 for $a (@all) {
 	my $ref = DXUser->get($a);
-	print "'$a' => bless ( { ";
+	my $s = $ref->encode();
 	
-	my $f;
-	for $f (sort keys %{$ref}) {
-		my $val = ${$ref}{$f};
-	    $val =~ s/'/\\'/og;
-		print "'$f' => '$val', ";
-	}
-	print " }, 'DXUser'),\n";
+	print "'$a' => qq{ $s },\n";
 	$count++;
 }
 print ");\n

perl/import_users.pl

@@ -0,0 +1,35 @@
+#!/usr/bin/perl
+#
+# Export the user file in a form that can be directly imported
+# back with a do statement
+#
+
+require 5.004;
+
+# search local then perl directories
+BEGIN {
+	umask 002;
+	
+	# root of directory tree for this system
+	$root = "/spider"; 
+	$root = $ENV{'DXSPIDER_ROOT'} if $ENV{'DXSPIDER_ROOT'};
+	
+	unshift @INC, "$root/perl";	# this IS the right way round!
+	unshift @INC, "$root/local";
+}
+
+use DXVars;
+use DXUser;
+use Carp;
+
+$userfn = $ARGV[0] if @ARGV;
+unless ($userfn) {
+	croak "need a filename";
+}
+
+DXUser->init($userfn, 1);
+
+do "$userfn.asc";
+print $@ if $@;
+
+DXUser->finish();