3 # Database Handler module for DXSpider
5 # Copyright (c) 1999 Dirk Koopman G1TLH
17 use vars qw($opentime $dbbase %avail %valid $lastprocesstime $nextstream %stream);
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
23 accesst => '9,Last Accs Time,atime',
24 createt => '9,Create Time,atime',
25 lastt => '9,Last Upd Time,atime',
27 db => '9,DB Tied hash',
28 remote => '0,Remote Database',
29 pre => '0,Heading 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',
48 $lastprocesstime = time;
52 # allocate a new stream for this request
56 my $n = ++$nextstream;
57 $stream{$n} = { n=>$n, call=>$call, t=>$main::systime };
75 # load all the database descriptors
78 my $s = readfilestr($dbbase, "dbs", "pl");
83 %avail = ( %$a ) if ref $a;
87 # save all the database descriptors
91 writefilestr($dbbase, "dbs", "pl", \%avail);
94 # get the descriptor of the database you want.
97 return undef unless %avail;
100 my $r = $avail{$name};
102 # search for a partial if not found direct
104 for (sort { $a->{name} cmp $b->{name} }values %avail) {
105 if ($_->{name} =~ /^$name/) {
118 $self->{accesst} = $main::systime;
119 return $self->{db} if $self->{db};
121 $self->{db} = tie %hash, 'DB_File', "$dbbase/$self->{name}";
140 for (values %avail) {
146 # get a value from the database
154 $key =~ s/[\@\$\&\%\*]+//g;
155 $key =~ s/^[\.\/]+//g;
157 # make sure we are open
159 if ($self->{localcmd}) {
160 my $dxchan = $main::me;
161 $dxchan->{remotecmd} = 1; # for the benefit of any command that needs to know
162 my $oldpriv = $dxchan->{priv};
164 my @in = (DXCommandmode::run_cmd($dxchan, "$self->{localcmd} $key"));
165 $dxchan->{priv} = $oldpriv;
166 delete $dxchan->{remotecmd};
167 return @in ? join("\n", @in) : undef;
168 } elsif ($self->{db}) {
169 my $s = $self->{db}->get($key, $value);
170 return $s ? undef : $value;
175 # put a value to the database
182 # make sure we are open
185 my $s = $self->{db}->put($key, $value);
186 return $s ? undef : 1;
191 # create a new database params: <name> [<remote node call>]
200 $self->{name} = lc $name;
201 $self->{remote} = uc $remote if $remote;
202 $self->{chain} = $chain if $chain && ref $chain;
203 $self->{accesst} = $self->{createt} = $self->{lastt} = $main::systime;
204 $self->{localcmd} = lc $cmd if $cmd;
206 $avail{$self->{name}} = $self;
207 mkdir $dbbase, 02775 unless -e $dbbase;
217 unlink "$dbbase/$self->{name}";
218 delete $avail{$self->{name}};
223 # process intermediate lines for an update
224 # NOTE THAT THIS WILL BE CALLED FROM DXCommandmode and the
225 # object will be a DXChannel (actually DXCommandmode)
233 # periodic maintenance
235 # just close any things that haven't been accessed for the default
241 if ($main::systime - $lastprocesstime >= 60) {
243 for (values %avail) {
244 if ($main::systime - $_->{accesst} > $opentime) {
249 $lastprocesstime = $main::systime;
262 # incoming DB Request
263 my @in = DXCommandmode::run_cmd($self, "dbshow $_[4] $_[5]");
264 sendremote($self, $_[2], $_[3], @in);
271 # incoming DB Information
272 my $n = getstream($_[3]);
274 my $mchan = DXChannel::get($n->{call});
275 $mchan->send($_[2] . ":$_[4]") if $mchan;
283 # incoming DB Complete
295 # send back a trache of data to the remote
296 # remember $dxchan is a dxchannel
304 $dxchan->send(DXProt::pc45($main::mycall, $tonode, $stream, $_));
306 $dxchan->send(DXProt::pc46($main::mycall, $tonode, $stream));
309 # print a value from the db reference
314 return $self->{$s} ? $self->{$s} : undef;
317 # various access routines
320 # return a list of valid elements
329 # return a prompt for a field
334 my ($self, $ele) = @_;
342 my $name = $AUTOLOAD;
343 return if $name =~ /::DESTROY$/;
346 confess "Non-existant field '$AUTOLOAD'" if !$valid{$name};
347 # this clever line of code creates a subroutine which takes over from autoload
348 # from OO Perl - Conway
349 *$AUTOLOAD = sub {@_ > 1 ? $_[0]->{$name} = $_[1] : $_[0]->{$name}};