]> scm.dxcluster.org Git - spider.git/blob - perl/DXUser_old.pm
done more work on directory now really quite ak1a compatible
[spider.git] / 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__