]> dxcluster.org Git - spider.git/blob - perl/DXDb.pm
add ak1a compat changes to chat
[spider.git] / perl / DXDb.pm
1 #!/usr/bin/perl -w
2 #
3 # Database Handler module for DXSpider
4 #
5 # Copyright (c) 1999 Dirk Koopman G1TLH
6 #
7
8 package DXDb;
9
10 use strict;
11 use DXVars;
12 use DXLog;
13 use DXUtil;
14 use DB_File;
15 use DXDebug;
16
17 use vars qw($opentime $dbbase %avail %valid $lastprocesstime $nextstream %stream);
18
19 $opentime = 5*60;                               # length of time a database stays open after last access
20 $dbbase = "$main::root/db";             # where all the databases are kept;
21 %avail = ();                                    # The hash contains a list of all the databases
22 %valid = (
23                   accesst => '9,Last Accs Time,atime',
24                   createt => '9,Create Time,atime',
25                   lastt => '9,Last Upd Time,atime',
26                   name => '0,Name',
27                   db => '9,DB Tied hash',
28                   remote => '0,Remote Database',
29                   pre => '0,Heading txt',
30                   post => '0,Tail txt',
31                   chain => '0,Search these,parray',
32                   disable => '0,Disabled?,yesno',
33                   nf => '0,Not Found txt',
34                   cal => '0,No Key txt',
35                   allowread => '9,Allowed read,parray',
36                   denyread => '9,Deny read,parray',
37                   allowupd => '9,Allow upd,parray',
38                   denyupd => '9,Deny upd,parray',
39                   fwdupd => '9,Forw upd to,parray',
40                   template => '9,Upd Templates,parray',
41                   te => '9,End Upd txt',
42                   tae => '9,End App txt',
43                   atemplate => '9,App Templates,parray',
44                   help => '0,Help txt,parray',
45                   localcmd => '0,Local Command',
46                  );
47
48 $lastprocesstime = time;
49 $nextstream = 0;
50 %stream = ();
51
52 use vars qw($VERSION $BRANCH);
53 $VERSION = sprintf( "%d.%03d", q$Revision$ =~ /(\d+)\.(\d+)/ );
54 $BRANCH = sprintf( "%d.%03d", q$Revision$ =~ /\d+\.\d+\.(\d+)\.(\d+)/  || (0,0));
55 $main::build += $VERSION;
56 $main::branch += $BRANCH;
57
58 # allocate a new stream for this request
59 sub newstream
60 {
61         my $call = uc shift;
62         my $n = ++$nextstream;
63         $stream{$n} = { n=>$n, call=>$call, t=>$main::systime };
64         return $n;
65 }
66
67 # delete a stream
68 sub delstream
69 {
70         my $n = shift;
71         delete $stream{$n};
72 }
73
74 # get a stream
75 sub getstream
76 {
77         my $n = shift;
78         return $stream{$n};
79 }
80
81 # load all the database descriptors
82 sub load
83 {
84         my $s = readfilestr($dbbase, "dbs", "pl");
85         if ($s) {
86                 my $a;
87                 eval "\$a = $s";
88                 confess $@ if $@;
89                 %avail = ( %$a ) if ref $a;
90         }
91 }
92
93 # save all the database descriptors
94 sub save
95 {
96         closeall();
97         writefilestr($dbbase, "dbs", "pl", \%avail);
98 }
99
100 # get the descriptor of the database you want.
101 sub getdesc
102 {
103         return undef unless %avail;
104         
105         my $name = lc shift;
106         my $r = $avail{$name};
107
108         # search for a partial if not found direct
109         unless ($r) {
110                 for (sort { $a->{name} cmp $b->{name} }values %avail) {
111                         if ($_->{name} =~ /^$name/) {
112                                 $r = $_;
113                                 last;
114                         }
115                 }
116         }
117         return $r;
118 }
119
120 # open it
121 sub open
122 {
123         my $self = shift;
124         $self->{accesst} = $main::systime;
125         return $self->{db} if $self->{db};
126         my %hash;
127         $self->{db} = tie %hash, 'DB_File', "$dbbase/$self->{name}";
128 #       untie %hash;
129         return $self->{db};
130 }
131
132 # close it
133 sub close
134 {
135         my $self = shift;
136         if ($self->{db}) {
137                 undef $self->{db};
138                 delete $self->{db};
139         }
140 }
141
142 # close all
143 sub closeall
144 {
145         if (%avail) {
146                 for (values %avail) {
147                         $_->close();
148                 }
149         }
150 }
151
152 # get a value from the database
153 sub getkey
154 {
155         my $self = shift;
156         my $key = uc shift;
157         my $value;
158
159         # make sure we are open
160         $self->open;
161         if ($self->{localcmd}) {
162                 my $dxchan = $main::me;
163                 $dxchan->{remotecmd} = 1; # for the benefit of any command that needs to know
164                 my $oldpriv = $dxchan->{priv};
165                 $dxchan->{priv} = 0;
166                 my @in = (DXCommandmode::run_cmd($dxchan, "$self->{localcmd} $key"));
167                 $dxchan->{priv} = $oldpriv;
168                 delete $dxchan->{remotecmd};
169                 return @in ? join("\n", @in) : undef;
170         } elsif ($self->{db}) {
171                 my $s = $self->{db}->get($key, $value);
172                 return $s ? undef : $value;
173         }
174         return undef;
175 }
176
177 # put a value to the database
178 sub putkey
179 {
180         my $self = shift;
181         my $key = uc shift;
182         my $value = shift;
183
184         # make sure we are open
185         $self->open;
186         if ($self->{db}) {
187                 my $s = $self->{db}->put($key, $value);
188                 return $s ? undef : 1;
189         }
190         return undef;
191 }
192
193 # create a new database params: <name> [<remote node call>]
194 sub new
195 {
196         my $self = bless {};
197         my $name = shift;
198         my $remote = shift;
199         my $chain = shift;
200         my $cmd = shift;
201         
202         $self->{name} = lc $name;
203         $self->{remote} = uc $remote if $remote;
204         $self->{chain} = $chain if $chain && ref $chain;
205         $self->{accesst} = $self->{createt} = $self->{lastt} = $main::systime;
206         $self->{localcmd} = lc $cmd if $cmd;
207         
208         $avail{$self->{name}} = $self;
209         mkdir $dbbase, 02775 unless -e $dbbase;
210         save();
211         return $self;
212 }
213
214 # delete a database
215 sub delete
216 {
217         my $self = shift;
218         $self->close;
219         unlink "$dbbase/$self->{name}";
220         delete $avail{$self->{name}};
221         save();
222 }
223
224 #
225 # process intermediate lines for an update
226 # NOTE THAT THIS WILL BE CALLED FROM DXCommandmode and the
227 # object will be a DXChannel (actually DXCommandmode)
228 #
229 sub normal
230 {
231         
232 }
233
234 #
235 # periodic maintenance
236 #
237 # just close any things that haven't been accessed for the default
238 # time 
239 #
240 #
241 sub process
242 {
243         my ($dxchan, $line) = @_;
244
245         # this is periodic processing
246         if (!$dxchan || !$line) {
247                 if ($main::systime - $lastprocesstime >= 60) {
248                         if (%avail) {
249                                 for (values %avail) {
250                                         if ($main::systime - $_->{accesst} > $opentime) {
251                                                 $_->close;
252                                         }
253                                 }
254                         }
255                         $lastprocesstime = $main::systime;
256                 }
257                 return;
258         }
259
260         my @f = split /\^/, $line;
261         my ($pcno) = $f[0] =~ /^PC(\d\d)/; # just get the number
262
263         # route out ones that are not for us
264         if ($f[1] eq $main::mycall) {
265                 ;
266         } else {
267                 $dxchan->route($f[1], $line);
268                 return;
269         }
270
271  SWITCH: {
272                 if ($pcno == 37) {              # probably obsolete
273                         last SWITCH;
274                 }
275
276                 if ($pcno == 44) {              # incoming DB Request
277                         my @in = DXCommandmode::run_cmd($dxchan, "dbshow $f[4] $f[5]");
278                         sendremote($dxchan, $f[2], $f[3], @in);
279                         last SWITCH;
280                 }
281
282                 if ($pcno == 45) {              # incoming DB Information
283                         my $n = getstream($f[3]);
284                         if ($n) {
285                                 my $mchan = DXChannel->get($n->{call});
286                                 $mchan->send($f[2] . ":$f[4]") if $mchan;
287                         }
288                         last SWITCH;
289                 }
290
291                 if ($pcno == 46) {              # incoming DB Complete
292                         delstream($f[3]);
293                         last SWITCH;
294                 }
295
296                 if ($pcno == 47) {              # incoming DB Update request
297                         last SWITCH;
298                 }
299
300                 if ($pcno == 48) {              # incoming DB Update request 
301                         last SWITCH;
302                 }
303         }       
304 }
305
306 # send back a trache of data to the remote
307 # remember $dxchan is a dxchannel
308 sub sendremote
309 {
310         my $dxchan = shift;
311         my $tonode = shift;
312         my $stream = shift;
313
314         for (@_) {
315                 $dxchan->send(DXProt::pc45($main::mycall, $tonode, $stream, $_));
316         }
317         $dxchan->send(DXProt::pc46($main::mycall, $tonode, $stream));
318 }
319
320 # print a value from the db reference
321 sub print
322 {
323         my $self = shift;
324         my $s = shift;
325         return $self->{$s} ? $self->{$s} : undef; 
326
327
328 # various access routines
329
330 #
331 # return a list of valid elements 
332
333
334 sub fields
335 {
336         return keys(%valid);
337 }
338
339 #
340 # return a prompt for a field
341 #
342
343 sub field_prompt
344
345         my ($self, $ele) = @_;
346         return $valid{$ele};
347 }
348
349 #no strict;
350 sub AUTOLOAD
351 {
352         no strict;
353         my $name = $AUTOLOAD;
354         return if $name =~ /::DESTROY$/;
355         $name =~ s/^.*:://o;
356   
357         confess "Non-existant field '$AUTOLOAD'" if !$valid{$name};
358         # this clever line of code creates a subroutine which takes over from autoload
359         # from OO Perl - Conway
360         *$AUTOLOAD = sub {@_ > 1 ? $_[0]->{$name} = $_[1] : $_[0]->{$name}};
361         goto &$AUTOLOAD;
362 }
363
364 1;