]> scm.dxcluster.org Git - spider.git/blob - perl/DXUser.pm
1. Do some range checking for spots and WWV in the future (got a WWV for Oct
[spider.git] / 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 = {};
108   $self->{call} = $call;
109   $self->{'sort'} = 'U';
110   $self->{dxok} = 1;
111   $self->{annok} = 1;
112   $self->{lang} = $main::lang;
113   bless $self, $pkg;
114   $u{call} = $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__