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;
  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 }
 198
 199 # delete a database
 200 sub delete
 201 {
 202         my $self = shift;
 203         $self->close;
 204         unlink "$dbbase/$self->{name}";
 205         delete $avail{$self->{name}};
 206         save();
 207 }
 208
 209 #
 210 # process intermediate lines for an update
 211 # NOTE THAT THIS WILL BE CALLED FROM DXCommandmode and the
 212 # object will be a DXChannel (actually DXCommandmode)
 213 #
 214 sub normal
 215 {
 216
 217 }
 218
 219 #
 220 # periodic maintenance
 221 #
 222 # just close any things that haven't been accessed for the default
 223 # time
 224 #
 225 #
 226 sub process
 227 {
 228         my ($dxchan, $line) = @_;
 229
 230         # this is periodic processing
 231         if (!$dxchan || !$line) {
 232                 if ($main::systime - $lastprocesstime >= 60) {
 233                         if (%avail) {
 234                                 for (values %avail) {
 235                                         if ($main::systime - $_->{accesst} > $opentime) {
 236                                                 $_->close;
 237                                         }
 238                                 }
 239                         }
 240                         $lastprocesstime = $main::systime;
 241                 }
 242                 return;
 243         }
 244
 245         my @f = split /\^/, $line;
 246         my ($pcno) = $f[0] =~ /^PC(\d\d)/; # just get the number
 247
 248         # route out ones that are not for us
 249         if ($f[1] eq $main::mycall) {
 250                 ;
 251         } else {
 252                 $dxchan->route($f[1], $line);
 253                 return;
 254         }
 255
 256  SWITCH: {
 257                 if ($pcno == 37) {              # probably obsolete
 258                         last SWITCH;
 259                 }
 260
 261                 if ($pcno == 44) {              # incoming DB Request
 262                         my $db = getdesc($f[4]);
 263                         if ($db) {
 264                                 if ($db->{remote}) {
 265                                         sendremote($dxchan, $f[2], $f[3], $dxchan->msg('dx1', $db->{remote}));
 266                                 } else {
 267                                         my $value = $db->getkey($f[5]);
 268                                         if ($value) {
 269                                                 my @out = split /\n/, $value;
 270                                                 sendremote($dxchan, $f[2], $f[3], @out);
 271                                         } else {
 272                                                 sendremote($dxchan, $f[2], $f[3], $dxchan->msg('dx2', $f[5], $db->{name}));
 273                                         }
 274                                 }
 275                         } else {
 276                                 sendremote($dxchan, $f[2], $f[3], $dxchan->msg('dx3', $f[4]));
 277                         }
 278                         last SWITCH;
 279                 }
 280
 281                 if ($pcno == 45) {              # incoming DB Information
 282                         my $n = getstream($f[3]);
 283                         if ($n) {
 284                                 my $mchan = DXChannel->get($n->{call});
 285                                 $mchan->send($f[2] . ":$f[4]") if $mchan;
 286                         }
 287                         last SWITCH;
 288                 }
 289
 290                 if ($pcno == 46) {              # incoming DB Complete
 291                         delstream($f[3]);
 292                         last SWITCH;
 293                 }
 294
 295                 if ($pcno == 47) {              # incoming DB Update request
 296                         last SWITCH;
 297                 }
 298
 299                 if ($pcno == 48) {              # incoming DB Update request
 300                         last SWITCH;
 301                 }
 302         }
 303 }
 304
 305 # send back a trache of data to the remote
 306 # remember $dxchan is a dxchannel
 307 sub sendremote
 308 {
 309         my $dxchan = shift;
 310         my $tonode = shift;
 311         my $stream = shift;
 312
 313         for (@_) {
 314                 $dxchan->send(DXProt::pc45($main::mycall, $tonode, $stream, $_));
 315         }
 316         $dxchan->send(DXProt::pc46($main::mycall, $tonode, $stream));
 317 }
 318
 319 # print a value from the db reference
 320 sub print
 321 {
 322         my $self = shift;
 323         my $s = shift;
 324         return $self->{$s} ? $self->{$s} : undef;
 325 }
 326
 327 # various access routines
 328
 329 #
 330 # return a list of valid elements
 331 #
 332
 333 sub fields
 334 {
 335         return keys(%valid);
 336 }
 337
 338 #
 339 # return a prompt for a field
 340 #
 341
 342 sub field_prompt
 343 {
 344         my ($self, $ele) = @_;
 345         return $valid{$ele};
 346 }
 347
 348 no strict;
 349 sub AUTOLOAD
 350 {
 351         my $self = shift;
 352         my $name = $AUTOLOAD;
 353         return if $name =~ /::DESTROY$/;
 354         $name =~ s/.*:://o;
 355
 356         confess "Non-existant field '$AUTOLOAD'" if !$valid{$name};
 357         # this clever line of code creates a subroutine which takes over from autoload
 358         # from OO Perl - Conway
 359         *{$AUTOLOAD} = sub {@_ > 1 ? $_[0]->{$name} = $_[1] : $_[0]->{$name}} ;
 360         @_ ? $self->{$name} = shift : $self->{$name} ;
 361 }
 362
 363 1;