X-Git-Url: http://dxcluster.org/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl%2FDXUser.pm;h=810bb7682d85c7f752249b013b2ef8ff3909fc81;hb=584783d0ee480f9f56c167fc2e2aec280ba5e897;hp=0af77f04df235d0da9e136dc5e7df3eb4f8856fa;hpb=ab568d677a2d2243eabee315b3e609c4ea4f73a0;p=spider.git diff --git a/perl/DXUser.pm b/perl/DXUser.pm index 0af77f04..810bb768 100644 --- a/perl/DXUser.pm +++ b/perl/DXUser.pm @@ -18,52 +18,54 @@ 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', -); + 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; + 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; + # $self->put(); + } + return $self->{$name}; } # @@ -71,11 +73,11 @@ sub AUTOLOAD # sub init { - my ($pkg, $fn) = @_; + my ($pkg, $fn) = @_; - 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; + $dbm = tie (%u, MLDBM, $fn, O_CREAT|O_RDWR, 0666) or confess "can't open user file: $fn ($!)"; + $filename = $fn; } use strict; @@ -86,8 +88,8 @@ use strict; sub finish { - $dbm = undef; - untie %u; + $dbm = undef; + untie %u; } # @@ -96,20 +98,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; + return $self; } # @@ -119,10 +121,10 @@ 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 + return $u{$call}; } # @@ -131,7 +133,7 @@ sub get sub get_all_calls { - return (sort keys %u); + return (sort keys %u); } # @@ -144,13 +146,13 @@ 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; + return $u{$call}; } # @@ -159,9 +161,9 @@ 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; } # @@ -170,9 +172,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}; } # @@ -181,9 +183,9 @@ sub del sub close { - my $self = shift; - $self->{lastin} = time; - $self->put(); + my $self = shift; + $self->{lastin} = time; + $self->put(); } # @@ -192,7 +194,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' ]; } # @@ -201,49 +264,15 @@ 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'} ; } 1; __END__