X-Git-Url: http://www.dxcluster.org/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl%2FDXUser.pm;h=65948d59913ebf2e38251e6b2f06b18bad372ffe;hb=337f38bfac57a5e5df34c63094fb869b0e2f6bee;hp=f5f7e0491f561351c0a146c5c98cdbcf3b1993b6;hpb=6b6a8002929017b6d4217f68fa492a2d728ee1fe;p=spider.git diff --git a/perl/DXUser.pm b/perl/DXUser.pm index f5f7e049..65948d59 100644 --- a/perl/DXUser.pm +++ b/perl/DXUser.pm @@ -13,6 +13,10 @@ require Exporter; use MLDBM qw(DB_File); use Fcntl; +use Carp; + +use strict; +use vars qw(%u $dbm $filename %valid); %u = undef; $dbm = undef; @@ -20,21 +24,33 @@ $filename = undef; # hash of valid elements and a simple prompt %valid = ( - call => 'Callsign', - alias => 'Real Callsign', - name => 'Name', - qth => 'Home QTH', - lat => 'Latitude', - long => 'Longtitude', - qra => 'Locator', - email => 'E-mail Address', - priv => 'Privilege Level', - lastin => 'Last Time in', - passwd => 'Password', - addr => 'Full Address', - 'sort' => 'Type of User', # A - ak1a, U - User, S - spider cluster, B - BBS + 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 ); +no strict; sub AUTOLOAD { my $self = shift; @@ -43,8 +59,12 @@ sub AUTOLOAD return if $name =~ /::DESTROY$/; $name =~ s/.*:://o; - die "Non-existant field '$AUTOLOAD'" if !$valid{$name}; - @_ ? $self->{$name} = shift : $self->{$name} ; + confess "Non-existant field '$AUTOLOAD'" if !$valid{$name}; + if (@_) { + $self->{$name} = shift; + $self->put(); + } + return $self->{$name}; } # @@ -54,11 +74,13 @@ sub init { my ($pkg, $fn) = @_; - 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 ($!)"; + 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; + # # close the system # @@ -75,22 +97,60 @@ 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; + $self->{lang} = $main::lang; bless $self, $pkg; $u{call} = $self; } # -# get - get an existing user +# get - get an existing user - this seems to return a different reference everytime it is +# called - see below # sub get { - my ($pkg, $call) = @_; + 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}; } @@ -136,6 +196,67 @@ 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 # @@ -146,40 +267,6 @@ sub field_prompt 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; -} - # some variable accessors sub sort {