From d70f8ae03e142cdc94075de2dda24d5ba480d70f Mon Sep 17 00:00:00 2001 From: Dean Hamstead Date: Mon, 14 Nov 2011 15:14:44 +1100 Subject: [PATCH] straight out of our POC... isnt useful yet --- src/lib/Torrus/DB/PostgreSQL.pm | 1809 +++++++++++++++++++++++++++++++++++++++ 1 file changed, 1809 insertions(+) create mode 100644 src/lib/Torrus/DB/PostgreSQL.pm diff --git a/src/lib/Torrus/DB/PostgreSQL.pm b/src/lib/Torrus/DB/PostgreSQL.pm new file mode 100644 index 0000000..d395407 --- /dev/null +++ b/src/lib/Torrus/DB/PostgreSQL.pm @@ -0,0 +1,1809 @@ +# Copyright (C) 2011 Dean Hamstead +# +# 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. + +# Robert Courtney +# Dean Hamstead + +package Torrus::DB::PostgreSQL; + +use strict; +use warnings; + +use base 'Torrus::DB'; + +use Torrus::Log; +use Torrus::SQL; +use Data::Compare qw/Compare/; + + +END +{ + #print "END called\n"; + &Torrus::DB::cleanupEnvironment(); +} + +=head1 NAME + +Torrus::DB::PostgreSQL - an abstraction layer for configuration database operations in Torrus + +Torrus::DB::Cursor - a custom class created to provide cursoring operations + +=head1 SYNOPSIS + + # + # Torrus::DB functions + # + + $db = Torrus::DB->new( 'name', %options ); + + $result = $db->trunc(); + + $val = $db->get( $key ); + $result = $db->put( $key, $val ); + $result = $db->del( $key [, $val ] ); + + $cursor = $db->cursor(); + + $val = $db->c_get( $cursor, $key ); + $result = $db->c_put( $cursor, $key, $val ); + $result = $db->c_del( $cursor ); + + ($key, $val) = $db->next( $cursor ); + + $ret = $db->getBestMatch( $string ); + $arrayref = $db->searchPrefix( $prefix ); + $arrayref = $db->searchSubstring( $string ); + + $result = $db->addToList( $list, $value ); + $result = $db->delFromList( $list, $value ); + $result = $db->searchList( $list, $value ); + $result = $db->deleteList( $list ); + + $db->closeNow(); + + # + # Torrus::DB::Cursor functions + # + + $cursor = new Torrus::DB::Cursor( $db, [ %options ] ); + + $val = $cursor->c_get($key); + $result = $cursor->c_put($key, $val); + $result = $cursor->c_del(); + + $result = $cursor->next( $key, $val ); + $result = $cursor->prev( $key, $val ); + + +=head1 DESCRIPTION + +Torrus::DB::PostgreSQL is used internally within Torrus as an abstraction layer for gaining access +to compiled configurations. It uses a similar interface to BerkeleyDB and takes advantage +of the typical structure of Btree databases and their cursoring/searching abilities + +Internally, Torrus::DB::PostgreSQL uses another class Torrus::DB::Cursor to provide cursoring +functionality. The API of Torrus::DB::Cursor is also included in this documentation. + +Torrus::DB::PostgreSQL also heavily relies upon internal caching and queued/uncommitted transactions +for performance. Read through the VARIABLES description below to understand how you can +tune the DB interactions in Torrus::DB::PostgreSQL for performance or reliability. + +=head1 VARIABLES + +=over + +=item B + + $Torrus::DB::dbCacheTimeout = 60; + +Controls the amount of time (in seconds) that database transactions can be left outstanding +before being committed. Setting this value to 0 effectively disables any transaction caching, +so transactions are committed as soon as they are complete + +=item B + + $Torrus::DB::maxUncommittedChanges = 10000; + +An alternative to using time-based caching, you can also define a limit of the number of +uncommitted changes before a commit is issued. This option is implemented separately to +the B option i.e. both can be used. + +Torrus::DB only counts changes (i.e. SQL UPDATE, INSERT, DELETE) commands towards this limit. + +=back + + + +=head1 FUNCTIONS - Torrus::DB + +=over + +=item B + + Database opening: + my $db = Torrus::DB::PostgreSQL->new('db_name', + [ -Btree => 1, ] + [ -WriteAccess => 1, ] + [ -Truncate => 1, ] + [ -Duplicates => 1, ] + [ -Subdir => 'dirname' ]); + Defaults: Hash, read-only, no truncate. + +Torrus::DB::PostgreSQL->new() will create a new Torrus::DB::PostgreSQL object, which contains a DB handler with a +connection to the database requested. + +B Be aware, creating multiple objects for the same database will mean that each +object will a reference to the same internal DB handler. See the B section +for more information + +=item B + + $result = $db->trunc(); + +Deletes all data/rows from the given database + +=item B + + $val = $db->get( $key ); + +The same as BerkeleyDB::get() - given a key, returns the value associated with that key +from the database. If the database is in a Btree format with Duplicates, it will allow +the same key to be mapped to many different values. The function returns 0 on success. + +=item B + + $result = $db->put( $key, $val ); + +The same as BerkeleyDB::put() - given a key/value pair, store them in the database. +put() can support multiple key/value pairs with the same key. The function returns 0 on success. + +=item B + + $result = $db->del( $key [, $val] ); + +Remove all key/value pairs where the key is $key (and optionally) the value is $val. This is +slightly different to the BerkeleyDB::del() function which only accepts a key, and removes all +key/val pairs with that key. The extra option here is to allow the c_del() function to re-use +the del() function for cursored deletes. + +=item B + + $cursor = $db->cursor(); + +Returns a new C object, which can be used for iterating over the +database contents. + +=item B + + $val = $db->c_get( $cursor, $key ); + +Uses a cursor object to find a key/val pair where key = $key. The cursor should move its +position to the location of the returned key/val pair i.e. following a c_get() with a +c_del() will result in ($key => $val) being removed from the database + + $db->c_del( $cursor ); + +=item B + + $result = $db->c_put( $cursor, $key, $val ); + +Inserts the ($key => $val) pair into the database at the current cursor location, +overwriting any previous key/value pair at its current position + +=item B + + $result = $db->c_del(); + +Deletes the key/val pair that the cursor is currently positioned at. This is clear +because the c_del() function does not accept any $key/$val arguments. + +=item B + + ($key, $val) = $db->next( $cursor ); + +Moves the cursor to the next position in its iteration and return the key/value pair +of that position. + +=item B + + $ret = $db->getBestMatch( $searchKey ); + +Performs a key-based search to find the closest-matching key. The closest match is +actually a key that is shorter than $searchKey, but is the largest key that is +still a prefix of $searchKey e.g. + +If the match is exact, $ret will be B<{ exact =E 1 }>, if the returned key +is not a match then $ret will be B<{ key =E $closest_key, value =E +$value_of_closest_key }>, otherwise return will be B + +=item B + + $arrayref = $db->searchPrefix( $prefix ); + +Search the database for keys that begin with $prefix, and return a reference to +an array [$key, $val] pairs e.g. $arrayref = [ [key1,val1], [key4,val4] ]; + +=item B + + $arrayref = $db->searchSubstring( $string ); + +Search the database for keys that contain $string, and return a reference +to an array [$key, $val] pairs e.g. $arrayref = [ [key2,val2], [key9,val9] ]; + +=item B + + $result = $db->addToList( $list, $value, [$unique] ); + +Consider $list as a key, with a comma-separated value. Add $value to the +comma-separated value for $key and return non-zero on success. + +If $unique is non-zero, if $value is already in the list, return 0. + +B DB: { 'Santa' => 'jan,jen,gin,john' }; + +running: $db-EaddToList( 'Santa', 'tommy' ); + +will result in DB: { 'Santa' => 'jan,jen,gin,john,tommy' }; + +=item B + + $result = $db->delFromList( $list, $value ); + +Removes $value from the comma-separated value that $list is mapped to in +the database. Returns non-zero if $value is in $list and can be removed. + +=item B + + $result = $db->searchList( $list, $value ); + +Returns true if $value is in the value pair with $key + +=item B + + $result = $db->deleteList( $list ); + +Deletes the list $list from the database. In effect, this simply deletes +key/value pairs where key is $$list. Returns true on success + +=item B + + $db->closeNow(); + +Closes the database handle associated with the object $db. This flushes +any outstanding transactions to the database and disconnects + +=head1 FUNCTIONS - Torrus::DB::Cursor + +=item B + + $cursor = new Torrus::DB::Cursor( $db ); + +Given an existing Torrus::DB object, return a cursor object for that database. +Many cursors can exist for the same database object, to allow concurrent +iteration of different queries. + +=item B + + $val = $cursor->c_get($key); + +Uses a cursor object to find a key/val pair where key = $key. The cursor +should move its position to the location of the returned key/val pair. + +=item B + + $result = $cursor->c_put($key, $val); + +Inserts the ($key => $val) pair into the database at the current cursor +location, overwriting any previous key/value pair at its current position + +=item B + + $result = $cursor->c_del(); + +Deletes the key/val pair that the cursor is currently positioned at. +This is clear because the c_del() function does not accept any +$key/$val arguments. + +=item B + + $result = $cursor->next( $key, $val ); + +Moves the cursor to the next position in its iteration and replaces +$key and $val with the values of the new position. The success of +this function is returned. + +=item B + + $result = $cursor->prev( $key, $val ); + +Moves the cursor back one position and replaces $key and $val with the +values at the new location. The success of this functions is returned. + +=back + + +=head1 CAVEATS + +In an effort to reduce duplicate code and configuration, Torrus::DB relies +on the Torrus::SQL module to provide configuration details (DSN, username, +password) to a database, and to return an object handler for that database. +A side-effect of this use is that Torrus::SQL caches database handlers so +that many objects requesting access to the same database (with the same +credentials) will receive the same database handler object. + + +=cut + +sub new +{ + my $class = shift; + my $dbname = shift; + my $self = {}; + my %options = @_; + bless $self, $class; + + my $tree = $options{'-Subdir'} || undef; + + # we need this in DESTROY debug message + $self->{'dbtable'} = 'config_' . ( $tree || 'root' ); + #$self->{'dbtable'} = 't_' . ( $tree ? "${tree}_" : '' ) . $dbname; + $self->{'dbname'} = $dbname; + $self->{'flags'} = \%options; + + #print "new Torrus::DB: dbtable = " . $self->{'dbtable'} . "\n"; + my %trees = ( filers => 1, machines => 1, switches => 1 ); + + # validate database name - if it doesn't + if ( !$options{'-WriteAccess'} and $tree and !$trees{$tree} ) + { + Error( "Tree $tree does not exist - not creating" ); + return undef; + } + + my $property = 0; + if( defined $options{'-Duplicates'} ) + { + $self->{'-Duplicates'} = $options{'-Duplicates'}; + } + + if( $options{'-Btree'} ) + { + $self->{'-Btree'} = $options{'-Btree'}; + } + + Debug('Opening ' . $self->{'dbname'}); + if( not exists( $Torrus::DB::dbPool{$dbname} ) ) + { + my $dbh = Torrus::SQL->dbh( 'Config' ); + + if( not $dbh ) + { + Error("Cannot open database $dbname: $! $BerkeleyDB::Error"); + return undef; + } + + if ( $options{'AutoCommit'} ) + { + $dbh->{'AutoCommit'} = 1; + } + + $Torrus::DB::dbPool{$dbname} = { 'dbh' => $dbh }; + + $self->{'dbh'} = $dbh; + } + else + { + Debug( 'Reusing existing DB handle' ); + my $ref = $Torrus::DB::dbPool{$dbname}; + $self->{'dbh'} = $ref->{'dbh'}; + } + + if( $options{'-Truncate'} ) + { + $self->trunc(); + } + + $self->{'_dbTruncated'} = 0; + $self->{'_deleted'} = {}; # key/value pairs already deleted from DB + $self->{'_cacheFilled'} = 0; + + return $self; +} + + +sub _closeHandle +{ + my $self = shift; + my $dbh = shift; + + if ( ! defined $dbh ) + { + $dbh = $self; + $self = undef; + } + + if ( $dbh ) + { + foreach my $action ( grep { $dbh->can($_) } qw/commit disconnect/ ) + { + $dbh->$action(); + } + } +} + + +sub DESTROY +{ + my $self = shift; + my $dbname = $self->{'dbname'}; + + return unless $Torrus::DB::dbPool{$dbname} + and $self->{'dbh'}; + + $self->closeNow(); +} + + +# It is strongly inadvisable to do anything inside a signal handler when DB +# operation is in progress + +our $interrupted = 0; +our $dbCacheTimeout; +our $maxUncommittedChanges; + +my $signalHandlersSet = 0; +my $safeSignals = 0; + +my $doFlush = 0; +my $alarmSet = 0; + +our %columns = ( + key => 'key', + value => 'value', + dbname => 'dbname', +); + + +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 $dbname = $self->{'dbname'}; + Debug('Explicitly closing ' . $dbname); + + delete $Torrus::DB::dbPool{$dbname}; + + my $dbh = $self->{'dbh'}; + if ( grep { Compare( $dbh, $_->{'dbh'} ) } values %Torrus::DB::dbPool ) + { + } + else + { + $self->_closeHandle( $dbh ); + } + delete $self->{'dbh'}; +} + +sub cleanupEnvironment +{ + foreach my $filename ( sort keys %Torrus::DB::dbPool ) + { + Debug('Closing ' . $filename); + my $dbh = $Torrus::DB::dbPool{$filename}{'dbh'}; + + &Torrus::DB::_closeHandle( $dbh ); + + delete $Torrus::DB::dbPool{$filename}; + } +} + + +sub _dbAlive +{ + my $self = shift; + + return unless $self->{'dbh'}; + + my $ok = $self->{'dbh'}->ping(); + if ( !$ok ) + { + Debug( "ping error($ok) after prepare(), pg_ping = ", $self->{'dbh'}->pg_ping() ); + } + + return $ok; +} + + + + +sub _runSql +{ + my $self = shift; + my $sql = shift; + #my @bind_vars = map { !defined $_ ? '' : $_ } @_; + my @bind_vars = @_; + my $results; + + if ( !$self->_dbAlive() ) + { + return; + } + + my $sth = $self->{'dbh'}->prepare($sql, {pg_prepare_now => 1} ); + if ( defined $sth ) + { + if ( !$self->_dbAlive() ) + { + Debug( "dbh->ping() error after prepare(), pg_ping = ", $self->{'dbh'}->pg_ping() ); + return; + } + + my $ok = $sth->execute( @bind_vars ); + if ( ! defined $ok ) + { + Debug( "sth->execute() error: " . substr($sql,0,100) ); + Debug( "error: " . $sth->errstr ); + return; + } + + my $now = time; + my $maxChanges = $Torrus::DB::maxUncommittedChanges || 1000; + my $cacheTime = $Torrus::DB::dbCacheTimeout || 30; + $self->{'lastDBCommit'} ||= time; + + $self->{'_cachedChanges'}++; + + unless ( index($sql,'SELECT') == 0 ) + { + my $commit = 0; + if ( $now > ($self->{'lastDBCommit'} + $cacheTime) ) + { + $commit = 1; + } + elsif ( $self->{'_cachedChanges'} > $maxUncommittedChanges ) + { + $commit = 1; + } + + if ( $commit ) + { + $self->{'dbh'}->commit(); + $self->{'_cachedChanges'} = 0; + $self->{'lastDBCommit'} = time; + } + } + } + else + { + Error( '_runSql dbh->prepare() error' ); + return; + } + + return $sth; +} + + +sub _slurp_db +{ + my $self = shift; + + if ( $self->{'_cacheFilled'} ) + { + return 1; + } + + my ($c_key, $c_val) = @Torrus::DB::columns{qw/key value/}; + my $sql = sprintf q/SELECT %s,%s FROM %s WHERE %s = ? ORDER BY %s,%s/, + $c_key, $c_val, + $self->{'dbtable'}, + $Torrus::DB::columns{'dbname'}, + $c_key, $c_val; + + my $sth = $self->_runSql( $sql, $self->{'dbname'} ); + + if ( $sth and $sth->rows() ) + { + my $data = $sth->fetchall_arrayref(); + + if ( $data and @$data ) + { + foreach my $row ( @$data ) + { + my ($k,$v) = @$row; + $self->_cachePut($k,$v); + } + } + } + + $self->{'_cacheFilled'} = 1; +} + + +sub _cacheGet +{ + my $self = shift; + my $key = shift; + my $val; + + if ( $self->{'_dbcache'}{$key} and keys %{ $self->{'_dbcache'}{$key} } ) + { + my @sorted = sort keys %{$self->{'_dbcache'}{$key}}; + $val = $sorted[0]; + + if ( !defined $val ) + { + $val = ''; + } + } + + #print "db->_cacheGet($key) = $val\n"; + return $val; +} + + +sub _cacheDel +{ + my $self = shift; + my $key = shift; + my $val = shift; + + if ( defined $val ) + { + #print "_cachedel($key => $val)\n"; + delete $self->{'_dbcache'}{$key}{$val}; + if ( scalar keys %{ $self->{'_dbcache'}{$key} } == 0 ) + { + delete $self->{'_dbcache'}{$key}; + $self->{'_deleted'}{$key} = {}; + #print "marking key($key) as deleted\n"; + } + else + { + #print "marking key($key => $val) as deleted\n"; + $self->{'_deleted'}{$key}{$val} = 1; + } + } + else + { + #print "_cachedel($key)\n"; + delete $self->{'_dbcache'}{$key}; + #print "marking key($key) as deleted\n"; + $self->{'_deleted'}{$key} = {}; + } + + delete $self->{'_dbcache_sorted'}; +} + +sub _cachePut +{ + my $self = shift; + my $key = shift; + my $val = shift; + + return unless defined $val; + + if ( $self->{'-Duplicates'} ) + { + $self->{'_dbcache'}{$key}{$val} = 1; + } + else + { + $self->{'_dbcache'}{$key} = { $val => 1 }; + } + + delete $self->{'_deleted'}{$key}; + delete $self->{'_dbcache_sorted'}; +} + + + +sub _inCache +{ + my $self = shift; + my $key = shift; + my $val = shift; + + my $inCache; + if ( defined $val ) + { + $inCache = defined $self->{'_dbcache'}{$key}{$val} ? 1 : 0; + } + else + { + $inCache = defined $self->{'_dbcache'}{$key} ? 1 : 0; + } + + return $inCache; +} + + + +sub _deleted +{ + my $self = shift; + my $key = shift; + my $val = shift; + + my $deleted; + if ( defined $val ) + { + $deleted = ( defined $self->{'_deleted'}{$key}{$val} ? 1 : 0 ); + } + else + { + $deleted = ( defined $self->{'_deleted'}{$key} ? 1 : 0 ); + } + + return $deleted; +} + + +sub trunc +{ + my $self = shift; + + Debug('Truncating ' . $self->{'dbname'}); + my $sql = sprintf 'DELETE FROM %s WHERE %s = ?', + $self->{'dbtable'}, + $Torrus::DB::columns{'dbname'}; + + $self->_runSql( $sql, $self->{'dbname'} ); + + if ( $self->{'_dbcache'} ) + { + $self->{'_dbcache'} = {}; + } + + $self->{'_truncated'} = 1; + $self->{'_cacheFilled'} = 1; + $self->{'_deleted'} = {}; + + return 1; +} + + +sub put +{ + my $self = shift; + my $key = shift; + my $val = shift; + + ref( $self->{'dbh'} ) or die( 'Fatal error: ' . $self->{'dbname'} ); + + my $dbname = $self->{'dbname'}; + + # return if key/value pair already in DB + if ( $self->_inCache($key,$val) ) + { + return 1; + } + + my ($insert, $update) = (0,0); + if ( !$self->{'-Duplicates'} and defined $self->get($key) ) + { + $update = 1; + } + else + { + $insert = 1; + } + + + # insert into DB + my ( $sql, @bind_vars ); + + if ( $insert ) + { + $sql = sprintf 'INSERT INTO %s VALUES(?,?,?)', + $self->{'dbtable'}; + + @bind_vars = ( $self->{'dbname'}, $key, $val ); + } + else + { + $sql = sprintf 'UPDATE %s SET %s = ? WHERE %s = ? AND %s = ?', + $self->{'dbtable'}, + $Torrus::DB::columns{'value'}, + $Torrus::DB::columns{'dbname'}, + $Torrus::DB::columns{'key'}; + + @bind_vars = ( $val, $self->{'dbname'}, $key ); + } + + $self->_cachePut( $key, $val ); + + $self->_runSql( $sql, @bind_vars ); + + #print "put() $key => $val END\n\n"; + return 0; +} + + +sub get +{ + my $self = shift; + my $key = shift; + my $val; + + if ( !$key ) + { + return 0; + } + + my $dbname = $self->{'dbname'}; + + $val = $self->_cacheGet($key); + + if ( !defined $val) + { + unless ( $self->{'_cacheFilled'} + or defined $self->{'_deleted'}{$key} + or $self->{'_truncated'} + ) + { + my $sql = sprintf 'SELECT %s FROM %s WHERE %s = ? AND %s = ?', + $Torrus::DB::columns{'value'}, + $self->{'dbtable'}, + $Torrus::DB::columns{'dbname'}, + $Torrus::DB::columns{'key'}; + + my $sth = $self->_runSql( $sql, $self->{'dbname'}, $key ); + if ( $sth and $sth->rows() ) + { + my $data = $sth->fetchall_arrayref(); + + if ( $data and @$data ) + { + foreach my $row ( @$data ) + { + my ($v) = @$row; + $self->_cachePut($key,$v); + } + } + } + + $val = $self->_cacheGet($key); + } + } + + return $val; +} + + +sub del +{ + my $self = shift; + my $key = shift; + my $val = shift; + + # delete from DB + my $inCache = $self->_inCache($key,$val); + + #print "del($key,$val) START\n"; + # delete from DB + unless ( $self->_deleted($key,$val) ) + { + my $sql = sprintf q/DELETE FROM %s WHERE %s = ? AND %s = ?/, + $self->{'dbtable'}, + $Torrus::DB::columns{'dbname'}, + $Torrus::DB::columns{'key'}; + + my @bind_vars = ( $self->{'dbname'}, $key ); + + if ( defined $val ) + { + $sql .= sprintf ' AND %s = ?', + $Torrus::DB::columns{'value'}, + $val; + + push @bind_vars, $val; + } + + #print "sql = $sql\n"; + $self->_runSql( $sql, @bind_vars ); + } + + # delete from cache + if ( $inCache ) + { + #print "del() - delete from cache\n"; + $self->_cacheDel($key,$val); + } + + #print "del($key,$val) END \n"; + return 1; +} + + +sub cursor +{ + my $self = shift; + my %options = @_; + + return Torrus::DB::Cursor->new( $self, %options ); +} + + +sub next +{ + my $self = shift; + my $cursor = shift; + my $key = ''; + my $val = ''; + + if( $cursor->next($key, $val) == 0 ) + { + return ($key, $val); + } + else + { + return; + } +} + +sub c_del +{ + my $self = shift; + my $cursor = shift; + + my $flags = 0; + $cursor->c_del( $flags ); +} + + +sub c_get +{ + my $self = shift; + my $cursor = shift; + my $key = shift; + my $val = undef; + + if( $cursor->c_get( $key, $val ) == 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 ) == 0 ); +} + + + +sub _getSortedPairs +{ + my $self = shift; + + return unless $self->{'_dbcache'} + and keys %{ $self->{'_dbcache'} }; + + my $dbcache = $self->{'_dbcache'}; + + my @values; + if ( $self->{'_dbcache_sorted'} ) + { + @values = @{ $self->{'_dbcache_sorted'} }; + } + else + { + foreach my $k ( sort keys %$dbcache ) + { + foreach my $v ( sort keys %{$dbcache->{$k}} ) + { + push @values, [$k,$v]; + } + } + $self->{'_dbcache_sorted'} = \@values; + } + + return @values; +} + + + + +# 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 $searchLen = length( $searchKey ); + + my $key; + my $val = ''; + + my $match = 0; + my $prefixMatch = 0; + + my @values = $self->_getSortedPairs(); + + my $idx = 0; + foreach my $row ( @values ) + { + my ($k,$v) = @{$row}; + + if ( index($searchKey, $k) == 0 ) + { + $prefixMatch = 1; + + if ( $k eq $searchKey ) + { + $key = $k; + $val = $v; + $match = 1; + last; + } + elsif ( !$key or (length($k) > length($key)) ) + { + $key = $k; + $val = $v; + } + } + else + { + if ( $prefixMatch ) + { + $key = $k; + $val = $v; + last; + } + } + $idx++; + } + + + + #print "match:$match prefixmatch:$prefixMatch key='$key' val='$val'\n"; + + + + + my $ok = 0; + my $ret = {}; + + if( $match or $prefixMatch ) + { + if ( $match ) + { + $ok = 1; + $ret->{'exact'} = 1; + } + elsif ( $prefixMatch ) + { + #print "prefixMatch - moving to previous value\n"; + # 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. + + $idx--; + if ( $idx >= 0 ) + { + ($key,$val) = @{$values[$idx]}; + + if( length( $key ) < $searchLen and + index( $searchKey, $key ) == 0 ) + { + $ok = 1; + $ret->{'key'} = $key; + $ret->{'value'} = $val; + } + } + } + } + else + { + $idx++; + + if ( $idx < scalar @values ) + { + ($key,$val) = @{$values[$idx]}; + + 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 %seen; + foreach my $key ( grep { index($_, $prefix) == 0 } sort keys %{$self->{'_dbcache'}} ) + { + $ok = 1; + foreach my $val ( sort keys %{$self->{'_dbcache'}{$key}} ) + { + push @{$ret}, [ $key, $val ]; + } + } + + 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; + + foreach my $key ( grep { index($_, $substring) >= 0 } sort keys %{$self->{'_dbcache'}} ) + { + $ok = 1; + foreach my $val ( sort keys %{$self->{'_dbcache'}{$key}} ) + { + push @{$ret}, [ $key, $val ]; + } + } + + return( $ok ? $ret : undef ); +} + + + + + +# Comma-separated list manipulation + +sub addToList +{ + my $self = shift; + my $key = shift; + my $newname = shift; + my $must_unique = shift; + + my $prefix; + my $list; + if( exists( $self->{'listcache'}{$key} ) ) + { + $list = $self->{'listcache'}{$key}; + } + else + { + $list = $self->get($key); + $self->{'listcache'}{$key} = $list; + } + + if( defined($list) and length($list) > 0 ) + { + $prefix = ','; + if( grep {$newname eq $_} split(',', $list) ) + { + # This name is already in the list + return $must_unique ? 0:1; + } + } + else + { + $prefix = ''; + } + $list .= $prefix.$newname; + + $self->{'listcache'}{$key} = $list; + return ( $self->put($key, $list) == 0 ); +} + + +sub searchList +{ + my $self = shift; + my $key = shift; + my $name = shift; + + my $list; + if( exists( $self->{'listcache'}{$key} ) ) + { + $list = $self->{'listcache'}{$key}; + } + else + { + $list = $self->get($key); + $self->{'listcache'}{$key} = $list; + } + + if( defined($list) and length($list) > 0 ) + { + if( grep {$name eq $_} split(',', $list) ) + { + return 1; + } + } + return 0; +} + +sub delFromList +{ + my $self = shift; + my $key = shift; + my $name = shift; + + my $list; + if( exists( $self->{'listcache'}{$key} ) ) + { + $list = $self->{'listcache'}{$key}; + } + else + { + $list = $self->get($key); + $self->{'listcache'}{$key} = $list; + } + + if( defined($list) and length($list) > 0 ) + { + my @array = split(',', $list); + my $found = 0; + foreach my $index (0 .. $#array) + { + if( $array[$index] eq $name ) + { + splice( @array, $index, 1 ); + $found = 1; + last; + } + } + if( $found ) + { + if( scalar(@array) > 0 ) + { + $list = join(',', @array); + $self->{'listcache'}{$key} = $list; + $self->put($key, $list); + } + else + { + $self->del($key); + delete $self->{'listcache'}{$key}; + } + return 1; + } + else + { + return 0; + } + } + return 0; +} + + + +sub deleteList +{ + my $self = shift; + my $key = shift; + + delete $self->{'listcache'}{$key}; + $self->del($key); +} + + + + + +package Torrus::DB::Cursor; + +use Torrus::Log; +use Torrus::DB; + + + +sub _keypair +{ + my ($col_k, $col_v) = @Torrus::DB::columns{qw/key value/}; + return ( $a->{$col_k} cmp $b->{$col_k} || $a->{$col_k} cmp $b->{$col_v} ); +} + + + +sub new +{ + my $class = shift; + my $db = shift; + my %options = @_; + my $self = {}; + + $self->{'db'} = $db; + $self->{'dbh'} = $db->{'dbh'}; + $self->{'dbname'} = $db->{'dbname'}; + $self->{'dbtable'} = $db->{'dbtable'}; + + if ( %options ) + { + $self->{'flags'} = \%options; + } + + bless $self, $class; + + $self->{'db'}->_slurp_db(); + $self->{'_cursor'} = []; + + return $self; +} + +sub DESTROY +{ + my $self = shift; + + delete $self->{'db'}; + delete $self->{'dbh'}; +} + + + +sub c_get +{ + my $self = shift; + my $key = $_[0]; + my $val = undef; + + $val = $self->{'db'}->get($key); + #print "cursor->c_get($key) = $val\n"; + + $_[0] = $key; + $_[1] = $val; + + return ( defined $val ? 0 : 1 ); +} + + +sub c_put +{ + my $self = shift; + my $key = shift; + my $val = shift; + + if ( ! $self->{'db'} ) + { + Error( "Cursor DB handle not defined" ); + } + + # if duplicates not supported, remove any existing keys first + $self->{'_cursor'} = [$key,$val]; + $self->{'db'}->put($key,$val); + + return 0; +} + + +sub c_del +{ + my $self = shift; + my $key; + my $val; + + if ( $self->{'_cursor'} and @{$self->{'_cursor'}} ) + { + ($key, $val) = @{ $self->{'_cursor'} }; + + #print STDERR "c_del($key,$val)\n"; + $self->{'db'}->del($key,$val); + $self->{'_cursor'} = []; + + return (1); + } + else + { + print STDERR "c_del() - no cursor position\n"; + Error( $self->{'dbh'}->errstr() ); + return; + } +} + + +sub last +{ + my $self = shift; + my $key = undef; + my $val = undef; + + # check we have data + if ( $self->{'db'}{'_dbcache'} and keys %{$self->{'db'}{'_dbcache'} } ) + { + my @keys = sort keys %{ $self->{'db'}{'_dbcache'} }; + $key = pop @keys; + + my @vals = sort keys %{ $self->{'db'}{'_dbcache'}{$key} }; + $val = pop @vals; + + $self->{'_cursor'} = [$key,$val]; + } + else + { + return 1; + } + + $_[0] = $key; + $_[1] = $val; + + if ( defined $key and defined $val ) + { + return 0; + } + else + { + return 1; + } +} + + +sub first +{ + my $self = shift; + my $key = undef; + my $val = undef; + + # check we have data + if ( $self->{'db'}{'_dbcache'} ) + { + my ($first) = $self->{'db'}->_getSortedPairs(); + + if ( $first and @$first ) + { + $self->{'_cursor'} = $first; + ($key,$val) = @$first; + } + } + else + { + return 1; + } + + $_[0] = $key; + $_[1] = $val; + + if ( defined $key and defined $val ) + { + return 0; + } + else + { + return 1; + } +} + + +sub prev +{ + my $self = shift; + my $key = undef; + my $val = undef; + + my ( @kv_pairs, $c_key, $c_val ); + + # check we have data + unless ( $self->{'db'}{'_dbcache'} ) + { + return 1; + } + + if ( $self->{'_cursor'} and @{$self->{'_cursor'}} ) + { + ($c_key,$c_val) = @{$self->{'_cursor'}}; + @kv_pairs = $self->{'db'}->_getSortedPairs(); + + my $pos = 0; + foreach my $ref ( @kv_pairs ) + { + if ( $ref->[0] eq $c_key && $ref->[1] eq $c_val ) + { + $pos--; + if ( $pos >= 0 && $pos < scalar @kv_pairs && $kv_pairs[$pos] ) + { + ($key,$val) = @{$kv_pairs[$pos]}; + $self->{'_cursor'} = [$key, $val]; + } + last; + } + $pos++; + } + + $_[0] = $key; + $_[1] = $val; + } + else + { + $self->first($key, $val); + } + + if ( defined $key and defined $val ) + { + return 0; + } + else + { + return 1; + } +} + + +sub next +{ + my $self = shift; + my $key = undef; + my $val = undef; + + my ( $c_key, $c_val ); + + # check we have data + unless ( $self->{'db'}{'_dbcache'} ) + { + return 1; + } + + if ( $self->{'_cursor'} and @{$self->{'_cursor'}} ) + { + ($c_key,$c_val) = @{$self->{'_cursor'}}; + my @kv_pairs = $self->{'db'}->_getSortedPairs(); + + my $pos = 0; + foreach my $ref ( @kv_pairs ) + { + if ( $ref->[0] eq $c_key && $ref->[1] eq $c_val ) + { + $pos++; + if ( $pos >= 0 && $pos < scalar @kv_pairs && $kv_pairs[$pos] ) + { + ($key,$val) = @{$kv_pairs[$pos]}; + $self->{'_cursor'} = [$key, $val]; + } + last; + } + $pos++; + } + + } + else + { + $self->first($key, $val); + $self->{'_cursor'} = [$key, $val]; + } + + $_[0] = $key; + $_[1] = $val; + + #print "cursor->next() = ($key,$val)\n"; + + if ( defined $key and defined $val ) + { + return 0; + } + else + { + return 1; + } + +} + + +sub c_bestKeyMatch +{ + my $self = shift; + my $key = undef; + my $val = undef; + + my $searchKey = $_[0]; + my $searchLen = length($searchKey); + + my @values; + { + return 1; + } + + my $prefixMatch = 0; + my $match = 0; + my $finished = 0; + foreach my $row ( @values ) + { + my ($k,$v) = @{$row}; + + if ( index($searchKey, $k) == 0 ) + { + $prefixMatch = 1; + + if ( $k eq $searchKey ) + { + $key = $k; + $val = $v; + $match = 1; + last; + } + elsif ( !$key or (length($k) > length($key)) ) + { + $key = $k; + $val = $v; + $match = 1; + } + } + else + { + if ( $prefixMatch ) + { + $key = $k; + $val = $v; + last; + } + } + } + + # move cursor to last key/val pair if no match found + if ( !$match && !$prefixMatch ) + { + ($key,$val) = @{$values[0]}; + } + + $_[0] = $key; + $_[1] = $val; + + if ( defined $key and defined $val ) + { + $self->{'_cursor'} = [$key, $val]; + return 0; + } + else + { + return 1; + } +} + +1; + + +# Local Variables: +# mode: perl +# indent-tabs-mode: nil +# perl-indent-level: 4 +# End: + + + + + + -- 2.11.4.GIT