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 # allocate a new stream for this request
  52 sub newstream
  53 {
  54         my $call = uc shift;
  55         my $n = ++$nextstream;
  56         $stream{$n} = { n=>$n, call=>$call, t=>$main::systime };
  57         return $n;
  58 }
  59
  60 # delete a stream
  61 sub delstream
  62 {
  63         my $n = shift;
  64         delete $stream{$n};
  65 }
  66
  67 # get a stream
  68 sub getstream
  69 {
  70         my $n = shift;
  71         return $stream{$n};
  72 }
  73
  74 # load all the database descriptors
  75 sub load
  76 {
  77         my $s = readfilestr($dbbase, "dbs", "pl");
  78         if ($s) {
  79                 my $a;
  80                 eval "\$a = $s";
  81                 confess $@ if $@;
  82                 %avail = ( %$a ) if ref $a;
  83         }
  84 }
  85
  86 # save all the database descriptors
  87 sub save
  88 {
  89         closeall();
  90         writefilestr($dbbase, "dbs", "pl", \%avail);
  91 }
  92
  93 # get the descriptor of the database you want.
  94 sub getdesc
  95 {
  96         return undef unless %avail;
  97
  98         my $name = lc shift;
  99         my $r = $avail{$name};
 100
 101         # search for a partial if not found direct
 102         unless ($r) {
 103                 for (sort { $a->{name} cmp $b->{name} }values %avail) {
 104                         if ($_->{name} =~ /^$name/) {
 105                                 $r = $_;
 106                                 last;
 107                         }
 108                 }
 109         }
 110         return $r;
 111 }
 112
 113 # open it
 114 sub open
 115 {
 116         my $self = shift;
 117         $self->{accesst} = $main::systime;
 118         return $self->{db} if $self->{db};
 119         my %hash;
 120         $self->{db} = tie %hash, 'DB_File', "$dbbase/$self->{name}";
 121 #       untie %hash;
 122         return $self->{db};
 123 }
 124
 125 # close it
 126 sub close
 127 {
 128         my $self = shift;
 129         if ($self->{db}) {
 130                 undef $self->{db};
 131                 delete $self->{db};
 132         }
 133 }
 134
 135 # close all
 136 sub closeall
 137 {
 138         if (%avail) {
 139                 for (values %avail) {
 140                         $_->close();
 141                 }
 142         }
 143 }
 144
 145 # get a value from the database
 146 sub getkey
 147 {
 148         my $self = shift;
 149         my $key = uc shift;
 150         my $value;
 151
 152         # make sure we are open
 153         $self->open;
 154         if ($self->{db}) {
 155                 my $s = $self->{db}->get($key, $value);
 156                 return $s ? undef : $value;
 157         }
 158         return undef;
 159 }
 160
 161 # put a value to the database
 162 sub putkey
 163 {
 164         my $self = shift;
 165         my $key = uc shift;
 166         my $value = shift;
 167
 168         # make sure we are open
 169         $self->open;
 170         if ($self->{db}) {
 171                 my $s = $self->{db}->put($key, $value);
 172                 return $s ? undef : 1;
 173         }
 174         return undef;
 175 }
 176
 177 # create a new database params: <name> [<remote node call>]
 178 sub new
 179 {
 180         my $self = bless {};
 181         my $name = shift;
 182         my $remote = shift;
 183         my $chain = shift;
 184         $self->{name} = lc $name;
 185         $self->{remote} = uc $remote if $remote;
 186         $self->{chain} = $chain if $chain && ref $chain;
 187         $self->{accesst} = $self->{createt} = $self->{lastt} = $main::systime;
 188         $avail{$self->{name}} = $self;
 189         mkdir $dbbase, 02775 unless -e $dbbase;
 190         save();
 191 }
 192
 193 # delete a database
 194 sub delete
 195 {
 196         my $self = shift;
 197         $self->close;
 198         unlink "$dbbase/$self->{name}";
 199         delete $avail{$self->{name}};
 200         save();
 201 }
 202
 203 #
 204 # process intermediate lines for an update
 205 # NOTE THAT THIS WILL BE CALLED FROM DXCommandmode and the
 206 # object will be a DXChannel (actually DXCommandmode)
 207 #
 208 sub normal
 209 {
 210
 211 }
 212
 213 #
 214 # periodic maintenance
 215 #
 216 # just close any things that haven't been accessed for the default
 217 # time
 218 #
 219 #
 220 sub process
 221 {
 222         my ($dxchan, $line) = @_;
 223
 224         # this is periodic processing
 225         if (!$dxchan || !$line) {
 226                 if ($main::systime - $lastprocesstime >= 60) {
 227                         if (%avail) {
 228                                 for (values %avail) {
 229                                         if ($main::systime - $_->{accesst} > $opentime) {
 230                                                 $_->close;
 231                                         }
 232                                 }
 233                         }
 234                         $lastprocesstime = $main::systime;
 235                 }
 236                 return;
 237         }
 238
 239         my @f = split /\^/, $line;
 240         my ($pcno) = $f[0] =~ /^PC(\d\d)/; # just get the number
 241
 242         # route out ones that are not for us
 243         if ($f[1] eq $main::mycall) {
 244                 ;
 245         } else {
 246                 $dxchan->route($f[1], $line);
 247                 return;
 248         }
 249
 250  SWITCH: {
 251                 if ($pcno == 37) {              # probably obsolete
 252                         last SWITCH;
 253                 }
 254
 255                 if ($pcno == 44) {              # incoming DB Request
 256                         my $db = getdesc($f[4]);
 257                         if ($db) {
 258                                 if ($db->{remote}) {
 259                                         sendremote($dxchan, $f[2], $f[3], $dxchan->msg('dx1', $db->{remote}));
 260                                 } else {
 261                                         my $value = $db->getkey($f[5]);
 262                                         if ($value) {
 263                                                 my @out = split /\n/, $value;
 264                                                 sendremote($dxchan, $f[2], $f[3], @out);
 265                                         } else {
 266                                                 sendremote($dxchan, $f[2], $f[3], $dxchan->msg('dx2', $f[5], $db->{name}));
 267                                         }
 268                                 }
 269                         } else {
 270                                 sendremote($dxchan, $f[2], $f[3], $dxchan->msg('dx3', $f[4]));
 271                         }
 272                         last SWITCH;
 273                 }
 274
 275                 if ($pcno == 45) {              # incoming DB Information
 276                         my $n = getstream($f[3]);
 277                         if ($n) {
 278                                 my $mchan = DXChannel->get($n->{call});
 279                                 $mchan->send($f[2] . ":$f[4]") if $mchan;
 280                         }
 281                         last SWITCH;
 282                 }
 283
 284                 if ($pcno == 46) {              # incoming DB Complete
 285                         delstream($f[3]);
 286                         last SWITCH;
 287                 }
 288
 289                 if ($pcno == 47) {              # incoming DB Update request
 290                         last SWITCH;
 291                 }
 292
 293                 if ($pcno == 48) {              # incoming DB Update request
 294                         last SWITCH;
 295                 }
 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         my $self = shift;
 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         @_ ? $self->{$name} = shift : $self->{$name} ;
 355 }
 356
 357 1;