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;