]> dxcluster.net Git - spider.git/blob - perl/DXDb.pm
add latest cty
[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         # massage the key
160         $key =~ s/[\@\$\&\%\*]+//g;
161         $key =~ s/^[\.\/]+//g;
162         
163         # make sure we are open
164         $self->open;
165         if ($self->{localcmd}) {
166                 my $dxchan = $main::me;
167                 $dxchan->{remotecmd} = 1; # for the benefit of any command that needs to know
168                 my $oldpriv = $dxchan->{priv};
169                 $dxchan->{priv} = 0;
170                 my @in = (DXCommandmode::run_cmd($dxchan, "$self->{localcmd} $key"));
171                 $dxchan->{priv} = $oldpriv;
172                 delete $dxchan->{remotecmd};
173                 return @in ? join("\n", @in) : undef;
174         } elsif ($self->{db}) {
175                 my $s = $self->{db}->get($key, $value);
176                 return $s ? undef : $value;
177         }
178         return undef;
179 }
180
181 # put a value to the database
182 sub putkey
183 {
184         my $self = shift;
185         my $key = uc shift;
186         my $value = shift;
187
188         # make sure we are open
189         $self->open;
190         if ($self->{db}) {
191                 my $s = $self->{db}->put($key, $value);
192                 return $s ? undef : 1;
193         }
194         return undef;
195 }
196
197 # create a new database params: <name> [<remote node call>]
198 sub new
199 {
200         my $self = bless {};
201         my $name = shift;
202         my $remote = shift;
203         my $chain = shift;
204         my $cmd = shift;
205         
206         $self->{name} = lc $name;
207         $self->{remote} = uc $remote if $remote;
208         $self->{chain} = $chain if $chain && ref $chain;
209         $self->{accesst} = $self->{createt} = $self->{lastt} = $main::systime;
210         $self->{localcmd} = lc $cmd if $cmd;
211         
212         $avail{$self->{name}} = $self;
213         mkdir $dbbase, 02775 unless -e $dbbase;
214         save();
215         return $self;
216 }
217
218 # delete a database
219 sub delete
220 {
221         my $self = shift;
222         $self->close;
223         unlink "$dbbase/$self->{name}";
224         delete $avail{$self->{name}};
225         save();
226 }
227
228 #
229 # process intermediate lines for an update
230 # NOTE THAT THIS WILL BE CALLED FROM DXCommandmode and the
231 # object will be a DXChannel (actually DXCommandmode)
232 #
233 sub normal
234 {
235         
236 }
237
238 #
239 # periodic maintenance
240 #
241 # just close any things that haven't been accessed for the default
242 # time 
243 #
244 #
245 sub process
246 {
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 }
258
259 sub handle_37
260 {               
261
262 }
263
264 sub handle_44
265 {       
266         my $self = shift;
267
268         # incoming DB Request
269         my @in = DXCommandmode::run_cmd($self, "dbshow $_[4] $_[5]");
270         sendremote($self, $_[2], $_[3], @in);
271 }
272
273 sub handle_45
274 {               
275         my $self = shift;
276
277         # incoming DB Information
278         my $n = getstream($_[3]);
279         if ($n) {
280                 my $mchan = DXChannel::get($n->{call});
281                 $mchan->send($_[2] . ":$_[4]") if $mchan;
282         }
283 }
284
285 sub handle_46
286 {               
287         my $self = shift;
288
289         # incoming DB Complete
290         delstream($_[3]);
291 }
292
293 sub handle_47
294 {
295 }
296
297 sub handle_48
298 {
299 }
300
301 # send back a trache of data to the remote
302 # remember $dxchan is a dxchannel
303 sub sendremote
304 {
305         my $dxchan = shift;
306         my $tonode = shift;
307         my $stream = shift;
308
309         for (@_) {
310                 $dxchan->send(DXProt::pc45($main::mycall, $tonode, $stream, $_));
311         }
312         $dxchan->send(DXProt::pc46($main::mycall, $tonode, $stream));
313 }
314
315 # print a value from the db reference
316 sub print
317 {
318         my $self = shift;
319         my $s = shift;
320         return $self->{$s} ? $self->{$s} : undef; 
321
322
323 # various access routines
324
325 #
326 # return a list of valid elements 
327
328
329 sub fields
330 {
331         return keys(%valid);
332 }
333
334 #
335 # return a prompt for a field
336 #
337
338 sub field_prompt
339
340         my ($self, $ele) = @_;
341         return $valid{$ele};
342 }
343
344 #no strict;
345 sub AUTOLOAD
346 {
347         no strict;
348         my $name = $AUTOLOAD;
349         return if $name =~ /::DESTROY$/;
350         $name =~ s/^.*:://o;
351   
352         confess "Non-existant field '$AUTOLOAD'" if !$valid{$name};
353         # this clever line of code creates a subroutine which takes over from autoload
354         # from OO Perl - Conway
355         *$AUTOLOAD = sub {@_ > 1 ? $_[0]->{$name} = $_[1] : $_[0]->{$name}};
356         goto &$AUTOLOAD;
357 }
358
359 1;