From 1728c7c7a64eaf2852c490629f022c7e70bc46e2 Mon Sep 17 00:00:00 2001 From: djk Date: Wed, 3 Mar 1999 02:26:16 +0000 Subject: [PATCH] added new DXUser with homemade data->ref and ref->data routines added import, export and convert users programs --- Changes | 4 + cmd/show/wwv.pl | 3 +- perl/DXUser.pm | 60 ++++++-- perl/DXUser_old.pm | 323 ++++++++++++++++++++++++++++++++++++++++++ perl/cluster.pl | 3 + perl/convert_users.pl | 155 ++++++++++++++++++++ perl/export_user.pl | 12 +- perl/import_users.pl | 35 +++++ 8 files changed, 577 insertions(+), 18 deletions(-) create mode 100644 perl/DXUser_old.pm create mode 100755 perl/convert_users.pl create mode 100755 perl/import_users.pl diff --git a/Changes b/Changes index 8895b547..9c61e121 100644 --- a/Changes +++ b/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 diff --git a/cmd/show/wwv.pl b/cmd/show/wwv.pl index 07a0259a..eb8d517b 100644 --- a/cmd/show/wwv.pl +++ b/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); diff --git a/perl/DXUser.pm b/perl/DXUser.pm index c84598af..9ebc31d9 100644 --- a/perl/DXUser.pm +++ b/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; } # diff --git a/perl/DXUser_old.pm b/perl/DXUser_old.pm new file mode 100644 index 00000000..70b066dc --- /dev/null +++ b/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__ diff --git a/perl/cluster.pl b/perl/cluster.pl index 2ae98efc..2330bcda 100755 --- a/perl/cluster.pl +++ b/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); } diff --git a/perl/convert_users.pl b/perl/convert_users.pl new file mode 100755 index 00000000..bb392131 --- /dev/null +++ b/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; +} + diff --git a/perl/export_user.pl b/perl/export_user.pl index 950b72e5..2b21466b 100755 --- a/perl/export_user.pl +++ b/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 diff --git a/perl/import_users.pl b/perl/import_users.pl new file mode 100755 index 00000000..3111e064 --- /dev/null +++ b/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(); -- 2.43.0