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