From 39c43b632223b4c11eac1253b523153e9cd5be94 Mon Sep 17 00:00:00 2001 From: djk Date: Thu, 3 Jun 1999 20:17:39 +0000 Subject: [PATCH] *** empty log message *** --- perl/DXUser_old.pm | 323 --------------------------------------------- 1 file changed, 323 deletions(-) delete mode 100644 perl/DXUser_old.pm diff --git a/perl/DXUser_old.pm b/perl/DXUser_old.pm deleted file mode 100644 index 70b066dc..00000000 --- a/perl/DXUser_old.pm +++ /dev/null @@ -1,323 +0,0 @@ -# -# DX cluster user routines -# -# Copyright (c) 1998 - Dirk Koopman G1TLH -# -# $Id$ -# - -package DXUser; - -require Exporter; -@ISA = qw(Exporter); - -use MLDBM qw(DB_File); -use Fcntl; -use Carp; - -use strict; -use vars qw(%u $dbm $filename %valid); - -%u = (); -$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 -# -sub init -{ - my ($pkg, $fn, $mode) = @_; - - confess "need a filename in User" if !$fn; - if ($mode) { - $dbm = tie (%u, MLDBM, $fn, O_CREAT|O_RDWR, 0666) or confess "can't open user file: $fn ($!)"; - } else { - $dbm = tie (%u, MLDBM, $fn, O_RDONLY) or confess "can't open user file: $fn ($!)"; - } - - $filename = $fn; -} - -use strict; - -# -# close the system -# - -sub finish -{ - untie %u; -} - -# -# new - create a new user -# - -sub new -{ - 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 = bless {}, $pkg; - $self->{call} = $call; - $self->{'sort'} = 'U'; - $self->{dxok} = 1; - $self->{annok} = 1; - $self->{lang} = $main::lang; - $u{call} = $self; - return $self; -} - -# -# get - get an existing user - this seems to return a different reference everytime it is -# called - see below -# - -sub get -{ - 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}; -} - -# -# put - put a user -# - -sub put -{ - my $self = shift; - my $call = $self->{call}; - $u{$call} = $self; -} - -# -# create a string from a user reference -# -sub encode -{ - my $self = shift; - my $out; - my $f; - - $out = "bless( { "; - for $f (sort keys %$self) { - my $val = $$self{$f}; - if (ref $val) { # it's an array (we think) - $out .= "'$f'=>[ "; - foreach (@$val) { - my $s = $_; - $out .= "'$s',"; - } - $out .= " ],"; - } else { - $val =~ s/'/\\'/og; - $out .= "'$f'=>'$val',"; - } - } - $out .= " }, 'DXUser')"; - return $out; -} - -# -# create a hash from a string -# -sub decode -{ - my $s = shift; - my $ref; - $s = '$ref = ' . $s; - eval $s; - confess $@ if $@; - return $ref; -} - -# -# del - delete a user -# - -sub del -{ - my $self = shift; - my $call = $self->{call}; - delete $u{$call}; -} - -# -# close - close down a user -# - -sub close -{ - my $self = shift; - $self->{lastin} = time; - $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__ -- 2.43.0