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;