1 # Copyright (C) 2002 Stanislav Sinyagin
3 # This program is free software; you can redistribute it and/or modify
4 # it under the terms of the GNU General Public License as published by
5 # the Free Software Foundation; either version 2 of the License, or
6 # (at your option) any later version.
8 # This program is distributed in the hope that it will be useful,
9 # but WITHOUT ANY WARRANTY; without even the implied warranty of
10 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
11 # GNU General Public License for more details.
13 # You should have received a copy of the GNU General Public License
14 # along with this program; if not, write to the Free Software
15 # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA.
17 # $Id: DB.pm,v 1.1 2010-12-27 00:03:39 ivan Exp $
18 # Stanislav Sinyagin <ssinyagin@yahoo.com>
27 # This is an abstraction layer for BerkeleyDB database operations
30 # my $db = new Torrus::DB('db_name',
32 # [ -WriteAccess => 1, ]
34 # [ -Subdir => 'dirname' ]);
35 # Defaults: Hash, read-only, no truncate.
41 # $status = $db->trunc();
46 &Torrus::DB::cleanupEnvironment();
57 if( not defined($Torrus::DB::env) )
59 if( not defined $Torrus::Global::dbHome )
61 Error('$Torrus::Global::dbHome must be defined ' .
62 'in torrus_config.pl');
65 elsif( not -d $Torrus::Global::dbHome )
67 Error("No such directory: $Torrus::Global::dbHome" );
72 $Torrus::DB::dbEnvErrFile =
73 $Torrus::Global::logDir . '/dbenv_errlog_' . $$;
75 Debug("Creating BerkeleyDB::Env");
78 new BerkeleyDB::Env(-Home => $Torrus::Global::dbHome,
79 -Flags => (DB_CREATE |
80 DB_INIT_CDB | DB_INIT_MPOOL),
82 -ErrFile => $Torrus::DB::dbEnvErrFile);
83 if( not defined($Torrus::DB::env) )
85 Error("Cannot create BerkeleyDB Environment: ".
92 my $filename = $dbname.'.db';
94 if( $options{'-Subdir'} )
96 my $dirname = $Torrus::Global::dbHome . '/' . $Torrus::DB::dbSub;
97 if( not -d $dirname and not mkdir( $dirname ) )
99 Error("Cannot create directory $dirname: $!");
102 $dirname .= '/' . $options{'-Subdir'};
103 if( not -d $dirname and not mkdir( $dirname ) )
105 Error("Cannot create directory $dirname: $!");
109 $Torrus::DB::dbSub . '/' . $options{'-Subdir'} . '/' . $filename;
112 # we need this in DESTROY debug message
113 $self->{'dbname'} = $filename;
117 my $accmethod = $options{'-Btree'} ?
118 'BerkeleyDB::Btree':'BerkeleyDB::Hash';
120 my $flags = DB_RDONLY;
122 if( $options{'-WriteAccess'} )
128 if( $options{'-Duplicates'} )
130 $property = DB_DUP | DB_DUPSORT;
133 if( not exists( $Torrus::DB::dbPool{$filename} ) )
135 Debug('Opening ' . $self->{'dbname'});
137 my $dbh = new $accmethod (
138 -Filename => $filename,
140 -Property => $property,
142 -Env => $Torrus::DB::env );
145 Error("Cannot open database $filename: $! $BerkeleyDB::Error");
149 $Torrus::DB::dbPool{$filename} = { 'dbh' => $dbh,
150 'accmethod' => $accmethod,
153 $self->{'dbh'} = $dbh;
157 my $ref = $Torrus::DB::dbPool{$filename};
158 if( $ref->{'accmethod'} eq $accmethod and $ref->{'flags'} eq $flags )
160 $self->{'dbh'} = $ref->{'dbh'};
164 Error('Database in dbPool has different flags: ' .
170 if( $options{'-Truncate'} )
175 if( $options{'-Delayed'} )
177 $self->{'delay_list_commit'} = 1;
184 # It is strongly inadvisable to do anything inside a signal handler when DB
185 # operation is in progress
187 our $interrupted = 0;
189 my $signalHandlersSet = 0;
196 sub setSignalHandlers
198 if( $signalHandlersSet )
206 Warn('Received SIGTERM. Scheduling to exit.');
211 Warn('Received SIGTERM. Stopping the process.');
219 Warn('Received SIGINT. Scheduling to exit.');
224 Warn('Received SIGINT. Stopping the process');
233 Warn('Received SIGPIPE. Scheduling to exit.');
238 Warn('Received SIGPIPE. Stopping the process');
246 Warn('Received SIGQUIT. Scheduling to exit.');
251 Warn('Received SIGQUIT. Stopping the process');
256 $signalHandlersSet = 1;
260 sub setSafeSignalHandlers
267 sub setUnsafeSignalHandlers
274 # If we were previously interrupted, gracefully exit now
280 Warn('Stopping the process');
291 my $filename = $self->{'dbname'};
292 Debug('Explicitly closing ' . $filename);
293 delete $Torrus::DB::dbPool{$filename};
294 $self->{'dbh'}->db_close();
295 delete $self->{'dbh'};
298 sub cleanupEnvironment
300 if( defined( $Torrus::DB::env ) )
302 foreach my $filename ( sort keys %Torrus::DB::dbPool )
304 Debug('Closing ' . $filename);
305 $Torrus::DB::dbPool{$filename}->{'dbh'}->db_close();
306 delete $Torrus::DB::dbPool{$filename};
309 Debug("Destroying BerkeleyDB::Env");
310 $Torrus::DB::env->close();
311 $Torrus::DB::env = undef;
313 if( -z $Torrus::DB::dbEnvErrFile )
315 unlink $Torrus::DB::dbEnvErrFile;
324 $self->{'delay_list_commit'} = 1;
333 Debug('Truncating ' . $self->{'dbname'});
335 return $self->{'dbh'}->truncate($count) == 0;
345 ref( $self->{'dbh'} ) or die( 'Fatal error: ' . $self->{'dbname'} );
346 return $self->{'dbh'}->db_put($key, $val) == 0;
355 $self->{'dbh'}->db_get($key, $val);
366 return $self->{'dbh'}->db_del($key) == 0;
375 return $self->{'dbh'}->db_cursor( $options{'-Write'} ? DB_WRITECURSOR:0 );
386 if( $cursor->c_get($key, $val, DB_NEXT) == 0 )
402 $cursor->c_del( $cnt );
413 if( $cursor->c_get( $key, $val, DB_SET ) == 0 )
430 return ( $cursor->c_put( $key, $val, DB_KEYFIRST ) == 0 );
435 # Btree best match. We assume that the searchKey is longer or equal
436 # than the matched key in the database.
438 # If none found, returns undef.
439 # If found, returns a hash with keys
440 # "exact" => true when exact match found
441 # "key" => key as is stored in the database
442 # "value" => value from the matched database entry
443 # The found key is shorter or equal than searchKey, and is a prefix
449 my $searchKey = shift;
451 my $key = $searchKey;
452 my $searchLen = length( $searchKey );
457 my $cursor = $self->{'dbh'}->db_cursor();
459 if( $cursor->c_get( $key, $val, DB_SET_RANGE ) == 0 )
461 if( $key eq $searchKey )
468 # the returned key/data pair is the smallest data item greater
469 # than or equal to the specified data item.
470 # The previous entry should be what we search for.
471 if( $cursor->c_get( $key, $val, DB_PREV ) == 0 )
473 if( length( $key ) < $searchLen and
474 index( $searchKey, $key ) == 0 )
477 $ret->{'key'} = $key;
478 $ret->{'value'} = $val;
485 if ( $cursor->c_get( $key, $val, DB_LAST ) == 0 )
487 if( length( $key ) < $searchLen and
488 index( $searchKey, $key ) == 0 )
491 $ret->{'key'} = $key;
492 $ret->{'value'} = $val;
497 return( $ok ? $ret : undef );
501 # Search the keys that match the specified prefix.
502 # Return value is an array of [key,val] pairs or undef
503 # Returned keys may be duplicated if the DB is created with -Duplicates
516 my $cursor = $self->{'dbh'}->db_cursor();
518 if( $cursor->c_get( $key, $val, DB_SET_RANGE ) == 0 )
520 # the returned key/data pair is the smallest data item greater
521 # than or equal to the specified data item.
523 while( not $finished )
525 if( index( $key, $prefix ) == 0 )
528 push( @{$ret}, [ $key, $val ] );
530 if( $cursor->c_get($key, $val, DB_NEXT) != 0 )
544 return( $ok ? $ret : undef );
548 # Search the keys that match the specified substring.
549 # Return value is an array of [key,val] pairs or undef
550 # Returned keys may be duplicated if the DB is created with -Duplicates
555 my $substring = shift;
563 my $cursor = $self->{'dbh'}->db_cursor();
565 while( $cursor->c_get($key, $val, DB_NEXT) == 0 )
567 if( index( $key, $substring ) >= 0 )
570 push( @{$ret}, [ $key, $val ] );
576 return( $ok ? $ret : undef );
583 # Comma-separated list manipulation
585 sub _populateListCache
590 if( not exists( $self->{'listcache'}{$key} ) )
593 my $values = $self->get($key);
594 if( defined( $values ) )
596 foreach my $val (split(/,/o, $values))
601 $self->{'listcache'}{$key} = $ref;
611 if( not $self->{'delay_list_commit'} )
613 $self->put($key, join(',', keys %{$self->{'listcache'}{$key}}));
624 $self->_populateListCache($key);
626 $self->{'listcache'}{$key}{$newval} = 1;
628 $self->_storeListCache($key);
638 $self->_populateListCache($key);
639 return $self->{'listcache'}{$key}{$name};
649 $self->_populateListCache($key);
650 if( $self->{'listcache'}{$key}{$name} )
652 delete $self->{'listcache'}{$key}{$name};
655 $self->_storeListCache($key);
664 $self->_populateListCache($key);
665 return keys %{$self->{'listcache'}{$key}};
675 delete $self->{'listcache'}{$key};
684 if( $self->{'delay_list_commit'} and
685 defined( $self->{'listcache'} ) )
687 while( my($key, $list) = each %{$self->{'listcache'}} )
689 $self->put($key, join(',', keys %{$list}));
701 # indent-tabs-mode: nil
702 # perl-indent-level: 4