summaryrefslogtreecommitdiff
path: root/torrus/perllib/Torrus/DB.pm
diff options
context:
space:
mode:
Diffstat (limited to 'torrus/perllib/Torrus/DB.pm')
-rw-r--r--torrus/perllib/Torrus/DB.pm703
1 files changed, 703 insertions, 0 deletions
diff --git a/torrus/perllib/Torrus/DB.pm b/torrus/perllib/Torrus/DB.pm
new file mode 100644
index 000000000..4d600f966
--- /dev/null
+++ b/torrus/perllib/Torrus/DB.pm
@@ -0,0 +1,703 @@
+# Copyright (C) 2002 Stanislav Sinyagin
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA.
+
+# $Id: DB.pm,v 1.1 2010-12-27 00:03:39 ivan Exp $
+# Stanislav Sinyagin <ssinyagin@yahoo.com>
+
+package Torrus::DB;
+
+use Torrus::Log;
+use BerkeleyDB;
+use strict;
+
+
+# This is an abstraction layer for BerkeleyDB database operations
+#
+# Database opening:
+# my $db = new Torrus::DB('db_name',
+# [ -Btree => 1, ]
+# [ -WriteAccess => 1, ]
+# [ -Truncate => 1, ]
+# [ -Subdir => 'dirname' ]);
+# Defaults: Hash, read-only, no truncate.
+#
+# Database closing:
+# undef $db;
+#
+# Database cleaning:
+# $status = $db->trunc();
+#
+
+END
+{
+ &Torrus::DB::cleanupEnvironment();
+}
+
+sub new
+{
+ my $self = {};
+ my $class = shift;
+ my $dbname = shift;
+ my %options = @_;
+ bless $self, $class;
+
+ if( not defined($Torrus::DB::env) )
+ {
+ if( not defined $Torrus::Global::dbHome )
+ {
+ Error('$Torrus::Global::dbHome must be defined ' .
+ 'in torrus_config.pl');
+ return undef;
+ }
+ elsif( not -d $Torrus::Global::dbHome )
+ {
+ Error("No such directory: $Torrus::Global::dbHome" );
+ return undef;
+ }
+ else
+ {
+ $Torrus::DB::dbEnvErrFile =
+ $Torrus::Global::logDir . '/dbenv_errlog_' . $$;
+
+ Debug("Creating BerkeleyDB::Env");
+ umask 0002;
+ $Torrus::DB::env =
+ new BerkeleyDB::Env(-Home => $Torrus::Global::dbHome,
+ -Flags => (DB_CREATE |
+ DB_INIT_CDB | DB_INIT_MPOOL),
+ -Mode => 0664,
+ -ErrFile => $Torrus::DB::dbEnvErrFile);
+ if( not defined($Torrus::DB::env) )
+ {
+ Error("Cannot create BerkeleyDB Environment: ".
+ $BerkeleyDB::Error);
+ return undef;
+ }
+ }
+ }
+
+ my $filename = $dbname.'.db';
+
+ if( $options{'-Subdir'} )
+ {
+ my $dirname = $Torrus::Global::dbHome . '/' . $Torrus::DB::dbSub;
+ if( not -d $dirname and not mkdir( $dirname ) )
+ {
+ Error("Cannot create directory $dirname: $!");
+ return undef;
+ }
+ $dirname .= '/' . $options{'-Subdir'};
+ if( not -d $dirname and not mkdir( $dirname ) )
+ {
+ Error("Cannot create directory $dirname: $!");
+ return undef;
+ }
+ $filename =
+ $Torrus::DB::dbSub . '/' . $options{'-Subdir'} . '/' . $filename;
+ }
+
+ # we need this in DESTROY debug message
+ $self->{'dbname'} = $filename;
+
+ my %hash;
+
+ my $accmethod = $options{'-Btree'} ?
+ 'BerkeleyDB::Btree':'BerkeleyDB::Hash';
+
+ my $flags = DB_RDONLY;
+
+ if( $options{'-WriteAccess'} )
+ {
+ $flags = DB_CREATE;
+ }
+
+ my $property = 0;
+ if( $options{'-Duplicates'} )
+ {
+ $property = DB_DUP | DB_DUPSORT;
+ }
+
+ if( not exists( $Torrus::DB::dbPool{$filename} ) )
+ {
+ Debug('Opening ' . $self->{'dbname'});
+
+ my $dbh = new $accmethod (
+ -Filename => $filename,
+ -Flags => $flags,
+ -Property => $property,
+ -Mode => 0664,
+ -Env => $Torrus::DB::env );
+ if( not $dbh )
+ {
+ Error("Cannot open database $filename: $! $BerkeleyDB::Error");
+ return undef;
+ }
+
+ $Torrus::DB::dbPool{$filename} = { 'dbh' => $dbh,
+ 'accmethod' => $accmethod,
+ 'flags' => $flags };
+
+ $self->{'dbh'} = $dbh;
+ }
+ else
+ {
+ my $ref = $Torrus::DB::dbPool{$filename};
+ if( $ref->{'accmethod'} eq $accmethod and $ref->{'flags'} eq $flags )
+ {
+ $self->{'dbh'} = $ref->{'dbh'};
+ }
+ else
+ {
+ Error('Database in dbPool has different flags: ' .
+ $self->{'dbname'});
+ return undef;
+ }
+ }
+
+ if( $options{'-Truncate'} )
+ {
+ $self->trunc();
+ }
+
+ if( $options{'-Delayed'} )
+ {
+ $self->{'delay_list_commit'} = 1;
+ }
+
+ return $self;
+}
+
+
+# It is strongly inadvisable to do anything inside a signal handler when DB
+# operation is in progress
+
+our $interrupted = 0;
+
+my $signalHandlersSet = 0;
+my $safeSignals = 0;
+
+
+
+
+
+sub setSignalHandlers
+{
+ if( $signalHandlersSet )
+ {
+ return;
+ }
+
+ $SIG{'TERM'} = sub {
+ if( $safeSignals )
+ {
+ Warn('Received SIGTERM. Scheduling to exit.');
+ $interrupted = 1;
+ }
+ else
+ {
+ Warn('Received SIGTERM. Stopping the process.');
+ exit(1);
+ }
+ };
+
+ $SIG{'INT'} = sub {
+ if( $safeSignals )
+ {
+ Warn('Received SIGINT. Scheduling to exit.');
+ $interrupted = 1;
+ }
+ else
+ {
+ Warn('Received SIGINT. Stopping the process');
+ exit(1);
+ }
+ };
+
+
+ $SIG{'PIPE'} = sub {
+ if( $safeSignals )
+ {
+ Warn('Received SIGPIPE. Scheduling to exit.');
+ $interrupted = 1;
+ }
+ else
+ {
+ Warn('Received SIGPIPE. Stopping the process');
+ exit(1);
+ }
+ };
+
+ $SIG{'QUIT'} = sub {
+ if( $safeSignals )
+ {
+ Warn('Received SIGQUIT. Scheduling to exit.');
+ $interrupted = 1;
+ }
+ else
+ {
+ Warn('Received SIGQUIT. Stopping the process');
+ exit(1);
+ }
+ };
+
+ $signalHandlersSet = 1;
+}
+
+
+sub setSafeSignalHandlers
+{
+ setSignalHandlers();
+ $safeSignals = 1;
+}
+
+
+sub setUnsafeSignalHandlers
+{
+ setSignalHandlers();
+ $safeSignals = 0;
+}
+
+
+# If we were previously interrupted, gracefully exit now
+
+sub checkInterrupted
+{
+ if( $interrupted )
+ {
+ Warn('Stopping the process');
+ exit(1);
+ }
+}
+
+
+
+sub closeNow
+{
+ my $self = shift;
+
+ my $filename = $self->{'dbname'};
+ Debug('Explicitly closing ' . $filename);
+ delete $Torrus::DB::dbPool{$filename};
+ $self->{'dbh'}->db_close();
+ delete $self->{'dbh'};
+}
+
+sub cleanupEnvironment
+{
+ if( defined( $Torrus::DB::env ) )
+ {
+ foreach my $filename ( sort keys %Torrus::DB::dbPool )
+ {
+ Debug('Closing ' . $filename);
+ $Torrus::DB::dbPool{$filename}->{'dbh'}->db_close();
+ delete $Torrus::DB::dbPool{$filename};
+ }
+
+ Debug("Destroying BerkeleyDB::Env");
+ $Torrus::DB::env->close();
+ $Torrus::DB::env = undef;
+
+ if( -z $Torrus::DB::dbEnvErrFile )
+ {
+ unlink $Torrus::DB::dbEnvErrFile;
+ }
+ }
+}
+
+
+sub delay
+{
+ my $self = shift;
+ $self->{'delay_list_commit'} = 1;
+}
+
+
+
+sub trunc
+{
+ my $self = shift;
+
+ Debug('Truncating ' . $self->{'dbname'});
+ my $count = 0;
+ return $self->{'dbh'}->truncate($count) == 0;
+}
+
+
+sub put
+{
+ my $self = shift;
+ my $key = shift;
+ my $val = shift;
+
+ ref( $self->{'dbh'} ) or die( 'Fatal error: ' . $self->{'dbname'} );
+ return $self->{'dbh'}->db_put($key, $val) == 0;
+}
+
+sub get
+{
+ my $self = shift;
+ my $key = shift;
+ my $val = undef;
+
+ $self->{'dbh'}->db_get($key, $val);
+ return $val;
+}
+
+
+sub del
+{
+ my $self = shift;
+ my $key = shift;
+ my $val = undef;
+
+ return $self->{'dbh'}->db_del($key) == 0;
+}
+
+
+sub cursor
+{
+ my $self = shift;
+ my %options = @_;
+
+ return $self->{'dbh'}->db_cursor( $options{'-Write'} ? DB_WRITECURSOR:0 );
+}
+
+
+sub next
+{
+ my $self = shift;
+ my $cursor = shift;
+ my $key = '';
+ my $val = '';
+
+ if( $cursor->c_get($key, $val, DB_NEXT) == 0 )
+ {
+ return ($key, $val);
+ }
+ else
+ {
+ return ();
+ }
+}
+
+sub c_del
+{
+ my $self = shift;
+ my $cursor = shift;
+
+ my $cnt = 0;
+ $cursor->c_del( $cnt );
+}
+
+
+sub c_get
+{
+ my $self = shift;
+ my $cursor = shift;
+ my $key = shift;
+ my $val = undef;
+
+ if( $cursor->c_get( $key, $val, DB_SET ) == 0 )
+ {
+ return $val;
+ }
+ else
+ {
+ return undef;
+ }
+}
+
+sub c_put
+{
+ my $self = shift;
+ my $cursor = shift;
+ my $key = shift;
+ my $val = shift;
+
+ return ( $cursor->c_put( $key, $val, DB_KEYFIRST ) == 0 );
+}
+
+
+
+# Btree best match. We assume that the searchKey is longer or equal
+# than the matched key in the database.
+#
+# If none found, returns undef.
+# If found, returns a hash with keys
+# "exact" => true when exact match found
+# "key" => key as is stored in the database
+# "value" => value from the matched database entry
+# The found key is shorter or equal than searchKey, and is a prefix
+# of the searchKey
+
+sub getBestMatch
+{
+ my $self = shift;
+ my $searchKey = shift;
+
+ my $key = $searchKey;
+ my $searchLen = length( $searchKey );
+ my $val = '';
+ my $ret = {};
+ my $ok = 0;
+
+ my $cursor = $self->{'dbh'}->db_cursor();
+
+ if( $cursor->c_get( $key, $val, DB_SET_RANGE ) == 0 )
+ {
+ if( $key eq $searchKey )
+ {
+ $ok = 1;
+ $ret->{'exact'} = 1;
+ }
+ else
+ {
+ # the returned key/data pair is the smallest data item greater
+ # than or equal to the specified data item.
+ # The previous entry should be what we search for.
+ if( $cursor->c_get( $key, $val, DB_PREV ) == 0 )
+ {
+ if( length( $key ) < $searchLen and
+ index( $searchKey, $key ) == 0 )
+ {
+ $ok = 1;
+ $ret->{'key'} = $key;
+ $ret->{'value'} = $val;
+ }
+ }
+ }
+ }
+ else
+ {
+ if ( $cursor->c_get( $key, $val, DB_LAST ) == 0 )
+ {
+ if( length( $key ) < $searchLen and
+ index( $searchKey, $key ) == 0 )
+ {
+ $ok = 1;
+ $ret->{'key'} = $key;
+ $ret->{'value'} = $val;
+ }
+ }
+ }
+
+ return( $ok ? $ret : undef );
+}
+
+
+# Search the keys that match the specified prefix.
+# Return value is an array of [key,val] pairs or undef
+# Returned keys may be duplicated if the DB is created with -Duplicates
+
+sub searchPrefix
+{
+ my $self = shift;
+ my $prefix = shift;
+
+ my $ret = [];
+ my $ok = 0;
+
+ my $key = $prefix;
+ my $val = '';
+
+ my $cursor = $self->{'dbh'}->db_cursor();
+
+ if( $cursor->c_get( $key, $val, DB_SET_RANGE ) == 0 )
+ {
+ # the returned key/data pair is the smallest data item greater
+ # than or equal to the specified data item.
+ my $finished = 0;
+ while( not $finished )
+ {
+ if( index( $key, $prefix ) == 0 )
+ {
+ $ok = 1;
+ push( @{$ret}, [ $key, $val ] );
+
+ if( $cursor->c_get($key, $val, DB_NEXT) != 0 )
+ {
+ $finished = 1;
+ }
+ }
+ else
+ {
+ $finished = 1;
+ }
+ }
+ }
+
+ undef $cursor;
+
+ return( $ok ? $ret : undef );
+}
+
+
+# Search the keys that match the specified substring.
+# Return value is an array of [key,val] pairs or undef
+# Returned keys may be duplicated if the DB is created with -Duplicates
+
+sub searchSubstring
+{
+ my $self = shift;
+ my $substring = shift;
+
+ my $ret = [];
+ my $ok = 0;
+
+ my $key = '';
+ my $val = '';
+
+ my $cursor = $self->{'dbh'}->db_cursor();
+
+ while( $cursor->c_get($key, $val, DB_NEXT) == 0 )
+ {
+ if( index( $key, $substring ) >= 0 )
+ {
+ $ok = 1;
+ push( @{$ret}, [ $key, $val ] );
+ }
+ }
+
+ undef $cursor;
+
+ return( $ok ? $ret : undef );
+}
+
+
+
+
+
+# Comma-separated list manipulation
+
+sub _populateListCache
+{
+ my $self = shift;
+ my $key = shift;
+
+ if( not exists( $self->{'listcache'}{$key} ) )
+ {
+ my $ref = {};
+ my $values = $self->get($key);
+ if( defined( $values ) )
+ {
+ foreach my $val (split(/,/o, $values))
+ {
+ $ref->{$val} = 1;
+ }
+ }
+ $self->{'listcache'}{$key} = $ref;
+ }
+}
+
+
+sub _storeListCache
+{
+ my $self = shift;
+ my $key = shift;
+
+ if( not $self->{'delay_list_commit'} )
+ {
+ $self->put($key, join(',', keys %{$self->{'listcache'}{$key}}));
+ }
+}
+
+
+sub addToList
+{
+ my $self = shift;
+ my $key = shift;
+ my $newval = shift;
+
+ $self->_populateListCache($key);
+
+ $self->{'listcache'}{$key}{$newval} = 1;
+
+ $self->_storeListCache($key);
+}
+
+
+sub searchList
+{
+ my $self = shift;
+ my $key = shift;
+ my $name = shift;
+
+ $self->_populateListCache($key);
+ return $self->{'listcache'}{$key}{$name};
+}
+
+
+sub delFromList
+{
+ my $self = shift;
+ my $key = shift;
+ my $name = shift;
+
+ $self->_populateListCache($key);
+ if( $self->{'listcache'}{$key}{$name} )
+ {
+ delete $self->{'listcache'}{$key}{$name};
+ }
+
+ $self->_storeListCache($key);
+}
+
+
+sub getListItems
+{
+ my $self = shift;
+ my $key = shift;
+
+ $self->_populateListCache($key);
+ return keys %{$self->{'listcache'}{$key}};
+}
+
+
+
+sub deleteList
+{
+ my $self = shift;
+ my $key = shift;
+
+ delete $self->{'listcache'}{$key};
+ $self->del($key);
+}
+
+
+sub commit
+{
+ my $self = shift;
+
+ if( $self->{'delay_list_commit'} and
+ defined( $self->{'listcache'} ) )
+ {
+ while( my($key, $list) = each %{$self->{'listcache'}} )
+ {
+ $self->put($key, join(',', keys %{$list}));
+ }
+ }
+}
+
+
+
+1;
+
+
+# Local Variables:
+# mode: perl
+# indent-tabs-mode: nil
+# perl-indent-level: 4
+# End:
generated by cgit v1.2.1 (git 2.18.0) at 2025-06-14 16:20:59 +0000