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