X-Git-Url: http://gb7djk.dxcluster.net/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl%2FDXUser.pm;h=08c5824a7f4f1b8508ff263c0452eaf25d92a5ce;hb=0824a94355e5fb2b4c379bb013d66466725629f5;hp=7ce853c665513dc53a02315e42c59884de589c74;hpb=f77b59f4fcceb428142461972e94345419cbda28;p=spider.git diff --git a/perl/DXUser.pm b/perl/DXUser.pm index 7ce853c6..08c5824a 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,45 @@ $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', - sort => 'Type of User', - lastin => 'Last Time in', - passwd => 'Password', - addr => 'Full Address' + 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? ); +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 # @@ -43,10 +71,12 @@ 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 ($!)"; + $dbm = tie (%u, MLDBM, $fn, O_CREAT|O_RDWR, 0666) or die "can't open user file: $fn ($!)"; $filename = $fn; } +use strict; + # # close the system # @@ -68,17 +98,51 @@ sub new my $self = {}; $self->{call} = $call; + $self->{sort} = 'U'; + $self->{dxok} = 1; + $self->{annok} = 1; 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 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}; } @@ -119,19 +183,19 @@ sub close # return a list of valid elements # -sub elements +sub fields { return keys(%valid); } # -# return a prompt together with the existing value +# return a prompt for a field # -sub prompt +sub field_prompt { my ($self, $ele) = @_; - return "$valid{$ele} [$self->{$ele}]"; + return $valid{$ele}; } # @@ -167,5 +231,12 @@ sub enter } return 0; } + +# some variable accessors +sub sort +{ + my $self = shift; + @_ ? $self->{sort} = shift : $self->{sort} ; +} 1; __END__