]> www.dxcluster.org Git - spider.git/blob - perl/DXDb.pm
fix 5.8 ism that does not work on 5.6 (incrementing a subroutine).
[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
54 main::mkver($VERSION = q$Revision$);
55
56 # allocate a new stream for this request
57 sub newstream
58 {
59         my $call = uc shift;
60         my $n = ++$nextstream;
61         $stream{$n} = { n=>$n, call=>$call, t=>$main::systime };
62         return $n;
63 }
64
65 # delete a stream
66 sub delstream
67 {
68         my $n = shift;
69         delete $stream{$n};
70 }
71
72 # get a stream
73 sub getstream
74 {
75         my $n = shift;
76         return $stream{$n};
77 }
78
79 # load all the database descriptors
80 sub load
81 {
82         my $s = readfilestr($dbbase, "dbs", "pl");
83         if ($s) {
84                 my $a;
85                 eval "\$a = $s";
86                 confess $@ if $@;
87                 %avail = ( %$a ) if ref $a;
88         }
89 }
90
91 # save all the database descriptors
92 sub save
93 {
94         closeall();
95         writefilestr($dbbase, "dbs", "pl", \%avail);
96 }
97
98 # get the descriptor of the database you want.
99 sub getdesc
100 {
101         return undef unless %avail;
102         
103         my $name = lc shift;
104         my $r = $avail{$name};
105
106         # search for a partial if not found direct
107         unless ($r) {
108                 for (sort { $a->{name} cmp $b->{name} }values %avail) {
109                         if ($_->{name} =~ /^$name/) {
110                                 $r = $_;
111                                 last;
112                         }
113                 }
114         }
115         return $r;
116 }
117
118 # open it
119 sub open
120 {
121         my $self = shift;
122         $self->{accesst} = $main::systime;
123         return $self->{db} if $self->{db};
124         my %hash;
125         $self->{db} = tie %hash, 'DB_File', "$dbbase/$self->{name}";
126 #       untie %hash;
127         return $self->{db};
128 }
129
130 # close it
131 sub close
132 {
133         my $self = shift;
134         if ($self->{db}) {
135                 undef $self->{db};
136                 delete $self->{db};
137         }
138 }
139
140 # close all
141 sub closeall
142 {
143         if (%avail) {
144                 for (values %avail) {
145                         $_->close();
146                 }
147         }
148 }
149
150 # get a value from the database
151 sub getkey
152 {
153         my $self = shift;
154         my $key = uc shift;
155         my $value;
156
157         # massage the key
158         $key =~ s/[\@\$\&\%\*]+//g;
159         $key =~ s/^[\.\/]+//g;
160         
161         # make sure we are open
162         $self->open;
163         if ($self->{localcmd}) {
164                 my $dxchan = $main::me;
165                 $dxchan->{remotecmd} = 1; # for the benefit of any command that needs to know
166                 my $oldpriv = $dxchan->{priv};
167                 $dxchan->{priv} = 0;
168                 my @in = (DXCommandmode::run_cmd($dxchan, "$self->{localcmd} $key"));
169                 $dxchan->{priv} = $oldpriv;
170                 delete $dxchan->{remotecmd};
171                 return @in ? join("\n", @in) : undef;
172         } elsif ($self->{db}) {
173                 my $s = $self->{db}->get($key, $value);
174                 return $s ? undef : $value;
175         }
176         return undef;
177 }
178
179 # put a value to the database
180 sub putkey
181 {
182         my $self = shift;
183         my $key = uc shift;
184         my $value = shift;
185
186         # make sure we are open
187         $self->open;
188         if ($self->{db}) {
189                 my $s = $self->{db}->put($key, $value);
190                 return $s ? undef : 1;
191         }
192         return undef;
193 }
194
195 # create a new database params: <name> [<remote node call>]
196 sub new
197 {
198         my $self = bless {};
199         my $name = shift;
200         my $remote = shift;
201         my $chain = shift;
202         my $cmd = shift;
203         
204         $self->{name} = lc $name;
205         $self->{remote} = uc $remote if $remote;
206         $self->{chain} = $chain if $chain && ref $chain;
207         $self->{accesst} = $self->{createt} = $self->{lastt} = $main::systime;
208         $self->{localcmd} = lc $cmd if $cmd;
209         
210         $avail{$self->{name}} = $self;
211         mkdir $dbbase, 02775 unless -e $dbbase;
212         save();
213         return $self;
214 }
215
216 # delete a database
217 sub delete
218 {
219         my $self = shift;
220         $self->close;
221         unlink "$dbbase/$self->{name}";
222         delete $avail{$self->{name}};
223         save();
224 }
225
226 #
227 # process intermediate lines for an update
228 # NOTE THAT THIS WILL BE CALLED FROM DXCommandmode and the
229 # object will be a DXChannel (actually DXCommandmode)
230 #
231 sub normal
232 {
233         
234 }
235
236 #
237 # periodic maintenance
238 #
239 # just close any things that haven't been accessed for the default
240 # time 
241 #
242 #
243 sub process
244 {
245         if ($main::systime - $lastprocesstime >= 60) {
246                 if (%avail) {
247                         for (values %avail) {
248                                 if ($main::systime - $_->{accesst} > $opentime) {
249                                         $_->close;
250                                 }
251                         }
252                 }
253                 $lastprocesstime = $main::systime;
254         }
255 }
256
257 sub handle_37
258 {               
259
260 }
261
262 sub handle_44
263 {       
264         my $self = shift;
265
266         # incoming DB Request
267         my @in = DXCommandmode::run_cmd($self, "dbshow $_[4] $_[5]");
268         sendremote($self, $_[2], $_[3], @in);
269 }
270
271 sub handle_45
272 {               
273         my $self = shift;
274
275         # incoming DB Information
276         my $n = getstream($_[3]);
277         if ($n) {
278                 my $mchan = DXChannel::get($n->{call});
279                 $mchan->send($_[2] . ":$_[4]") if $mchan;
280         }
281 }
282
283 sub handle_46
284 {               
285         my $self = shift;
286
287         # incoming DB Complete
288         delstream($_[3]);
289 }
290
291 sub handle_47
292 {
293 }
294
295 sub handle_48
296 {
297 }
298
299 # send back a trache of data to the remote
300 # remember $dxchan is a dxchannel
301 sub sendremote
302 {
303         my $dxchan = shift;
304         my $tonode = shift;
305         my $stream = shift;
306
307         for (@_) {
308                 $dxchan->send(DXProt::pc45($main::mycall, $tonode, $stream, $_));
309         }
310         $dxchan->send(DXProt::pc46($main::mycall, $tonode, $stream));
311 }
312
313 # print a value from the db reference
314 sub print
315 {
316         my $self = shift;
317         my $s = shift;
318         return $self->{$s} ? $self->{$s} : undef; 
319
320
321 # various access routines
322
323 #
324 # return a list of valid elements 
325
326
327 sub fields
328 {
329         return keys(%valid);
330 }
331
332 #
333 # return a prompt for a field
334 #
335
336 sub field_prompt
337
338         my ($self, $ele) = @_;
339         return $valid{$ele};
340 }
341
342 #no strict;
343 sub AUTOLOAD
344 {
345         no strict;
346         my $name = $AUTOLOAD;
347         return if $name =~ /::DESTROY$/;
348         $name =~ s/^.*:://o;
349   
350         confess "Non-existant field '$AUTOLOAD'" if !$valid{$name};
351         # this clever line of code creates a subroutine which takes over from autoload
352         # from OO Perl - Conway
353         *$AUTOLOAD = sub {@_ > 1 ? $_[0]->{$name} = $_[1] : $_[0]->{$name}};
354         goto &$AUTOLOAD;
355 }
356
357 1;