]> scm.dxcluster.org Git - spider.git/blob - perl/DXUser.pm
started the addition of help files
[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 = undef;
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,Home Node',
43   lockout => '9,Locked out?,yesno',        # won't let them in at all
44   dxok => '9,DX Spots?,yesno',            # accept his dx spots?
45   annok => '9,Announces?,yesno',            # accept his announces?
46   reg => '0,Registered?,yesno',            # is this user registered?
47   lang => '0,Language',
48 );
49
50 no strict;
51 sub AUTOLOAD
52 {
53   my $self = shift;
54   my $name = $AUTOLOAD;
55   
56   return if $name =~ /::DESTROY$/;
57   $name =~ s/.*:://o;
58   
59   confess "Non-existant field '$AUTOLOAD'" if !$valid{$name};
60   if (@_) {
61     $self->{$name} = shift;
62         $self->put();
63   }
64   return $self->{$name};
65 }
66
67 #
68 # initialise the system
69 #
70 sub init
71 {
72   my ($pkg, $fn) = @_;
73   
74   die "need a filename in User" if !$fn;
75   $dbm = tie (%u, MLDBM, $fn, O_CREAT|O_RDWR, 0666) or die "can't open user file: $fn ($!)";
76   $filename = $fn;
77 }
78
79 use strict;
80
81 #
82 # close the system
83 #
84
85 sub finish
86 {
87   $dbm = undef;
88   untie %u;
89 }
90
91 #
92 # new - create a new user
93 #
94
95 sub new
96 {
97   my ($pkg, $call) = @_;
98   die "can't create existing call $call in User\n!" if $u{$call};
99
100   my $self = {};
101   $self->{call} = $call;
102   $self->{sort} = 'U';
103   $self->{dxok} = 1;
104   $self->{annok} = 1;
105   bless $self, $pkg;
106   $u{call} = $self;
107 }
108
109 #
110 # get - get an existing user - this seems to return a different reference everytime it is
111 #       called - see below
112 #
113
114 sub get
115 {
116   my $pkg = shift;
117   my $call = uc shift;
118   $call =~ s/-\d+//o;       # strip ssid
119   return $u{$call};
120 }
121
122 #
123 # get all callsigns in the database 
124 #
125
126 sub get_all_calls
127 {
128   return keys %u;
129 }
130
131 #
132 # get an existing either from the channel (if there is one) or from the database
133 #
134 # It is important to note that if you have done a get (for the channel say) and you
135 # want access or modify that you must use this call (and you must NOT use get's all
136 # over the place willy nilly!)
137 #
138
139 sub get_current
140 {
141   my $pkg = shift;
142   my $call = uc shift;
143   $call =~ s/-\d+//o;       # strip ssid
144   
145   my $dxchan = DXChannel->get($call);
146   return $dxchan->user if $dxchan;
147   return $u{$call};
148 }
149
150 #
151 # put - put a user
152 #
153
154 sub put
155 {
156   my $self = shift;
157   my $call = $self->{call};
158   $u{$call} = $self;
159 }
160
161 #
162 # del - delete a user
163 #
164
165 sub del
166 {
167   my $self = shift;
168   my $call = $self->{call};
169   delete $u{$call};
170 }
171
172 #
173 # close - close down a user
174 #
175
176 sub close
177 {
178   my $self = shift;
179   $self->{lastin} = time;
180   $self->put();
181 }
182
183 #
184 # return a list of valid elements 
185
186
187 sub fields
188 {
189   return keys(%valid);
190 }
191
192 #
193 # return a prompt for a field
194 #
195
196 sub field_prompt
197
198   my ($self, $ele) = @_;
199   return $valid{$ele};
200 }
201
202 #
203 # enter an element from input, returns 1 for success
204 #
205
206 sub enter
207 {
208   my ($self, $ele, $value) = @_;
209   return 0 if (!defined $valid{$ele});
210   chomp $value;
211   return 0 if $value eq "";
212   if ($ele eq 'long') {
213     my ($longd, $longm, $longl) = $value =~ /(\d+) (\d+) ([EWew])/;
214         return 0 if (!$longl || $longd < 0 || $longd > 180 || $longm < 0 || $longm > 59);
215         $longd += ($longm/60);
216         $longd = 0-$longd if (uc $longl) eq 'W'; 
217         $self->{'long'} = $longd;
218         return 1;
219   } elsif ($ele eq 'lat') {
220     my ($latd, $latm, $latl) = $value =~ /(\d+) (\d+) ([NSns])/;
221         return 0 if (!$latl || $latd < 0 || $latd > 90 || $latm < 0 || $latm > 59);
222         $latd += ($latm/60);
223         $latd = 0-$latd if (uc $latl) eq 'S';
224         $self->{'lat'} = $latd;
225         return 1;
226   } elsif ($ele eq 'qra') {
227     $self->{'qra'} = UC $value;
228         return 1;
229   } else {
230     $self->{$ele} = $value;               # default action
231         return 1;
232   }
233   return 0;
234 }
235
236 # some variable accessors
237 sub sort
238 {
239   my $self = shift;
240   @_ ? $self->{sort} = shift : $self->{sort} ;
241 }
242 1;
243 __END__