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                   allowread => '9,Allowed read,parray',
  25                   allowupd => '9,Allow upd,parray',
  26                   atemplate => '9,App Templates,parray',
  27                   cal => '0,No Key txt',
  28                   chain => '0,Search these,parray',
  29                   createt => '9,Create Time,atime',
  30                   db => '9,DB Tied hash',
  31                   denyread => '9,Deny read,parray',
  32                   denyupd => '9,Deny upd,parray',
  33                   disable => '0,Disabled?,yesno',
  34                   fwdupd => '9,Forw upd to,parray',
  35                   help => '0,Help txt,parray',
  36                   lastt => '9,Last Upd Time,atime',
  37                   localcmd => '0,Local Command',
  38                   name => '0,Name',
  39                   nf => '0,Not Found txt',
  40                   post => '0,Tail txt',
  41                   pre => '0,Heading txt',
  42                   remote => '0,Remote Database',
  43                   tae => '9,End App txt',
  44                   te => '9,End Upd txt',
  45                   template => '9,Upd Templates,parray',
  46                  );
  47
  48 $lastprocesstime = time;
  49 $nextstream = 0;
  50 %stream = ();
  51
  52 # allocate a new stream for this request
  53 sub newstream
  54 {
  55         my $call = uc shift;
  56         my $n = ++$nextstream;
  57         $stream{$n} = { n=>$n, call=>$call, t=>$main::systime };
  58         return $n;
  59 }
  60
  61 # delete a stream
  62 sub delstream
  63 {
  64         my $n = shift;
  65         delete $stream{$n};
  66 }
  67
  68 # get a stream
  69 sub getstream
  70 {
  71         my $n = shift;
  72         return $stream{$n};
  73 }
  74
  75 # load all the database descriptors
  76 sub load
  77 {
  78         my $s = readfilestr($dbbase, "dbs", "pl");
  79         if ($s) {
  80                 my $a;
  81                 eval "\$a = $s";
  82                 confess $@ if $@;
  83                 %avail = ( %$a ) if ref $a;
  84         }
  85 }
  86
  87 # save all the database descriptors
  88 sub save
  89 {
  90         closeall();
  91         writefilestr($dbbase, "dbs", "pl", \%avail);
  92 }
  93
  94 # get the descriptor of the database you want.
  95 sub getdesc
  96 {
  97         return undef unless %avail;
  98
  99         my $name = lc shift;
 100         my $r = $avail{$name};
 101
 102         # search for a partial if not found direct
 103         unless ($r) {
 104                 for (sort { $a->{name} cmp $b->{name} }values %avail) {
 105                         if ($_->{name} =~ /^$name/) {
 106                                 $r = $_;
 107                                 last;
 108                         }
 109                 }
 110         }
 111         return $r;
 112 }
 113
 114 # open it
 115 sub open
 116 {
 117         my $self = shift;
 118         $self->{accesst} = $main::systime;
 119         return $self->{db} if $self->{db};
 120         my %hash;
 121         $self->{db} = tie %hash, 'DB_File', "$dbbase/$self->{name}";
 122 #       untie %hash;
 123         return $self->{db};
 124 }
 125
 126 # close it
 127 sub close
 128 {
 129         my $self = shift;
 130         if ($self->{db}) {
 131                 undef $self->{db};
 132                 delete $self->{db};
 133         }
 134 }
 135
 136 # close all
 137 sub closeall
 138 {
 139         if (%avail) {
 140                 for (values %avail) {
 141                         $_->close();
 142                 }
 143         }
 144 }
 145
 146 # get a value from the database
 147 sub getkey
 148 {
 149         my $self = shift;
 150         my $key = uc shift;
 151         my $value;
 152
 153         # massage the key
 154         $key =~ s/[\@\$\&\%\*]+//g;
 155         $key =~ s/^[\.\/]+//g;
 156
 157         # make sure we are open
 158         $self->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};
 163                 $dxchan->{priv} = 0;
 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;
 171         }
 172         return undef;
 173 }
 174
 175 # put a value to the database
 176 sub putkey
 177 {
 178         my $self = shift;
 179         my $key = uc shift;
 180         my $value = shift;
 181
 182         # make sure we are open
 183         $self->open;
 184         if ($self->{db}) {
 185                 my $s = $self->{db}->put($key, $value);
 186                 return $s ? undef : 1;
 187         }
 188         return undef;
 189 }
 190
 191 # create a new database params: <name> [<remote node call>]
 192 sub new
 193 {
 194         my $self = bless {};
 195         my $name = shift;
 196         my $remote = shift;
 197         my $chain = shift;
 198         my $cmd = shift;
 199
 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;
 205
 206         $avail{$self->{name}} = $self;
 207         mkdir $dbbase, 02775 unless -e $dbbase;
 208         save();
 209         return $self;
 210 }
 211
 212 # delete a database
 213 sub delete
 214 {
 215         my $self = shift;
 216         $self->close;
 217         unlink "$dbbase/$self->{name}";
 218         delete $avail{$self->{name}};
 219         save();
 220 }
 221
 222 #
 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)
 226 #
 227 sub normal
 228 {
 229
 230 }
 231
 232 #
 233 # periodic maintenance
 234 #
 235 # just close any things that haven't been accessed for the default
 236 # time
 237 #
 238 #
 239 sub process
 240 {
 241         if ($main::systime - $lastprocesstime >= 60) {
 242                 if (%avail) {
 243                         for (values %avail) {
 244                                 if ($main::systime - $_->{accesst} > $opentime) {
 245                                         $_->close;
 246                                 }
 247                         }
 248                 }
 249                 $lastprocesstime = $main::systime;
 250         }
 251 }
 252
 253 sub handle_37
 254 {
 255
 256 }
 257
 258 sub handle_44
 259 {
 260         my $self = shift;
 261
 262         # incoming DB Request
 263         my @in = DXCommandmode::run_cmd($self, "dbshow $_[4] $_[5]");
 264         sendremote($self, $_[2], $_[3], @in);
 265 }
 266
 267 sub handle_45
 268 {
 269         my $self = shift;
 270
 271         # incoming DB Information
 272         my $n = getstream($_[3]);
 273         if ($n) {
 274                 my $mchan = DXChannel::get($n->{call});
 275                 $mchan->send($_[2] . ":$_[4]") if $mchan;
 276         }
 277 }
 278
 279 sub handle_46
 280 {
 281         my $self = shift;
 282
 283         # incoming DB Complete
 284         delstream($_[3]);
 285 }
 286
 287 sub handle_47
 288 {
 289 }
 290
 291 sub handle_48
 292 {
 293 }
 294
 295 # send back a trache of data to the remote
 296 # remember $dxchan is a dxchannel
 297 sub sendremote
 298 {
 299         my $dxchan = shift;
 300         my $tonode = shift;
 301         my $stream = shift;
 302
 303         for (@_) {
 304                 $dxchan->send(DXProt::pc45($main::mycall, $tonode, $stream, $_));
 305         }
 306         $dxchan->send(DXProt::pc46($main::mycall, $tonode, $stream));
 307 }
 308
 309 # print a value from the db reference
 310 sub print
 311 {
 312         my $self = shift;
 313         my $s = shift;
 314         return $self->{$s} ? $self->{$s} : undef;
 315 }
 316
 317 # various access routines
 318
 319 #
 320 # return a list of valid elements
 321 #
 322
 323 sub fields
 324 {
 325         return keys(%valid);
 326 }
 327
 328 #
 329 # return a prompt for a field
 330 #
 331
 332 sub field_prompt
 333 {
 334         my ($self, $ele) = @_;
 335         return $valid{$ele};
 336 }
 337
 338 #no strict;
 339 sub AUTOLOAD
 340 {
 341         no strict;
 342         my $name = $AUTOLOAD;
 343         return if $name =~ /::DESTROY$/;
 344         $name =~ s/^.*:://o;
 345
 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}};
 350         goto &$AUTOLOAD;
 351 }
 352
 353 1;