X-Git-Url: http://gb7djk.dxcluster.net/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl%2FDXUser.pm;h=e1b44dfad41f94109d6771820c5700ae36b86bf3;hb=69c8aeb338cc485103e289fbab7ec4e7e056ed20;hp=6f7756ffd5c4f7965aeed905588e6edcb4bfe563;hpb=2e16209416d1d189707935868a708b525c93097b;p=spider.git

diff --git a/perl/DXUser.pm b/perl/DXUser.pm
index 6f7756ff..e1b44dfa 100644
--- a/perl/DXUser.pm
+++ b/perl/DXUser.pm
@@ -1,19 +1,73 @@
 #
 # DX cluster user routines
 #
+# Copyright (c) 1998 - Dirk Koopman G1TLH
+#
+# $Id$
+#
 
 package DXUser;
 
 require Exporter;
 @ISA = qw(Exporter);
 
-use MLDBM;
+use MLDBM qw(DB_File);
 use Fcntl;
+use Carp;
+
+use strict;
+use vars qw(%u $dbm $filename %valid);
 
 %u = undef;
 $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
 #
@@ -21,11 +75,13 @@ sub init
 {
   my ($pkg, $fn) = @_;
   
-  die "need a filename in User\n" if !$fn;
-  $dbm = tie %u, MLDBM, $fn, O_CREAT|O_RDWR, 0666 or die "can't open user file: $fn ($!)\n";
+  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
 #
@@ -42,22 +98,60 @@ sub finish
 
 sub new
 {
-  my ($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;
-  bless $self;
+  $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 ($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};
 }
 
@@ -94,5 +188,91 @@ sub close
   $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__