perl/DXUser_old.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, $mode) = @_;
  77
  78         confess "need a filename in User" if !$fn;
  79         if ($mode) {
  80                 $dbm = tie (%u, MLDBM, $fn, O_CREAT|O_RDWR, 0666) or confess "can't open user file: $fn ($!)";
  81         } else {
  82                 $dbm = tie (%u, MLDBM, $fn, O_RDONLY) or confess "can't open user file: $fn ($!)";
  83         }
  84
  85         $filename = $fn;
  86 }
  87
  88 use strict;
  89
  90 #
  91 # close the system
  92 #
  93
  94 sub finish
  95 {
  96         untie %u;
  97 }
  98
  99 #
 100 # new - create a new user
 101 #
 102
 103 sub new
 104 {
 105         my $pkg = shift;
 106         my $call = uc shift;
 107         #  $call =~ s/-\d+$//o;
 108
 109         confess "can't create existing call $call in User\n!" if $u{$call};
 110
 111         my $self = bless {}, $pkg;
 112         $self->{call} = $call;
 113         $self->{'sort'} = 'U';
 114         $self->{dxok} = 1;
 115         $self->{annok} = 1;
 116         $self->{lang} = $main::lang;
 117         $u{call} = $self;
 118         return $self;
 119 }
 120
 121 #
 122 # get - get an existing user - this seems to return a different reference everytime it is
 123 #       called - see below
 124 #
 125
 126 sub get
 127 {
 128         my $pkg = shift;
 129         my $call = uc shift;
 130         #  $call =~ s/-\d+$//o;       # strip ssid
 131         return $u{$call};
 132 }
 133
 134 #
 135 # get all callsigns in the database
 136 #
 137
 138 sub get_all_calls
 139 {
 140         return (sort keys %u);
 141 }
 142
 143 #
 144 # get an existing either from the channel (if there is one) or from the database
 145 #
 146 # It is important to note that if you have done a get (for the channel say) and you
 147 # want access or modify that you must use this call (and you must NOT use get's all
 148 # over the place willy nilly!)
 149 #
 150
 151 sub get_current
 152 {
 153         my $pkg = shift;
 154         my $call = uc shift;
 155         #  $call =~ s/-\d+$//o;       # strip ssid
 156
 157         my $dxchan = DXChannel->get($call);
 158         return $dxchan->user if $dxchan;
 159         return $u{$call};
 160 }
 161
 162 #
 163 # put - put a user
 164 #
 165
 166 sub put
 167 {
 168         my $self = shift;
 169         my $call = $self->{call};
 170         $u{$call} = $self;
 171 }
 172
 173 #
 174 # create a string from a user reference
 175 #
 176 sub encode
 177 {
 178         my $self = shift;
 179         my $out;
 180         my $f;
 181
 182         $out = "bless( { ";
 183         for $f (sort keys %$self) {
 184                 my $val = $$self{$f};
 185             if (ref $val) {          # it's an array (we think)
 186                         $out .= "'$f'=>[ ";
 187                         foreach (@$val) {
 188                                 my $s = $_;
 189                                 $out .= "'$s',";
 190                         }
 191                         $out .= " ],";
 192             } else {
 193                         $val =~ s/'/\\'/og;
 194                         $out .= "'$f'=>'$val',";
 195                 }
 196         }
 197         $out .= " }, 'DXUser')";
 198         return $out;
 199 }
 200
 201 #
 202 # create a hash from a string
 203 #
 204 sub decode
 205 {
 206         my $s = shift;
 207         my $ref;
 208         $s = '$ref = ' . $s;
 209         eval $s;
 210         confess $@ if $@;
 211         return $ref;
 212 }
 213
 214 #
 215 # del - delete a user
 216 #
 217
 218 sub del
 219 {
 220         my $self = shift;
 221         my $call = $self->{call};
 222         delete $u{$call};
 223 }
 224
 225 #
 226 # close - close down a user
 227 #
 228
 229 sub close
 230 {
 231         my $self = shift;
 232         $self->{lastin} = time;
 233         $self->put();
 234 }
 235
 236 #
 237 # return a list of valid elements
 238 #
 239
 240 sub fields
 241 {
 242         return keys(%valid);
 243 }
 244
 245 #
 246 # group handling
 247 #
 248
 249 # add one or more groups
 250 sub add_group
 251 {
 252         my $self = shift;
 253         my $ref = $self->{group} || [ 'local' ];
 254         $self->{group} = $ref if !$self->{group};
 255         push @$ref, @_ if @_;
 256 }
 257
 258 # remove one or more groups
 259 sub del_group
 260 {
 261         my $self = shift;
 262         my $ref = $self->{group} || [ 'local' ];
 263         my @in = @_;
 264
 265         $self->{group} = $ref if !$self->{group};
 266
 267         @$ref = map { my $a = $_; return (grep { $_ eq $a } @in) ? () : $a } @$ref;
 268 }
 269
 270 # does this thing contain all the groups listed?
 271 sub union
 272 {
 273         my $self = shift;
 274         my $ref = $self->{group};
 275         my $n;
 276
 277         return 0 if !$ref || @_ == 0;
 278         return 1 if @$ref == 0 && @_ == 0;
 279         for ($n = 0; $n < @_; ) {
 280                 for (@$ref) {
 281                         my $a = $_;
 282                         $n++ if grep $_ eq $a, @_;
 283                 }
 284         }
 285         return $n >= @_;
 286 }
 287
 288 # simplified group test just for one group
 289 sub in_group
 290 {
 291         my $self = shift;
 292         my $s = shift;
 293         my $ref = $self->{group};
 294
 295         return 0 if !$ref;
 296         return grep $_ eq $s, $ref;
 297 }
 298
 299 # set up a default group (only happens for them's that connect direct)
 300 sub new_group
 301 {
 302         my $self = shift;
 303         $self->{group} = [ 'local' ];
 304 }
 305
 306 #
 307 # return a prompt for a field
 308 #
 309
 310 sub field_prompt
 311 {
 312         my ($self, $ele) = @_;
 313         return $valid{$ele};
 314 }
 315
 316 # some variable accessors
 317 sub sort
 318 {
 319         my $self = shift;
 320         @_ ? $self->{'sort'} = shift : $self->{'sort'} ;
 321 }
 322 1;
 323 __END__