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