perl/DXUser.pm

   1 #
   2 # DX cluster user routines
   3 #
   4 # Copyright (c) 1998 - Dirk Koopman G1TLH
   5 #
   6 # $Id$
   7 #
   8
   9 package DXUser;
  10
  11 require Exporter;
  12 @ISA = qw(Exporter);
  13
  14 use MLDBM qw(DB_File);
  15 use Fcntl;
  16 use Carp;
  17
  18 use strict;
  19 use vars qw(%u $dbm $filename %valid);
  20
  21 %u = ();
  22 $dbm = undef;
  23 $filename = undef;
  24
  25 # hash of valid elements and a simple prompt
  26 %valid = (
  27                   call => '0,Callsign',
  28                   alias => '0,Real Callsign',
  29                   name => '0,Name',
  30                   qth => '0,Home QTH',
  31                   lat => '0,Latitude,slat',
  32                   long => '0,Longitude,slong',
  33                   qra => '0,Locator',
  34                   email => '0,E-mail Address',
  35                   priv => '9,Privilege Level',
  36                   lastin => '0,Last Time in,cldatetime',
  37                   passwd => '9,Password',
  38                   addr => '0,Full Address',
  39                   'sort' => '0,Type of User', # A - ak1a, U - User, S - spider cluster, B - BBS
  40                   xpert => '0,Expert Status,yesno',
  41                   bbs => '0,Home BBS',
  42                   node => '0,Last Node',
  43                   homenode => '0,Home Node',
  44                   lockout => '9,Locked out?,yesno',     # won't let them in at all
  45                   dxok => '9,DX Spots?,yesno', # accept his dx spots?
  46                   annok => '9,Announces?,yesno', # accept his announces?
  47                   reg => '0,Registered?,yesno', # is this user registered?
  48                   lang => '0,Language',
  49                   hmsgno => '0,Highest Msgno',
  50                   group => '0,Access Group,parray',     # used to create a group of users/nodes for some purpose or other
  51                   isolate => '9,Isolate network,yesno',
  52                  );
  53
  54 no strict;
  55 sub AUTOLOAD
  56 {
  57         my $self = shift;
  58         my $name = $AUTOLOAD;
  59
  60         return if $name =~ /::DESTROY$/;
  61         $name =~ s/.*:://o;
  62
  63         confess "Non-existant field '$AUTOLOAD'" if !$valid{$name};
  64         if (@_) {
  65                 $self->{$name} = shift;
  66                 #       $self->put();
  67         }
  68         return $self->{$name};
  69 }
  70
  71 #
  72 # initialise the system
  73 #
  74 sub init
  75 {
  76         my ($pkg, $fn) = @_;
  77
  78         confess "need a filename in User" if !$fn;
  79         $dbm = tie (%u, MLDBM, $fn, O_CREAT|O_RDWR, 0666) or confess "can't open user file: $fn ($!)";
  80         $filename = $fn;
  81 }
  82
  83 use strict;
  84
  85 #
  86 # close the system
  87 #
  88
  89 sub finish
  90 {
  91         $dbm = undef;
  92         untie %u;
  93 }
  94
  95 #
  96 # new - create a new user
  97 #
  98
  99 sub new
 100 {
 101         my $pkg = shift;
 102         my $call = uc shift;
 103         #  $call =~ s/-\d+$//o;
 104
 105         confess "can't create existing call $call in User\n!" if $u{$call};
 106
 107         my $self = bless {}, $pkg;
 108         $self->{call} = $call;
 109         $self->{'sort'} = 'U';
 110         $self->{dxok} = 1;
 111         $self->{annok} = 1;
 112         $self->{lang} = $main::lang;
 113         $u{call} = $self;
 114         return $self;
 115 }
 116
 117 #
 118 # get - get an existing user - this seems to return a different reference everytime it is
 119 #       called - see below
 120 #
 121
 122 sub get
 123 {
 124         my $pkg = shift;
 125         my $call = uc shift;
 126         #  $call =~ s/-\d+$//o;       # strip ssid
 127         return $u{$call};
 128 }
 129
 130 #
 131 # get all callsigns in the database
 132 #
 133
 134 sub get_all_calls
 135 {
 136         return (sort keys %u);
 137 }
 138
 139 #
 140 # get an existing either from the channel (if there is one) or from the database
 141 #
 142 # It is important to note that if you have done a get (for the channel say) and you
 143 # want access or modify that you must use this call (and you must NOT use get's all
 144 # over the place willy nilly!)
 145 #
 146
 147 sub get_current
 148 {
 149         my $pkg = shift;
 150         my $call = uc shift;
 151         #  $call =~ s/-\d+$//o;       # strip ssid
 152
 153         my $dxchan = DXChannel->get($call);
 154         return $dxchan->user if $dxchan;
 155         return $u{$call};
 156 }
 157
 158 #
 159 # put - put a user
 160 #
 161
 162 sub put
 163 {
 164         my $self = shift;
 165         my $call = $self->{call};
 166         $u{$call} = $self;
 167 }
 168
 169 #
 170 # del - delete a user
 171 #
 172
 173 sub del
 174 {
 175         my $self = shift;
 176         my $call = $self->{call};
 177         delete $u{$call};
 178 }
 179
 180 #
 181 # close - close down a user
 182 #
 183
 184 sub close
 185 {
 186         my $self = shift;
 187         $self->{lastin} = time;
 188         $self->put();
 189 }
 190
 191 #
 192 # return a list of valid elements
 193 #
 194
 195 sub fields
 196 {
 197         return keys(%valid);
 198 }
 199
 200 #
 201 # group handling
 202 #
 203
 204 # add one or more groups
 205 sub add_group
 206 {
 207         my $self = shift;
 208         my $ref = $self->{group} || [ 'local' ];
 209         $self->{group} = $ref if !$self->{group};
 210         push @$ref, @_ if @_;
 211 }
 212
 213 # remove one or more groups
 214 sub del_group
 215 {
 216         my $self = shift;
 217         my $ref = $self->{group} || [ 'local' ];
 218         my @in = @_;
 219
 220         $self->{group} = $ref if !$self->{group};
 221
 222         @$ref = map { my $a = $_; return (grep { $_ eq $a } @in) ? () : $a } @$ref;
 223 }
 224
 225 # does this thing contain all the groups listed?
 226 sub union
 227 {
 228         my $self = shift;
 229         my $ref = $self->{group};
 230         my $n;
 231
 232         return 0 if !$ref || @_ == 0;
 233         return 1 if @$ref == 0 && @_ == 0;
 234         for ($n = 0; $n < @_; ) {
 235                 for (@$ref) {
 236                         my $a = $_;
 237                         $n++ if grep $_ eq $a, @_;
 238                 }
 239         }
 240         return $n >= @_;
 241 }
 242
 243 # simplified group test just for one group
 244 sub in_group
 245 {
 246         my $self = shift;
 247         my $s = shift;
 248         my $ref = $self->{group};
 249
 250         return 0 if !$ref;
 251         return grep $_ eq $s, $ref;
 252 }
 253
 254 # set up a default group (only happens for them's that connect direct)
 255 sub new_group
 256 {
 257         my $self = shift;
 258         $self->{group} = [ 'local' ];
 259 }
 260
 261 #
 262 # return a prompt for a field
 263 #
 264
 265 sub field_prompt
 266 {
 267         my ($self, $ele) = @_;
 268         return $valid{$ele};
 269 }
 270
 271 # some variable accessors
 272 sub sort
 273 {
 274         my $self = shift;
 275         @_ ? $self->{'sort'} = shift : $self->{'sort'} ;
 276 }
 277 1;
 278 __END__