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