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                  );
  46
  47 $lastprocesstime = time;
  48 $nextstream = 0;
  49 %stream = ();
  50
  51 use vars qw($VERSION $BRANCH);
  52 $VERSION = sprintf( "%d.%03d", q$Revision$ =~ /(\d+)\.(\d+)/ );
  53 $BRANCH = sprintf( "%d.%03d", q$Revision$ =~ /\d+\.\d+\.(\d+)\.(\d+)/  || (0,0));
  54 $main::build += $VERSION;
  55 $main::branch += $BRANCH;
  56
  57 # allocate a new stream for this request
  58 sub newstream
  59 {
  60         my $call = uc shift;
  61         my $n = ++$nextstream;
  62         $stream{$n} = { n=>$n, call=>$call, t=>$main::systime };
  63         return $n;
  64 }
  65
  66 # delete a stream
  67 sub delstream
  68 {
  69         my $n = shift;
  70         delete $stream{$n};
  71 }
  72
  73 # get a stream
  74 sub getstream
  75 {
  76         my $n = shift;
  77         return $stream{$n};
  78 }
  79
  80 # load all the database descriptors
  81 sub load
  82 {
  83         my $s = readfilestr($dbbase, "dbs", "pl");
  84         if ($s) {
  85                 my $a;
  86                 eval "\$a = $s";
  87                 confess $@ if $@;
  88                 %avail = ( %$a ) if ref $a;
  89         }
  90 }
  91
  92 # save all the database descriptors
  93 sub save
  94 {
  95         closeall();
  96         writefilestr($dbbase, "dbs", "pl", \%avail);
  97 }
  98
  99 # get the descriptor of the database you want.
 100 sub getdesc
 101 {
 102         return undef unless %avail;
 103
 104         my $name = lc shift;
 105         my $r = $avail{$name};
 106
 107         # search for a partial if not found direct
 108         unless ($r) {
 109                 for (sort { $a->{name} cmp $b->{name} }values %avail) {
 110                         if ($_->{name} =~ /^$name/) {
 111                                 $r = $_;
 112                                 last;
 113                         }
 114                 }
 115         }
 116         return $r;
 117 }
 118
 119 # open it
 120 sub open
 121 {
 122         my $self = shift;
 123         $self->{accesst} = $main::systime;
 124         return $self->{db} if $self->{db};
 125         my %hash;
 126         $self->{db} = tie %hash, 'DB_File', "$dbbase/$self->{name}";
 127 #       untie %hash;
 128         return $self->{db};
 129 }
 130
 131 # close it
 132 sub close
 133 {
 134         my $self = shift;
 135         if ($self->{db}) {
 136                 undef $self->{db};
 137                 delete $self->{db};
 138         }
 139 }
 140
 141 # close all
 142 sub closeall
 143 {
 144         if (%avail) {
 145                 for (values %avail) {
 146                         $_->close();
 147                 }
 148         }
 149 }
 150
 151 # get a value from the database
 152 sub getkey
 153 {
 154         my $self = shift;
 155         my $key = uc shift;
 156         my $value;
 157
 158         # make sure we are open
 159         $self->open;
 160         if ($self->{db}) {
 161                 my $s = $self->{db}->get($key, $value);
 162                 return $s ? undef : $value;
 163         }
 164         return undef;
 165 }
 166
 167 # put a value to the database
 168 sub putkey
 169 {
 170         my $self = shift;
 171         my $key = uc shift;
 172         my $value = shift;
 173
 174         # make sure we are open
 175         $self->open;
 176         if ($self->{db}) {
 177                 my $s = $self->{db}->put($key, $value);
 178                 return $s ? undef : 1;
 179         }
 180         return undef;
 181 }
 182
 183 # create a new database params: <name> [<remote node call>]
 184 sub new
 185 {
 186         my $self = bless {};
 187         my $name = shift;
 188         my $remote = shift;
 189         my $chain = shift;
 190         $self->{name} = lc $name;
 191         $self->{remote} = uc $remote if $remote;
 192         $self->{chain} = $chain if $chain && ref $chain;
 193         $self->{accesst} = $self->{createt} = $self->{lastt} = $main::systime;
 194         $avail{$self->{name}} = $self;
 195         mkdir $dbbase, 02775 unless -e $dbbase;
 196         save();
 197         return $self;
 198 }
 199
 200 # delete a database
 201 sub delete
 202 {
 203         my $self = shift;
 204         $self->close;
 205         unlink "$dbbase/$self->{name}";
 206         delete $avail{$self->{name}};
 207         save();
 208 }
 209
 210 #
 211 # process intermediate lines for an update
 212 # NOTE THAT THIS WILL BE CALLED FROM DXCommandmode and the
 213 # object will be a DXChannel (actually DXCommandmode)
 214 #
 215 sub normal
 216 {
 217
 218 }
 219
 220 #
 221 # periodic maintenance
 222 #
 223 # just close any things that haven't been accessed for the default
 224 # time
 225 #
 226 #
 227 sub process
 228 {
 229         my ($dxchan, $line) = @_;
 230
 231         # this is periodic processing
 232         if (!$dxchan || !$line) {
 233                 if ($main::systime - $lastprocesstime >= 60) {
 234                         if (%avail) {
 235                                 for (values %avail) {
 236                                         if ($main::systime - $_->{accesst} > $opentime) {
 237                                                 $_->close;
 238                                         }
 239                                 }
 240                         }
 241                         $lastprocesstime = $main::systime;
 242                 }
 243                 return;
 244         }
 245
 246         my @f = split /\^/, $line;
 247         my ($pcno) = $f[0] =~ /^PC(\d\d)/; # just get the number
 248
 249         # route out ones that are not for us
 250         if ($f[1] eq $main::mycall) {
 251                 ;
 252         } else {
 253                 $dxchan->route($f[1], $line);
 254                 return;
 255         }
 256
 257  SWITCH: {
 258                 if ($pcno == 37) {              # probably obsolete
 259                         last SWITCH;
 260                 }
 261
 262                 if ($pcno == 44) {              # incoming DB Request
 263                         my $db = getdesc($f[4]);
 264                         if ($db) {
 265                                 if ($db->{remote}) {
 266                                         sendremote($dxchan, $f[2], $f[3], $dxchan->msg('db1', $db->{remote}));
 267                                 } else {
 268                                         my $value = $db->getkey($f[5]);
 269                                         if ($value) {
 270                                                 my @out = split /\n/, $value;
 271                                                 sendremote($dxchan, $f[2], $f[3], @out);
 272                                         } else {
 273                                                 sendremote($dxchan, $f[2], $f[3], $dxchan->msg('db2', $f[5], $db->{name}));
 274                                         }
 275                                 }
 276                         } else {
 277                                 sendremote($dxchan, $f[2], $f[3], $dxchan->msg('db3', $f[4]));
 278                         }
 279                         last SWITCH;
 280                 }
 281
 282                 if ($pcno == 45) {              # incoming DB Information
 283                         my $n = getstream($f[3]);
 284                         if ($n) {
 285                                 my $mchan = DXChannel->get($n->{call});
 286                                 $mchan->send($f[2] . ":$f[4]") if $mchan;
 287                         }
 288                         last SWITCH;
 289                 }
 290
 291                 if ($pcno == 46) {              # incoming DB Complete
 292                         delstream($f[3]);
 293                         last SWITCH;
 294                 }
 295
 296                 if ($pcno == 47) {              # incoming DB Update request
 297                         last SWITCH;
 298                 }
 299
 300                 if ($pcno == 48) {              # incoming DB Update request
 301                         last SWITCH;
 302                 }
 303         }
 304 }
 305
 306 # send back a trache of data to the remote
 307 # remember $dxchan is a dxchannel
 308 sub sendremote
 309 {
 310         my $dxchan = shift;
 311         my $tonode = shift;
 312         my $stream = shift;
 313
 314         for (@_) {
 315                 $dxchan->send(DXProt::pc45($main::mycall, $tonode, $stream, $_));
 316         }
 317         $dxchan->send(DXProt::pc46($main::mycall, $tonode, $stream));
 318 }
 319
 320 # print a value from the db reference
 321 sub print
 322 {
 323         my $self = shift;
 324         my $s = shift;
 325         return $self->{$s} ? $self->{$s} : undef;
 326 }
 327
 328 # various access routines
 329
 330 #
 331 # return a list of valid elements
 332 #
 333
 334 sub fields
 335 {
 336         return keys(%valid);
 337 }
 338
 339 #
 340 # return a prompt for a field
 341 #
 342
 343 sub field_prompt
 344 {
 345         my ($self, $ele) = @_;
 346         return $valid{$ele};
 347 }
 348
 349 #no strict;
 350 sub AUTOLOAD
 351 {
 352         no strict;
 353         my $name = $AUTOLOAD;
 354         return if $name =~ /::DESTROY$/;
 355         $name =~ s/^.*:://o;
 356
 357         confess "Non-existant field '$AUTOLOAD'" if !$valid{$name};
 358         # this clever line of code creates a subroutine which takes over from autoload
 359         # from OO Perl - Conway
 360         *$AUTOLOAD = sub {@_ > 1 ? $_[0]->{$name} = $_[1] : $_[0]->{$name}};
 361         goto &$AUTOLOAD;
 362 }
 363
 364 1;