X-Git-Url: http://dxcluster.org/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl%2FDXUser.pm;h=554a9930cdfc35ee6174c18a9893774fdd827cd7;hb=6b19958cbe351af8d5462f4e0e03b87875eec16a;hp=cdbc0b23c81c542ea3dd79b698ba8bf7b79ec074;hpb=1cf4bd14be226274d5deb05da8480ab91a5dac52;p=spider.git diff --git a/perl/DXUser.pm b/perl/DXUser.pm index cdbc0b23..554a9930 100644 --- a/perl/DXUser.pm +++ b/perl/DXUser.pm @@ -11,51 +11,66 @@ package DXUser; require Exporter; @ISA = qw(Exporter); -use MLDBM qw(DB_File); +use DB_File; use Fcntl; +use Carp; -%u = undef; +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,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? -); + 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; - die "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}; } # @@ -63,21 +78,29 @@ sub AUTOLOAD # sub init { - my ($pkg, $fn) = @_; + my ($pkg, $fn, $mode) = @_; - 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; + 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; + # # close the system # sub finish { - $dbm = undef; - untie %u; + undef $dbm; + untie %u; } # @@ -86,16 +109,20 @@ sub finish sub new { - my ($pkg, $call) = @_; - die "can't create existing call $call in User\n!" if $u{$call}; + 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; - bless $self, $pkg; - $u{call} = $self; + 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; } # @@ -105,8 +132,20 @@ sub new sub get { - my ($pkg, $call) = @_; - 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; +} + +# +# get all callsigns in the database +# + +sub get_all_calls +{ + return (sort keys %u); } # @@ -119,10 +158,14 @@ sub get sub get_current { - my ($pkg, $call) = @_; - my $dxchan = DXChannel->get($call); - return $dxchan->user if $dxchan; - return $u{$call}; + my $pkg = shift; + my $call = uc shift; + # $call =~ s/-\d+$//o; # strip ssid + + my $dxchan = DXChannel->get($call); + return $dxchan->user if $dxchan; + my $s = $u{$call}; + return $s ? decode($s) : undef; } # @@ -131,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; } # @@ -142,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}; } # @@ -153,9 +239,9 @@ sub del sub close { - my $self = shift; - $self->{lastin} = time; - $self->put(); + my $self = shift; + $self->{lastin} = time; + $self->put(); } # @@ -164,7 +250,68 @@ sub close sub fields { - return keys(%valid); + 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' ]; } # @@ -173,49 +320,51 @@ sub fields 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; + 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__