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