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