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