add localqsl a la golist thing

[spider.git] / perl / DXDb.pm

diff --git a/perl/DXDb.pm b/perl/DXDb.pm
index 49da69c9804b729aad3cd04c87e7a4165397c395..f54d6f14ff02b882fbefdd26cf21bbcab0fa1f4b 100644 (file)
--- a/perl/DXDb.pm
+++ b/perl/DXDb.pm
@@ -12,8 +12,7 @@ use DXVars;
 use DXLog;
 use DXUtil;
 use DB_File;
-
-use Carp;
+use DXDebug;
 
 use vars qw($opentime $dbbase %avail %valid $lastprocesstime $nextstream %stream);
 
@@ -21,18 +20,40 @@ $opentime = 5*60;                           # length of time a database stays open after last access
 $dbbase = "$main::root/db";            # where all the databases are kept;
 %avail = ();                                   # The hash contains a list of all the databases
 %valid = (
-                 accesst => '9,Last Access Time,atime',
+                 accesst => '9,Last Accs Time,atime',
                  createt => '9,Create Time,atime',
-                 lastt => '9,Last Update Time,atime',
+                 lastt => '9,Last Upd Time,atime',
                  name => '0,Name',
                  db => '9,DB Tied hash',
                  remote => '0,Remote Database',
+                 pre => '0,Heading txt',
+                 post => '0,Tail txt',
+                 chain => '0,Search these,parray',
+                 disable => '0,Disabled?,yesno',
+                 nf => '0,Not Found txt',
+                 cal => '0,No Key txt',
+                 allowread => '9,Allowed read,parray',
+                 denyread => '9,Deny read,parray',
+                 allowupd => '9,Allow upd,parray',
+                 denyupd => '9,Deny upd,parray',
+                 fwdupd => '9,Forw upd to,parray',
+                 template => '9,Upd Templates,parray',
+                 te => '9,End Upd txt',
+                 tae => '9,End App txt',
+                 atemplate => '9,App Templates,parray',
+                 help => '0,Help txt,parray',
                 );
 
 $lastprocesstime = time;
 $nextstream = 0;
 %stream = ();
 
+use vars qw($VERSION $BRANCH);
+$VERSION = sprintf( "%d.%03d", q$Revision$ =~ /(\d+)\.(\d+)/ );
+$BRANCH = sprintf( "%d.%03d", q$Revision$ =~ /\d+\.\d+\.(\d+)\.(\d+)/  || (0,0));
+$main::build += $VERSION;
+$main::branch += $BRANCH;
+
 # allocate a new stream for this request
 sub newstream
 {
@@ -61,18 +82,18 @@ sub load
 {
        my $s = readfilestr($dbbase, "dbs", "pl");
        if ($s) {
-               my $a = { eval $s } ;
+               my $a;
+               eval "\$a = $s";
                confess $@ if $@;
-               %avail = %{$a} if $a
+               %avail = ( %$a ) if ref $a;
        }
 }
 
 # save all the database descriptors
 sub save
 {
-       my $date = cldatetime($main::systime);
-       
-       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");
+       closeall();
+       writefilestr($dbbase, "dbs", "pl", \%avail);
 }
 
 # get the descriptor of the database you want.
@@ -85,7 +106,7 @@ sub getdesc
 
        # search for a partial if not found direct
        unless ($r) {
-               for (values %avail) {
+               for (sort { $a->{name} cmp $b->{name} }values %avail) {
                        if ($_->{name} =~ /^$name/) {
                                $r = $_;
                                last;
@@ -112,7 +133,8 @@ sub close
 {
        my $self = shift;
        if ($self->{db}) {
-               untie $self->{db};
+               undef $self->{db};
+               delete $self->{db};
        }
 }
 
@@ -164,12 +186,15 @@ sub new
        my $self = bless {};
        my $name = shift;
        my $remote = shift;
+       my $chain = shift;
        $self->{name} = lc $name;
        $self->{remote} = uc $remote if $remote;
+       $self->{chain} = $chain if $chain && ref $chain;
        $self->{accesst} = $self->{createt} = $self->{lastt} = $main::systime;
        $avail{$self->{name}} = $self;
        mkdir $dbbase, 02775 unless -e $dbbase;
        save();
+       return $self;
 }
 
 # delete a database
@@ -238,18 +263,18 @@ sub process
                        my $db = getdesc($f[4]);
                        if ($db) {
                                if ($db->{remote}) {
-                                       sendremote($dxchan, $f[2], $f[3], $dxchan->msg('dx1', $db->{remote}));
+                                       sendremote($dxchan, $f[2], $f[3], $dxchan->msg('db1', $db->{remote}));
                                } else {
                                        my $value = $db->getkey($f[5]);
                                        if ($value) {
                                                my @out = split /\n/, $value;
                                                sendremote($dxchan, $f[2], $f[3], @out);
                                        } else {
-                                               sendremote($dxchan, $f[2], $f[3], $dxchan->msg('dx2', $f[5], $db->{name}));
+                                               sendremote($dxchan, $f[2], $f[3], $dxchan->msg('db2', $f[5], $db->{name}));
                                        }
                                }
                        } else {
-                               sendremote($dxchan, $f[2], $f[3], $dxchan->msg('dx3', $f[4]));
+                               sendremote($dxchan, $f[2], $f[3], $dxchan->msg('db3', $f[4]));
                        }
                        last SWITCH;
                }
@@ -258,7 +283,7 @@ sub process
                        my $n = getstream($f[3]);
                        if ($n) {
                                my $mchan = DXChannel->get($n->{call});
-                               $mchan->send($f[2] . ":$f[4]");
+                               $mchan->send($f[2] . ":$f[4]") if $mchan;
                        }
                        last SWITCH;
                }
@@ -292,6 +317,14 @@ sub sendremote
        $dxchan->send(DXProt::pc46($main::mycall, $tonode, $stream));
 }
 
+# print a value from the db reference
+sub print
+{
+       my $self = shift;
+       my $s = shift;
+       return $self->{$s} ? $self->{$s} : undef; 
+} 
+
 # various access routines
 
 #
@@ -313,16 +346,19 @@ sub field_prompt
        return $valid{$ele};
 }
 
-no strict;
+#no strict;
 sub AUTOLOAD
 {
-       my $self = shift;
+       no strict;
        my $name = $AUTOLOAD;
        return if $name =~ /::DESTROY$/;
-       $name =~ s/.*:://o;
+       $name =~ s/^.*:://o;
   
        confess "Non-existant field '$AUTOLOAD'" if !$valid{$name};
-       @_ ? $self->{$name} = shift : $self->{$name} ;
+       # this clever line of code creates a subroutine which takes over from autoload
+       # from OO Perl - Conway
+       *$AUTOLOAD = sub {@_ > 1 ? $_[0]->{$name} = $_[1] : $_[0]->{$name}};
+        goto &$AUTOLOAD;
 }
 
 1;