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         # make sure we are open
 160         $self->open;
 161         if ($self->{localcmd}) {
 162                 my $dxchan = $main::me;
 163                 $dxchan->{remotecmd} = 1; # for the benefit of any command that needs to know
 164                 my $oldpriv = $dxchan->{priv};
 165                 $dxchan->{priv} = 0;
 166                 my @in = (DXCommandmode::run_cmd($dxchan, "$self->{localcmd} $key"));
 167                 $dxchan->{priv} = $oldpriv;
 168                 delete $dxchan->{remotecmd};
 169                 return @in ? join("\n", @in) : undef;
 170         } elsif ($self->{db}) {
 171                 my $s = $self->{db}->get($key, $value);
 172                 return $s ? undef : $value;
 173         }
 174         return undef;
 175 }
 176
 177 # put a value to the database
 178 sub putkey
 179 {
 180         my $self = shift;
 181         my $key = uc shift;
 182         my $value = shift;
 183
 184         # make sure we are open
 185         $self->open;
 186         if ($self->{db}) {
 187                 my $s = $self->{db}->put($key, $value);
 188                 return $s ? undef : 1;
 189         }
 190         return undef;
 191 }
 192
 193 # create a new database params: <name> [<remote node call>]
 194 sub new
 195 {
 196         my $self = bless {};
 197         my $name = shift;
 198         my $remote = shift;
 199         my $chain = shift;
 200         my $cmd = shift;
 201
 202         $self->{name} = lc $name;
 203         $self->{remote} = uc $remote if $remote;
 204         $self->{chain} = $chain if $chain && ref $chain;
 205         $self->{accesst} = $self->{createt} = $self->{lastt} = $main::systime;
 206         $self->{localcmd} = lc $cmd if $cmd;
 207
 208         $avail{$self->{name}} = $self;
 209         mkdir $dbbase, 02775 unless -e $dbbase;
 210         save();
 211         return $self;
 212 }
 213
 214 # delete a database
 215 sub delete
 216 {
 217         my $self = shift;
 218         $self->close;
 219         unlink "$dbbase/$self->{name}";
 220         delete $avail{$self->{name}};
 221         save();
 222 }
 223
 224 #
 225 # process intermediate lines for an update
 226 # NOTE THAT THIS WILL BE CALLED FROM DXCommandmode and the
 227 # object will be a DXChannel (actually DXCommandmode)
 228 #
 229 sub normal
 230 {
 231
 232 }
 233
 234 #
 235 # periodic maintenance
 236 #
 237 # just close any things that haven't been accessed for the default
 238 # time
 239 #
 240 #
 241 sub process
 242 {
 243         if ($main::systime - $lastprocesstime >= 60) {
 244                 if (%avail) {
 245                         for (values %avail) {
 246                                 if ($main::systime - $_->{accesst} > $opentime) {
 247                                         $_->close;
 248                                 }
 249                         }
 250                 }
 251                 $lastprocesstime = $main::systime;
 252         }
 253 }
 254
 255 sub handle_37
 256 {
 257
 258 }
 259
 260 sub handle_44
 261 {
 262         my $self = shift;
 263
 264         # incoming DB Request
 265         my @in = DXCommandmode::run_cmd($self, "dbshow $_[4] $_[5]");
 266         sendremote($self, $_[2], $_[3], @in);
 267 }
 268
 269 sub handle_45
 270 {
 271         my $self = shift;
 272
 273         # incoming DB Information
 274         my $n = getstream($_[3]);
 275         if ($n) {
 276                 my $mchan = DXChannel->get($n->{call});
 277                 $mchan->send($_[2] . ":$_[4]") if $mchan;
 278         }
 279 }
 280
 281 sub handle_46
 282 {
 283         my $self = shift;
 284
 285         # incoming DB Complete
 286         delstream($_[3]);
 287 }
 288
 289 sub handle_47
 290 {
 291 }
 292
 293 sub handle_48
 294 {
 295 }
 296
 297 # send back a trache of data to the remote
 298 # remember $dxchan is a dxchannel
 299 sub sendremote
 300 {
 301         my $dxchan = shift;
 302         my $tonode = shift;
 303         my $stream = shift;
 304
 305         for (@_) {
 306                 $dxchan->send(DXProt::pc45($main::mycall, $tonode, $stream, $_));
 307         }
 308         $dxchan->send(DXProt::pc46($main::mycall, $tonode, $stream));
 309 }
 310
 311 # print a value from the db reference
 312 sub print
 313 {
 314         my $self = shift;
 315         my $s = shift;
 316         return $self->{$s} ? $self->{$s} : undef;
 317 }
 318
 319 # various access routines
 320
 321 #
 322 # return a list of valid elements
 323 #
 324
 325 sub fields
 326 {
 327         return keys(%valid);
 328 }
 329
 330 #
 331 # return a prompt for a field
 332 #
 333
 334 sub field_prompt
 335 {
 336         my ($self, $ele) = @_;
 337         return $valid{$ele};
 338 }
 339
 340 #no strict;
 341 sub AUTOLOAD
 342 {
 343         no strict;
 344         my $name = $AUTOLOAD;
 345         return if $name =~ /::DESTROY$/;
 346         $name =~ s/^.*:://o;
 347
 348         confess "Non-existant field '$AUTOLOAD'" if !$valid{$name};
 349         # this clever line of code creates a subroutine which takes over from autoload
 350         # from OO Perl - Conway
 351         *$AUTOLOAD = sub {@_ > 1 ? $_[0]->{$name} = $_[1] : $_[0]->{$name}};
 352         goto &$AUTOLOAD;
 353 }
 354
 355 1;