BerkeleyDB
view release on metacpan or search on metacpan
BerkeleyDB.pm view on Meta::CPAN
{
my $self = shift ;
my $key = shift ;
$self->db_del($key) ;
}
sub CLEAR_old
{
my $self = shift ;
my ($key, $value) = (0, 0) ;
my $cursor = $self->_db_write_cursor() ;
while ($cursor->c_get($key, $value, BerkeleyDB::DB_PREV()) == 0)
{ $cursor->c_del() }
}
sub CLEAR_new
{
my $self = shift ;
$self->truncate(my $count);
}
*CLEAR = $BerkeleyDB::db_version < 4 ? \&CLEAR_old : \&CLEAR_new ;
BerkeleyDB.pm view on Meta::CPAN
*FIRSTKEY = \&BerkeleyDB::_tiedHash::FIRSTKEY ;
*NEXTKEY = \&BerkeleyDB::_tiedHash::NEXTKEY ;
sub EXTEND {} # don't do anything with EXTEND
sub SHIFT
{
my $self = shift;
my ($key, $value) = (0, 0) ;
my $cursor = $self->_db_write_cursor() ;
return undef if $cursor->c_get($key, $value, BerkeleyDB::DB_FIRST()) != 0 ;
return undef if $cursor->c_del() != 0 ;
return $value ;
}
sub UNSHIFT
{
my $self = shift;
if (@_)
{
my ($key, $value) = (0, 0) ;
my $cursor = $self->_db_write_cursor() ;
my $status = $cursor->c_get($key, $value, BerkeleyDB::DB_FIRST()) ;
if ($status == 0)
{
foreach $value (reverse @_)
{
$key = 0 ;
$cursor->c_put($key, $value, BerkeleyDB::DB_BEFORE()) ;
}
}
elsif ($status == BerkeleyDB::DB_NOTFOUND())
{
$key = 0 ;
foreach $value (@_)
{
$self->db_put($key++, $value) ;
}
}
}
}
sub PUSH
{
my $self = shift;
if (@_)
{
my ($key, $value) = (-1, 0) ;
my $cursor = $self->_db_write_cursor() ;
my $status = $cursor->c_get($key, $value, BerkeleyDB::DB_LAST()) ;
if ($status == 0 || $status == BerkeleyDB::DB_NOTFOUND())
{
$key = -1 if $status != 0 and $self->type != BerkeleyDB::DB_RECNO() ;
foreach $value (@_)
{
++ $key ;
$status = $self->db_put($key, $value) ;
}
}
# can use this when DB_APPEND is fixed.
# foreach $value (@_)
# {
# my $status = $cursor->c_put($key, $value, BerkeleyDB::DB_AFTER()) ;
#print "[$status]\n" ;
# }
}
}
sub POP
{
my $self = shift;
my ($key, $value) = (0, 0) ;
my $cursor = $self->_db_write_cursor() ;
return undef if $cursor->c_get($key, $value, BerkeleyDB::DB_LAST()) != 0 ;
return undef if $cursor->c_del() != 0 ;
return $value ;
}
sub SPLICE
{
my $self = shift;
croak "SPLICE is not implemented yet" ;
}
BerkeleyDB.pm view on Meta::CPAN
my $db = shift ;
my $key = shift ;
my $flag = shift ;
my $value = 0 ;
my $origkey = $key ;
my $wantarray = wantarray ;
my %values = () ;
my @values = () ;
my $counter = 0 ;
my $status = 0 ;
my $cursor = $db->db_cursor() ;
# iterate through the database until either EOF ($status == 0)
# or a different key is encountered ($key ne $origkey).
for ($status = $cursor->c_get($key, $value, BerkeleyDB::DB_SET()) ;
$status == 0 and $key eq $origkey ;
$status = $cursor->c_get($key, $value, BerkeleyDB::DB_NEXT()) ) {
# save the value or count number of matches
if ($wantarray) {
if ($flag)
{ ++ $values{$value} }
else
{ push (@values, $value) }
}
else
{ ++ $counter }
}
return ($wantarray ? ($flag ? %values : @values) : $counter) ;
}
sub db_cursor
{
my $db = shift ;
my ($addr) = $db->_db_cursor(@_) ;
my $obj ;
$obj = bless [$addr, $db] , "BerkeleyDB::Cursor" if $addr ;
return $obj ;
}
sub _db_write_cursor
{
my $db = shift ;
my ($addr) = $db->__db_write_cursor(@_) ;
my $obj ;
$obj = bless [$addr, $db] , "BerkeleyDB::Cursor" if $addr ;
return $obj ;
}
sub db_join
{
croak 'Usage: $db->BerkeleyDB::db_join([cursors], flags=0)'
if @_ < 2 || @_ > 3 ;
my $db = shift ;
croak 'db_join: first parameter is not an array reference'
if ! ref $_[0] || ref $_[0] ne 'ARRAY';
my ($addr) = $db->_db_join(@_) ;
my $obj ;
$obj = bless [$addr, $db, $_[0]] , "BerkeleyDB::Cursor" if $addr ;
return $obj ;
}
package BerkeleyDB::Cursor ;
sub c_close
{
my $cursor = shift ;
$cursor->[1] = "" ;
return $cursor->_c_close() ;
}
sub c_dup
{
my $cursor = shift ;
my ($addr) = $cursor->_c_dup(@_) ;
my $obj ;
$obj = bless [$addr, $cursor->[1]] , "BerkeleyDB::Cursor" if $addr ;
return $obj ;
}
sub c_get_db_stream
{
my $cursor = shift ;
my $addr = $cursor->_c_get_db_stream(@_);
my $obj ;
$obj = bless [$addr, $cursor] , "BerkeleyDB::DbStream" if $addr ;
return $obj ;
}
sub db_stream
{
my $db = shift ;
my ($addr) = $db->_db_stream(@_) ;
my $obj ;
$obj = bless [$addr, $db] , "BerkeleyDB::DbStream" if $addr ;
return $obj ;
}
#sub gdbs
#{
# my $cursor = shift ;
#
# my $k = '';
# my $v = '';
# $db->partial_set(0,0) ;
# ok $cursor->c_get($k, $v, DB_FIRST) == 0, "set cursor"
# or diag "Status is [" . $cursor->status() . "]";
# $db->partial_clear() ;
# is $k, "1";
#}
sub DESTROY
{
my $self = shift ;
$self->_DESTROY() ;
}
BerkeleyDB.pm view on Meta::CPAN
sub BerkeleyDB::Common::cds_lock
{
my $db = shift ;
# fatal error if database not opened in CDS mode
croak("CDS not enabled for this database\n")
if ! $db->cds_enabled();
if ( ! defined $Object{"$db"})
{
$Object{"$db"} = $db->_db_write_cursor()
|| return undef ;
}
++ $Count{"$db"} ;
return bless [$db, 1], "BerkeleyDB::CDS::Lock" ;
}
sub cds_unlock
{
BerkeleyDB.pod view on Meta::CPAN
$status = $db->get_blob_dir($dir) ;
$bool = $env->cds_enabled();
$bool = $db->cds_enabled();
$lock = $db->cds_lock();
$lock->cds_unlock();
($flag, $old_offset, $old_length) = $db->partial_set($offset, $length) ;
($flag, $old_offset, $old_length) = $db->partial_clear() ;
$cursor = $db->db_cursor([$flags]) ;
$newcursor = $cursor->c_dup([$flags]);
$status = $cursor->c_get() ;
$status = $cursor->c_put() ;
$status = $cursor->c_del() ;
$status = $cursor->c_count() ;
$status = $cursor->c_pget() ;
$status = $cursor->status() ;
$status = $cursor->c_close() ;
$stream = $cursor->db_stream() ;
$cursor = $db->db_join() ;
$status = $cursor->c_get() ;
$status = $cursor->c_close() ;
$status = $stream->size($S);
$status = $stream->read($data, $offset, $size);
$status = $stream->write($data, $offset);
$status = $env->txn_checkpoint()
$hash_ref = $env->txn_stat()
$status = $env->set_mutexlocks()
$status = $env->set_flags()
$status = $env->set_timeout()
BerkeleyDB.pod view on Meta::CPAN
that the interface provided here to be identical to the Berkeley DB
interface. The main changes have been to make the Berkeley DB API work
in a Perl way. Note that if you are using Berkeley DB 2.x, the new
features available in Berkeley DB 3.x or later are not available via
this module.
The reader is expected to be familiar with the Berkeley DB
documentation. Where the interface provided here is identical to the
Berkeley DB library and the... TODO
The B<db_appinit>, B<db_cursor>, B<db_open> and B<db_txn> man pages are
particularly relevant.
The interface to Berkeley DB is implemented with a number of Perl
classes.
=head1 The BerkeleyDB::Env Class
The B<BerkeleyDB::Env> class provides an interface to the Berkeley DB
function B<db_appinit> in Berkeley DB 2.x or B<db_env_create> and
B<DBENV-E<gt>open> in Berkeley DB 3.x (or later). Its purpose is to initialise a
BerkeleyDB.pod view on Meta::CPAN
$db->db_put("tomato", "red") ;
# Check for existence of a key
print "Banana Exists\n\n" if $db->db_get("banana", $v) == 0;
# Delete a key/value pair.
$db->db_del("apple") ;
# print the contents of the file
my ($k, $v) = ("", "") ;
my $cursor = $db->db_cursor() ;
while ($cursor->c_get($k, $v, DB_NEXT) == 0)
{ print "$k -> $v\n" }
undef $cursor ;
undef $db ;
=head2 Duplicate keys
The code below is a variation on the examples above. This time the hash has
been inverted. The key this time is colour and the value is the fruit name.
The B<DB_DUP> flag has been specified to allow duplicates.
use strict ;
use BerkeleyDB ;
BerkeleyDB.pod view on Meta::CPAN
# Add a few key/value pairs to the file
$db->db_put("red", "apple") ;
$db->db_put("orange", "orange") ;
$db->db_put("green", "banana") ;
$db->db_put("yellow", "banana") ;
$db->db_put("red", "tomato") ;
$db->db_put("green", "apple") ;
# print the contents of the file
my ($k, $v) = ("", "") ;
my $cursor = $db->db_cursor() ;
while ($cursor->c_get($k, $v, DB_NEXT) == 0)
{ print "$k -> $v\n" }
undef $cursor ;
undef $db ;
here is the output:
orange -> orange
yellow -> banana
red -> apple
red -> tomato
green -> banana
green -> apple
BerkeleyDB.pod view on Meta::CPAN
# Add a few key/value pairs to the file
$db->db_put("red", "apple") ;
$db->db_put("orange", "orange") ;
$db->db_put("green", "banana") ;
$db->db_put("yellow", "banana") ;
$db->db_put("red", "tomato") ;
$db->db_put("green", "apple") ;
# print the contents of the file
my ($k, $v) = ("", "") ;
my $cursor = $db->db_cursor() ;
while ($cursor->c_get($k, $v, DB_NEXT) == 0)
{ print "$k -> $v\n" }
undef $cursor ;
undef $db ;
Notice that in the output below the duplicate values are sorted.
orange -> orange
yellow -> banana
red -> apple
red -> tomato
green -> apple
green -> banana
BerkeleyDB.pod view on Meta::CPAN
If the C<MsgFile> option is specified the output will be sent to the
file. Otherwise output is sent to standard output.
This option requires Berkeley DB 4.3 or better.
=head2 $status = $db->db_sync()
If any parts of the database are in memory, write them to the database.
=head2 $cursor = $db->db_cursor([$flags])
Creates a cursor object. This is used to access the contents of the
database sequentially. See L<CURSORS> for details of the methods
available when working with cursors.
The B<$flags> parameter is optional. If present it must be set to B<one>
of the following values:
=over 5
=item B<DB_RMW>
TODO.
BerkeleyDB.pod view on Meta::CPAN
# for ... set $$value and set $$changed to 1
return 0;
}
$foreign_db->associate_foreign($secondary, \&foreign_cb, DB_FOREIGN_NULLIFY);
=head1 CURSORS
A cursor is used whenever you want to access the contents of a database
in sequential order.
A cursor object is created with the C<db_cursor>
A cursor object has the following methods available:
=head2 $newcursor = $cursor->c_dup($flags)
Creates a duplicate of C<$cursor>. This method needs Berkeley DB 3.0.x or better.
The C<$flags> parameter is optional and can take the following value:
=over 5
=item DB_POSITION
When present this flag will position the new cursor at the same place as the
existing cursor.
=back
=head2 $status = $cursor->c_get($key, $value, $flags)
Reads a key/value pair from the database, returning the data in C<$key>
and C<$value>. The key/value pair actually read is controlled by the
C<$flags> parameter, which can take B<one> of the following values:
=over 5
=item B<DB_FIRST>
Set the cursor to point to the first key/value pair in the
database. Return the key/value pair in C<$key> and C<$value>.
=item B<DB_LAST>
Set the cursor to point to the last key/value pair in the database. Return
the key/value pair in C<$key> and C<$value>.
=item B<DB_NEXT>
If the cursor is already pointing to a key/value pair, it will be
incremented to point to the next key/value pair and return its contents.
If the cursor isn't initialised, B<DB_NEXT> works just like B<DB_FIRST>.
If the cursor is already positioned at the last key/value pair, B<c_get>
will return B<DB_NOTFOUND>.
=item B<DB_NEXT_DUP>
This flag is only valid when duplicate keys have been enabled in
a database.
If the cursor is already pointing to a key/value pair and the key of
the next key/value pair is identical, the cursor will be incremented to
point to it and their contents returned.
=item B<DB_PREV>
If the cursor is already pointing to a key/value pair, it will be
decremented to point to the previous key/value pair and return its
contents.
If the cursor isn't initialised, B<DB_PREV> works just like B<DB_LAST>.
If the cursor is already positioned at the first key/value pair, B<c_get>
will return B<DB_NOTFOUND>.
=item B<DB_CURRENT>
If the cursor has been set to point to a key/value pair, return their
contents.
If the key/value pair referenced by the cursor has been deleted, B<c_get>
will return B<DB_KEYEMPTY>.
=item B<DB_SET>
Set the cursor to point to the key/value pair referenced by B<$key>
and return the value in B<$value>.
=item B<DB_SET_RANGE>
This flag is a variation on the B<DB_SET> flag. As well as returning
the value, it also returns the key, via B<$key>.
When used with a B<BerkeleyDB::Btree> database the key matched by B<c_get>
will be the shortest key (in length) which is greater than or equal to
the key supplied, via B<$key>. This allows partial key searches.
See ??? for an example of how to use this flag.
BerkeleyDB.pod view on Meta::CPAN
the B<$flags> parameter:
=over 5
=item B<DB_RMW>
TODO.
=back
=head2 $status = $cursor->c_put($key, $value, $flags)
Stores the key/value pair in the database. The position that the data is
stored in the database is controlled by the C<$flags> parameter, which
must take B<one> of the following values:
=over 5
=item B<DB_AFTER>
When used with a Btree or Hash database, a duplicate of the key referenced
by the current cursor position will be created and the contents of
B<$value> will be associated with it - B<$key> is ignored.
The new key/value pair will be stored immediately after the current
cursor position.
Obviously the database has to have been opened with B<DB_DUP>.
When used with a Recno ... TODO
=item B<DB_BEFORE>
When used with a Btree or Hash database, a duplicate of the key referenced
by the current cursor position will be created and the contents of
B<$value> will be associated with it - B<$key> is ignored.
The new key/value pair will be stored immediately before the current
cursor position.
Obviously the database has to have been opened with B<DB_DUP>.
When used with a Recno ... TODO
=item B<DB_CURRENT>
If the cursor has been initialised, replace the value of the key/value
pair stored in the database with the contents of B<$value>.
=item B<DB_KEYFIRST>
Only valid with a Btree or Hash database. This flag is only really
used when duplicates are enabled in the database and sorted duplicates
haven't been specified.
In this case the key/value pair will be inserted as the first entry in
the duplicates for the particular key.
=item B<DB_KEYLAST>
Only valid with a Btree or Hash database. This flag is only really
used when duplicates are enabled in the database and sorted duplicates
haven't been specified.
In this case the key/value pair will be inserted as the last entry in
the duplicates for the particular key.
=back
=head2 $status = $cursor->c_del([$flags])
This method deletes the key/value pair associated with the current cursor
position. The cursor position will not be changed by this operation, so
any subsequent cursor operation must first initialise the cursor to
point to a valid key/value pair.
If the key/value pair associated with the cursor have already been
deleted, B<c_del> will return B<DB_KEYEMPTY>.
The B<$flags> parameter is not used at present.
=head2 $status = $cursor->c_count($cnt [, $flags])
Stores the number of duplicates at the current cursor position in B<$cnt>.
The B<$flags> parameter is not used at present. This method needs
Berkeley DB 3.1 or better.
=head2 $status = $cursor->status()
Returns the status of the last cursor method as a dual type.
=head2 $status = $cursor->c_pget() ;
See C<db_pget>
=head2 $status = $cursor->c_close()
Closes the cursor B<$cursor>.
=head2 $stream = $cursor->db_stream($flags);
Create a BerkeleyDB::DbStream object to read the blob at the current cursor location.
See L<Blob> for details of the the BerkeleyDB::DbStream object.
$flags must be one or more of the following OR'ed together
DB_STREAM_READ
DB_STREAM_WRITE
DB_STREAM_SYNC_WRITE
For full information on the flags refer to the Berkeley DB Reference Guide.
BerkeleyDB.pod view on Meta::CPAN
After committing or aborting a child transaction you need to set the active
transaction again using C<Txn>.
=head1 BerkeleyDBB::DbStream -- support for BLOB
Blob support is available in Berkeley DB starting with version 6.0. Refer
to the section "Blob Support" in the Berkeley DB Programmer Reference for
details of how Blob supports works.
A Blob is access via a BerkeleyDBB::DbStream object. This is created via a
cursor object.
# Note - error handling not shown below.
# Set the key we want
my $k = "some key";
# Don't want the value retrieved by the cursor,
# so use partial_set to make sure no data is retrieved.
my $v = '';
$cursor->partial_set(0,0) ;
$cursor->c_get($k, $v, DB_SET) ;
$cursor->partial_clear() ;
# Now create a stream to the blob
my $stream = $cursor->db_stream(DB_STREAM_WRITE) ;
# get the size of the blob
$stream->size(my $s) ;
# Read the first 1k of data from the blob
my $data ;
$stream->read($data, 0, 1024);
A BerkeleyDB::DbStream object has the following methods available:
BerkeleyDB.pod view on Meta::CPAN
Example
Below is an example of how to walk through a database when you don't know
beforehand which entries are blobs and which are not.
while (1)
{
my $k = '';
my $v = '';
$cursor->partial_set(0,0) ;
my $status = $cursor->c_get($k, $v, DB_NEXT) ;
$cursor->partial_clear();
last if $status != 0 ;
my $stream = $cursor->db_stream(DB_STREAM_WRITE);
if (defined $stream)
{
# It's a Blob
$stream->size(my $s) ;
}
else
{
# Not a Blob
$cursor->c_get($k, $v, DB_CURRENT) ;
}
}
=head1 Berkeley DB Concurrent Data Store (CDS)
The Berkeley DB I<Concurrent Data Store> (CDS) is a lightweight locking
mechanism that is useful in scenarios where transactions are overkill.
=head2 What is CDS?
BerkeleyDB.pod view on Meta::CPAN
Multiple processes with read locks can all access the database at the same
time as long as no process has a write lock. A process with a write lock
can only access the database if there are no other active read or write
locks.
The majority of the time the Berkeley DB CDS mode will handle all locking
without your application having to do anything. There are a couple of
exceptions you need to be aware of though - these will be discussed in
L<Safely Updating Records> and L<Implicit Cursors> below.
A Berkeley DB Cursor (created with C<< $db->db_cursor >>) will by hold a
lock on the database until it is either explicitly closed or destroyed.
This means the lock has the potential to be long lived.
By default Berkeley DB cursors create a read lock, but it is possible to
create a cursor that holds a write lock, thus
$cursor = $db->db_cursor(DB_WRITECURSOR);
Whilst either a read or write cursor is active, it will block any other
processes that wants to write to the database.
To avoid blocking problems, only keep cursors open as long as they are
needed. The same is true when you use the C<cursor> method or the
C<cds_lock> method.
For full information on CDS see the "Berkeley DB Concurrent Data Store
applications" section in the Berkeley DB Reference Guide.
=head2 Opening a database for CDS
Here is the typical signature that is used when opening a database in CDS
mode.
BerkeleyDB.pod view on Meta::CPAN
$db->db_get("Counter", $value);
++ $value ;
$db->db_put("Counter", $value);
$lk->unlock;
The C<cds_lock> method will ensure that the current process has exclusive
access to the database until the lock is either explicitly released, via
the C<< $lk->cds_unlock() >> or by the lock object being destroyed.
If you are interested, all that C<cds_lock> does is open a "write" cursor.
This has the useful side-effect of holding a write-lock on the database
until the cursor is deleted. This is how you create a write-cursor
$cursor = $db->db_cursor(DB_WRITECURSOR);
If you have instantiated multiple C<cds_lock> objects for one database
within a single process, that process will hold a write-lock on the
database until I<ALL> C<cds_lock> objects have been destroyed.
As with all write-cursors, you should try to limit the scope of the
C<cds_lock> to as short a time as possible. Remember the complete database
will be locked to other process whilst the write lock is in place.
=head2 Cannot write with a read cursor while a write cursor is active
This issue is easier to demonstrate with an example, so consider the code
below. The intention of the code is to increment the values of all the
elements in a database by one.
# Assume $db is a database opened in a CDS environment.
# Create a write-lock
my $lock = $db->db_cursor(DB_WRITECURSOR);
# or
# my $lock = $db->cds_lock();
my $cursor = $db->db_cursor();
# Now loop through the database, and increment
# each value using c_put.
while ($cursor->c_get($key, $value, DB_NEXT) == 0)
{
$cursor->c_put($key, $value+1, DB_CURRENT) == 0
or die "$BerkeleyDB::Error\n";
}
When this code is run, it will fail on the C<c_put> line with this error
Write attempted on read-only cursor
The read cursor has automatically disallowed a write operation to prevent a
deadlock.
So the rule is -- you B<CANNOT> carry out a write operation using a
read-only cursor (i.e. you cannot use C<c_put> or C<c_del>) whilst another
write-cursor is already active.
The workaround for this issue is to just use C<db_put> instead of C<c_put>,
like this
# Assume $db is a database opened in a CDS environment.
# Create a write-lock
my $lock = $db->db_cursor(DB_WRITECURSOR);
# or
# my $lock = $db->cds_lock();
my $cursor = $db->db_cursor();
# Now loop through the database, and increment
# each value using c_put.
while ($cursor->c_get($key, $value, DB_NEXT) == 0)
{
$db->db_put($key, $value+1) == 0
or die "$BerkeleyDB::Error\n";
}
=head2 Implicit Cursors
All Berkeley DB cursors will hold either a read lock or a write lock on the
database for the existence of the cursor. In order to prevent blocking of
other processes you need to make sure that they are not long lived.
There are a number of instances where the Perl interface to Berkeley DB
will create a cursor behind the scenes without you being aware of it. Most
of these are very short-lived and will not affect the running of your
script, but there are a few notable exceptions.
Consider this snippet of code
while (my ($k, $v) = each %hash)
{
# do something
}
To implement the "each" functionality, a read cursor will be created behind
the scenes to allow you to iterate through the tied hash, C<%hash>. While
that cursor is still active, a read lock will obviously be held against the
database. If your application has any other writing processes, these will
be blocked until the read cursor is closed. That won't happen until the
loop terminates.
To avoid blocking problems, only keep cursors open as long as they are
needed. The same is true when you use the C<cursor> method or the
C<cds_lock> method.
The locking behaviour of the C<values> or C<keys> functions, shown below,
is subtly different.
foreach my $k (keys %hash)
{
# do something
}
foreach my $v (values %hash)
{
# do something
}
Just as in the C<each> function, a read cursor will be created to iterate
over the database in both of these cases. Where C<keys> and C<values>
differ is the place where the cursor carries out the iteration through the
database. Whilst C<each> carried out a single iteration every time it was
invoked, the C<keys> and C<values> functions will iterate through the
entire database in one go -- the complete database will be read into memory
before the first iteration of the loop.
Apart from the fact that a read lock will be held for the amount of time
required to iterate through the database, the use of C<keys> and C<values>
is B<not> recommended because it will result in the complete database being
read into memory.
BerkeleyDB.pod.P view on Meta::CPAN
$status = $db->get_blob_dir($dir) ;
$bool = $env->cds_enabled();
$bool = $db->cds_enabled();
$lock = $db->cds_lock();
$lock->cds_unlock();
($flag, $old_offset, $old_length) = $db->partial_set($offset, $length) ;
($flag, $old_offset, $old_length) = $db->partial_clear() ;
$cursor = $db->db_cursor([$flags]) ;
$newcursor = $cursor->c_dup([$flags]);
$status = $cursor->c_get() ;
$status = $cursor->c_put() ;
$status = $cursor->c_del() ;
$status = $cursor->c_count() ;
$status = $cursor->c_pget() ;
$status = $cursor->status() ;
$status = $cursor->c_close() ;
$stream = $cursor->db_stream() ;
$cursor = $db->db_join() ;
$status = $cursor->c_get() ;
$status = $cursor->c_close() ;
$status = $stream->size($S);
$status = $stream->read($data, $offset, $size);
$status = $stream->write($data, $offset);
$status = $env->txn_checkpoint()
$hash_ref = $env->txn_stat()
$status = $env->set_mutexlocks()
$status = $env->set_flags()
$status = $env->set_timeout()
BerkeleyDB.pod.P view on Meta::CPAN
that the interface provided here to be identical to the Berkeley DB
interface. The main changes have been to make the Berkeley DB API work
in a Perl way. Note that if you are using Berkeley DB 2.x, the new
features available in Berkeley DB 3.x or later are not available via
this module.
The reader is expected to be familiar with the Berkeley DB
documentation. Where the interface provided here is identical to the
Berkeley DB library and the... TODO
The B<db_appinit>, B<db_cursor>, B<db_open> and B<db_txn> man pages are
particularly relevant.
The interface to Berkeley DB is implemented with a number of Perl
classes.
=head1 The BerkeleyDB::Env Class
The B<BerkeleyDB::Env> class provides an interface to the Berkeley DB
function B<db_appinit> in Berkeley DB 2.x or B<db_env_create> and
B<DBENV-E<gt>open> in Berkeley DB 3.x (or later). Its purpose is to initialise a
BerkeleyDB.pod.P view on Meta::CPAN
If the C<MsgFile> option is specified the output will be sent to the
file. Otherwise output is sent to standard output.
This option requires Berkeley DB 4.3 or better.
=head2 $status = $db->db_sync()
If any parts of the database are in memory, write them to the database.
=head2 $cursor = $db->db_cursor([$flags])
Creates a cursor object. This is used to access the contents of the
database sequentially. See L<CURSORS> for details of the methods
available when working with cursors.
The B<$flags> parameter is optional. If present it must be set to B<one>
of the following values:
=over 5
=item B<DB_RMW>
TODO.
BerkeleyDB.pod.P view on Meta::CPAN
# for ... set $$value and set $$changed to 1
return 0;
}
$foreign_db->associate_foreign($secondary, \&foreign_cb, DB_FOREIGN_NULLIFY);
=head1 CURSORS
A cursor is used whenever you want to access the contents of a database
in sequential order.
A cursor object is created with the C<db_cursor>
A cursor object has the following methods available:
=head2 $newcursor = $cursor->c_dup($flags)
Creates a duplicate of C<$cursor>. This method needs Berkeley DB 3.0.x or better.
The C<$flags> parameter is optional and can take the following value:
=over 5
=item DB_POSITION
When present this flag will position the new cursor at the same place as the
existing cursor.
=back
=head2 $status = $cursor->c_get($key, $value, $flags)
Reads a key/value pair from the database, returning the data in C<$key>
and C<$value>. The key/value pair actually read is controlled by the
C<$flags> parameter, which can take B<one> of the following values:
=over 5
=item B<DB_FIRST>
Set the cursor to point to the first key/value pair in the
database. Return the key/value pair in C<$key> and C<$value>.
=item B<DB_LAST>
Set the cursor to point to the last key/value pair in the database. Return
the key/value pair in C<$key> and C<$value>.
=item B<DB_NEXT>
If the cursor is already pointing to a key/value pair, it will be
incremented to point to the next key/value pair and return its contents.
If the cursor isn't initialised, B<DB_NEXT> works just like B<DB_FIRST>.
If the cursor is already positioned at the last key/value pair, B<c_get>
will return B<DB_NOTFOUND>.
=item B<DB_NEXT_DUP>
This flag is only valid when duplicate keys have been enabled in
a database.
If the cursor is already pointing to a key/value pair and the key of
the next key/value pair is identical, the cursor will be incremented to
point to it and their contents returned.
=item B<DB_PREV>
If the cursor is already pointing to a key/value pair, it will be
decremented to point to the previous key/value pair and return its
contents.
If the cursor isn't initialised, B<DB_PREV> works just like B<DB_LAST>.
If the cursor is already positioned at the first key/value pair, B<c_get>
will return B<DB_NOTFOUND>.
=item B<DB_CURRENT>
If the cursor has been set to point to a key/value pair, return their
contents.
If the key/value pair referenced by the cursor has been deleted, B<c_get>
will return B<DB_KEYEMPTY>.
=item B<DB_SET>
Set the cursor to point to the key/value pair referenced by B<$key>
and return the value in B<$value>.
=item B<DB_SET_RANGE>
This flag is a variation on the B<DB_SET> flag. As well as returning
the value, it also returns the key, via B<$key>.
When used with a B<BerkeleyDB::Btree> database the key matched by B<c_get>
will be the shortest key (in length) which is greater than or equal to
the key supplied, via B<$key>. This allows partial key searches.
See ??? for an example of how to use this flag.
BerkeleyDB.pod.P view on Meta::CPAN
the B<$flags> parameter:
=over 5
=item B<DB_RMW>
TODO.
=back
=head2 $status = $cursor->c_put($key, $value, $flags)
Stores the key/value pair in the database. The position that the data is
stored in the database is controlled by the C<$flags> parameter, which
must take B<one> of the following values:
=over 5
=item B<DB_AFTER>
When used with a Btree or Hash database, a duplicate of the key referenced
by the current cursor position will be created and the contents of
B<$value> will be associated with it - B<$key> is ignored.
The new key/value pair will be stored immediately after the current
cursor position.
Obviously the database has to have been opened with B<DB_DUP>.
When used with a Recno ... TODO
=item B<DB_BEFORE>
When used with a Btree or Hash database, a duplicate of the key referenced
by the current cursor position will be created and the contents of
B<$value> will be associated with it - B<$key> is ignored.
The new key/value pair will be stored immediately before the current
cursor position.
Obviously the database has to have been opened with B<DB_DUP>.
When used with a Recno ... TODO
=item B<DB_CURRENT>
If the cursor has been initialised, replace the value of the key/value
pair stored in the database with the contents of B<$value>.
=item B<DB_KEYFIRST>
Only valid with a Btree or Hash database. This flag is only really
used when duplicates are enabled in the database and sorted duplicates
haven't been specified.
In this case the key/value pair will be inserted as the first entry in
the duplicates for the particular key.
=item B<DB_KEYLAST>
Only valid with a Btree or Hash database. This flag is only really
used when duplicates are enabled in the database and sorted duplicates
haven't been specified.
In this case the key/value pair will be inserted as the last entry in
the duplicates for the particular key.
=back
=head2 $status = $cursor->c_del([$flags])
This method deletes the key/value pair associated with the current cursor
position. The cursor position will not be changed by this operation, so
any subsequent cursor operation must first initialise the cursor to
point to a valid key/value pair.
If the key/value pair associated with the cursor have already been
deleted, B<c_del> will return B<DB_KEYEMPTY>.
The B<$flags> parameter is not used at present.
=head2 $status = $cursor->c_count($cnt [, $flags])
Stores the number of duplicates at the current cursor position in B<$cnt>.
The B<$flags> parameter is not used at present. This method needs
Berkeley DB 3.1 or better.
=head2 $status = $cursor->status()
Returns the status of the last cursor method as a dual type.
=head2 $status = $cursor->c_pget() ;
See C<db_pget>
=head2 $status = $cursor->c_close()
Closes the cursor B<$cursor>.
=head2 $stream = $cursor->db_stream($flags);
Create a BerkeleyDB::DbStream object to read the blob at the current cursor location.
See L<Blob> for details of the the BerkeleyDB::DbStream object.
$flags must be one or more of the following OR'ed together
DB_STREAM_READ
DB_STREAM_WRITE
DB_STREAM_SYNC_WRITE
For full information on the flags refer to the Berkeley DB Reference Guide.
BerkeleyDB.pod.P view on Meta::CPAN
After committing or aborting a child transaction you need to set the active
transaction again using C<Txn>.
=head1 BerkeleyDBB::DbStream -- support for BLOB
Blob support is available in Berkeley DB starting with version 6.0. Refer
to the section "Blob Support" in the Berkeley DB Programmer Reference for
details of how Blob supports works.
A Blob is access via a BerkeleyDBB::DbStream object. This is created via a
cursor object.
# Note - error handling not shown below.
# Set the key we want
my $k = "some key";
# Don't want the value retrieved by the cursor,
# so use partial_set to make sure no data is retrieved.
my $v = '';
$cursor->partial_set(0,0) ;
$cursor->c_get($k, $v, DB_SET) ;
$cursor->partial_clear() ;
# Now create a stream to the blob
my $stream = $cursor->db_stream(DB_STREAM_WRITE) ;
# get the size of the blob
$stream->size(my $s) ;
# Read the first 1k of data from the blob
my $data ;
$stream->read($data, 0, 1024);
A BerkeleyDB::DbStream object has the following methods available:
BerkeleyDB.pod.P view on Meta::CPAN
Example
Below is an example of how to walk through a database when you don't know
beforehand which entries are blobs and which are not.
while (1)
{
my $k = '';
my $v = '';
$cursor->partial_set(0,0) ;
my $status = $cursor->c_get($k, $v, DB_NEXT) ;
$cursor->partial_clear();
last if $status != 0 ;
my $stream = $cursor->db_stream(DB_STREAM_WRITE);
if (defined $stream)
{
# It's a Blob
$stream->size(my $s) ;
}
else
{
# Not a Blob
$cursor->c_get($k, $v, DB_CURRENT) ;
}
}
=head1 Berkeley DB Concurrent Data Store (CDS)
The Berkeley DB I<Concurrent Data Store> (CDS) is a lightweight locking
mechanism that is useful in scenarios where transactions are overkill.
=head2 What is CDS?
BerkeleyDB.pod.P view on Meta::CPAN
Multiple processes with read locks can all access the database at the same
time as long as no process has a write lock. A process with a write lock
can only access the database if there are no other active read or write
locks.
The majority of the time the Berkeley DB CDS mode will handle all locking
without your application having to do anything. There are a couple of
exceptions you need to be aware of though - these will be discussed in
L<Safely Updating Records> and L<Implicit Cursors> below.
A Berkeley DB Cursor (created with C<< $db->db_cursor >>) will by hold a
lock on the database until it is either explicitly closed or destroyed.
This means the lock has the potential to be long lived.
By default Berkeley DB cursors create a read lock, but it is possible to
create a cursor that holds a write lock, thus
$cursor = $db->db_cursor(DB_WRITECURSOR);
Whilst either a read or write cursor is active, it will block any other
processes that wants to write to the database.
To avoid blocking problems, only keep cursors open as long as they are
needed. The same is true when you use the C<cursor> method or the
C<cds_lock> method.
For full information on CDS see the "Berkeley DB Concurrent Data Store
applications" section in the Berkeley DB Reference Guide.
=head2 Opening a database for CDS
Here is the typical signature that is used when opening a database in CDS
mode.
BerkeleyDB.pod.P view on Meta::CPAN
$db->db_get("Counter", $value);
++ $value ;
$db->db_put("Counter", $value);
$lk->unlock;
The C<cds_lock> method will ensure that the current process has exclusive
access to the database until the lock is either explicitly released, via
the C<< $lk->cds_unlock() >> or by the lock object being destroyed.
If you are interested, all that C<cds_lock> does is open a "write" cursor.
This has the useful side-effect of holding a write-lock on the database
until the cursor is deleted. This is how you create a write-cursor
$cursor = $db->db_cursor(DB_WRITECURSOR);
If you have instantiated multiple C<cds_lock> objects for one database
within a single process, that process will hold a write-lock on the
database until I<ALL> C<cds_lock> objects have been destroyed.
As with all write-cursors, you should try to limit the scope of the
C<cds_lock> to as short a time as possible. Remember the complete database
will be locked to other process whilst the write lock is in place.
=head2 Cannot write with a read cursor while a write cursor is active
This issue is easier to demonstrate with an example, so consider the code
below. The intention of the code is to increment the values of all the
elements in a database by one.
# Assume $db is a database opened in a CDS environment.
# Create a write-lock
my $lock = $db->db_cursor(DB_WRITECURSOR);
# or
# my $lock = $db->cds_lock();
my $cursor = $db->db_cursor();
# Now loop through the database, and increment
# each value using c_put.
while ($cursor->c_get($key, $value, DB_NEXT) == 0)
{
$cursor->c_put($key, $value+1, DB_CURRENT) == 0
or die "$BerkeleyDB::Error\n";
}
When this code is run, it will fail on the C<c_put> line with this error
Write attempted on read-only cursor
The read cursor has automatically disallowed a write operation to prevent a
deadlock.
So the rule is -- you B<CANNOT> carry out a write operation using a
read-only cursor (i.e. you cannot use C<c_put> or C<c_del>) whilst another
write-cursor is already active.
The workaround for this issue is to just use C<db_put> instead of C<c_put>,
like this
# Assume $db is a database opened in a CDS environment.
# Create a write-lock
my $lock = $db->db_cursor(DB_WRITECURSOR);
# or
# my $lock = $db->cds_lock();
my $cursor = $db->db_cursor();
# Now loop through the database, and increment
# each value using c_put.
while ($cursor->c_get($key, $value, DB_NEXT) == 0)
{
$db->db_put($key, $value+1) == 0
or die "$BerkeleyDB::Error\n";
}
=head2 Implicit Cursors
All Berkeley DB cursors will hold either a read lock or a write lock on the
database for the existence of the cursor. In order to prevent blocking of
other processes you need to make sure that they are not long lived.
There are a number of instances where the Perl interface to Berkeley DB
will create a cursor behind the scenes without you being aware of it. Most
of these are very short-lived and will not affect the running of your
script, but there are a few notable exceptions.
Consider this snippet of code
while (my ($k, $v) = each %hash)
{
# do something
}
To implement the "each" functionality, a read cursor will be created behind
the scenes to allow you to iterate through the tied hash, C<%hash>. While
that cursor is still active, a read lock will obviously be held against the
database. If your application has any other writing processes, these will
be blocked until the read cursor is closed. That won't happen until the
loop terminates.
To avoid blocking problems, only keep cursors open as long as they are
needed. The same is true when you use the C<cursor> method or the
C<cds_lock> method.
The locking behaviour of the C<values> or C<keys> functions, shown below,
is subtly different.
foreach my $k (keys %hash)
{
# do something
}
foreach my $v (values %hash)
{
# do something
}
Just as in the C<each> function, a read cursor will be created to iterate
over the database in both of these cases. Where C<keys> and C<values>
differ is the place where the cursor carries out the iteration through the
database. Whilst C<each> carried out a single iteration every time it was
invoked, the C<keys> and C<values> functions will iterate through the
entire database in one go -- the complete database will be read into memory
before the first iteration of the loop.
Apart from the fact that a read lock will be held for the amount of time
required to iterate through the database, the use of C<keys> and C<values>
is B<not> recommended because it will result in the complete database being
read into memory.
BerkeleyDB.xs view on Meta::CPAN
bool secondary_db ;
#endif
#ifdef AT_LEAST_DB_4_8
SV * associated_foreign ;
SV * bt_compress ;
SV * bt_uncompress ;
#endif
bool primary_recno_or_queue ;
int Status ;
DB_INFO * info ;
DBC * cursor ;
DB_TXN * txn ;
int open_cursors ;
#ifdef AT_LEAST_DB_4_3
int open_sequences ;
#endif
u_int32_t partial ;
u_int32_t dlen ;
u_int32_t doff ;
int active ;
bool cds_enabled;
#ifdef ALLOW_RECNO_OFFSET
int array_base ;
BerkeleyDB.xs view on Meta::CPAN
#ifdef AT_LEAST_DB_3_3
SV * associated ;
bool secondary_db ;
#endif
#ifdef AT_LEAST_DB_4_8
SV * associated_foreign ;
#endif
bool primary_recno_or_queue ;
int Status ;
DB_INFO * info ;
DBC * cursor ;
DB_TXN * txn ;
BerkeleyDB_type * parent_db ;
u_int32_t partial ;
u_int32_t dlen ;
u_int32_t doff ;
int active ;
bool cds_enabled;
#ifdef ALLOW_RECNO_OFFSET
int array_base ;
#endif
BerkeleyDB.xs view on Meta::CPAN
/* Close All Cursors */
{
BerkeleyDB__Cursor db ;
HE * he ;
I32 len ;
HV * hv = perl_get_hv("BerkeleyDB::Term::Cursor", TRUE);
int all = 0 ;
int closed = 0 ;
(void) hv_iterinit(hv) ;
Trace(("BerkeleyDB::Term::close_all_cursors \n")) ;
while ( (he = hv_iternext(hv)) ) {
db = * (BerkeleyDB__Cursor*) hv_iterkey(he, &len) ;
Trace((" Closing Cursor [%p] in [%p] Active [%d]\n", db->cursor, db, db->active));
if (db->active) {
((db->cursor)->c_close)(db->cursor) ;
++ closed ;
}
db->active = FALSE ;
++ all ;
}
Trace(("End of BerkeleyDB::Term::close_all_cursors closed %d of %d cursors\n",closed, all)) ;
}
/* Close All Databases */
{
BerkeleyDB db ;
HE * he ;
I32 len ;
HV * hv = perl_get_hv("BerkeleyDB::Term::Db", TRUE);
int all = 0 ;
int closed = 0 ;
BerkeleyDB.xs view on Meta::CPAN
static void
destroyDB(BerkeleyDB db)
{
#ifdef dTHX
dTHX;
#endif
if (! PL_dirty && db->active) {
if (db->parent_env && db->parent_env->open_dbs)
-- db->parent_env->open_dbs ;
-- db->open_cursors ;
((db->dbp)->close)(db->dbp, 0) ;
}
if (db->hash)
SvREFCNT_dec(db->hash) ;
if (db->compare)
SvREFCNT_dec(db->compare) ;
if (db->dup_compare)
SvREFCNT_dec(db->dup_compare) ;
#ifdef AT_LEAST_DB_3_3
if (db->associated && !db->secondary_db)
BerkeleyDB.xs view on Meta::CPAN
static I32
GetArrayLength(BerkeleyDB db)
{
I32 RETVAL = 0 ;
#ifndef AT_LEAST_DB_3_1
DBT key ;
DBT value ;
DBC * cursor ;
DBT_clear(key) ;
DBT_clear(value) ;
#if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 6
if ( ((db->dbp)->cursor)(db->dbp, db->txn, &cursor) == 0 )
#else
if ( ((db->dbp)->cursor)(db->dbp, db->txn, &cursor, 0) == 0 )
#endif
{
RETVAL = cursor->c_get(cursor, &key, &value, DB_LAST) ;
if (RETVAL == 0)
RETVAL = *(I32 *)key.data ;
else /* No key means empty file */
RETVAL = 0 ;
cursor->c_close(cursor) ;
}
Trace(("GetArrayLength got %d\n", RETVAL)) ;
return ((I32)RETVAL) ;
#else
DB_BTREE_STAT * stat ;
#ifdef AT_LEAST_DB_4_3
db->Status = ((db->dbp)->stat)(db->dbp, db->txn, &stat, 0) ;
#else
#ifdef AT_LEAST_DB_3_3
BerkeleyDB.xs view on Meta::CPAN
PREINIT:
dMY_CXT;
INIT:
ckActive_Database(db->active) ;
saveCurrentDB(db) ;
CODE:
Trace(("BerkeleyDB::Common::db_close %p\n", db));
#ifdef STRICT_CLOSE
if (db->txn)
softCrash("attempted to close a database while a transaction was still open") ;
if (db->open_cursors)
softCrash("attempted to close a database with %d open cursor(s)",
db->open_cursors) ;
#ifdef AT_LEAST_DB_4_3
if (db->open_sequences)
softCrash("attempted to close a database with %d open sequence(s)",
db->open_sequences) ;
#endif /* AT_LEAST_DB_4_3 */
#endif /* STRICT_CLOSE */
RETVAL = db->Status = ((db->dbp)->close)(db->dbp, flags) ;
if (db->parent_env && db->parent_env->open_dbs)
-- db->parent_env->open_dbs ;
db->active = FALSE ;
hash_delete("BerkeleyDB::Term::Db", (char *)db) ;
-- db->open_cursors ;
Trace(("end of BerkeleyDB::Common::db_close\n"));
OUTPUT:
RETVAL
void
dab__DESTROY(db)
BerkeleyDB::Common db
PREINIT:
dMY_CXT;
CODE:
saveCurrentDB(db) ;
Trace(("In BerkeleyDB::Common::_DESTROY db %p dirty=%d\n", db, PL_dirty)) ;
destroyDB(db) ;
Trace(("End of BerkeleyDB::Common::DESTROY \n")) ;
#if DB_VERSION_MAJOR == 2 && DB_VERSION_MINOR < 6
#define db_cursor(db, txn, cur,flags) ((db->dbp)->cursor)(db->dbp, txn, cur)
#else
#define db_cursor(db, txn, cur,flags) ((db->dbp)->cursor)(db->dbp, txn, cur,flags)
#endif
BerkeleyDB::Cursor::Raw
_db_cursor(db, flags=0)
u_int32_t flags
BerkeleyDB::Common db
BerkeleyDB::Cursor RETVAL = NULL ;
PREINIT:
dMY_CXT;
ALIAS: __db_write_cursor = 1
INIT:
ckActive_Database(db->active) ;
CODE:
{
DBC * cursor ;
saveCurrentDB(db) ;
if (ix == 1 && db->cds_enabled) {
#ifdef AT_LEAST_DB_3
flags |= DB_WRITECURSOR;
#else
flags |= DB_RMW;
#endif
}
if ((db->Status = db_cursor(db, db->txn, &cursor, flags)) == 0){
ZMALLOC(RETVAL, BerkeleyDB__Cursor_type) ;
db->open_cursors ++ ;
RETVAL->parent_db = db ;
RETVAL->cursor = cursor ;
RETVAL->dbp = db->dbp ;
RETVAL->txn = db->txn ;
RETVAL->type = db->type ;
RETVAL->recno_or_queue = db->recno_or_queue ;
RETVAL->cds_enabled = db->cds_enabled ;
RETVAL->filename = my_strdup(db->filename) ;
RETVAL->compare = db->compare ;
RETVAL->dup_compare = db->dup_compare ;
#ifdef AT_LEAST_DB_3_3
RETVAL->associated = db->associated ;
BerkeleyDB.xs view on Meta::CPAN
RETVAL->filter_store_value = db->filter_store_value ;
#endif
/* RETVAL->info ; */
hash_store_iv("BerkeleyDB::Term::Cursor", (char *)RETVAL, 1) ;
}
}
OUTPUT:
RETVAL
BerkeleyDB::Cursor::Raw
_db_join(db, cursors, flags=0)
u_int32_t flags
BerkeleyDB::Common db
AV * cursors
BerkeleyDB::Cursor RETVAL = NULL ;
PREINIT:
dMY_CXT;
INIT:
ckActive_Database(db->active) ;
CODE:
{
#if DB_VERSION_MAJOR == 2 && (DB_VERSION_MINOR < 5 || (DB_VERSION_MINOR == 5 && DB_VERSION_PATCH < 2))
softCrash("join needs Berkeley DB 2.5.2 or later") ;
#else /* Berkeley DB >= 2.5.2 */
DBC * join_cursor ;
DBC ** cursor_list ;
I32 count = av_len(cursors) + 1 ;
int i ;
saveCurrentDB(db) ;
if (count < 1 )
softCrash("db_join: No cursors in parameter list") ;
cursor_list = (DBC **)safemalloc(sizeof(DBC*) * (count + 1));
for (i = 0 ; i < count ; ++i) {
SV * obj = (SV*) * av_fetch(cursors, i, FALSE) ;
IV tmp = SvIV(getInnerObject(obj)) ;
BerkeleyDB__Cursor cur = INT2PTR(BerkeleyDB__Cursor, tmp);
if (cur->dbp == db->dbp)
softCrash("attempted to do a self-join");
cursor_list[i] = cur->cursor ;
}
cursor_list[i] = NULL ;
#if DB_VERSION_MAJOR == 2
if ((db->Status = ((db->dbp)->join)(db->dbp, cursor_list, flags, &join_cursor)) == 0){
#else
if ((db->Status = ((db->dbp)->join)(db->dbp, cursor_list, &join_cursor, flags)) == 0){
#endif
ZMALLOC(RETVAL, BerkeleyDB__Cursor_type) ;
db->open_cursors ++ ;
RETVAL->parent_db = db ;
RETVAL->cursor = join_cursor ;
RETVAL->dbp = db->dbp ;
RETVAL->type = db->type ;
RETVAL->filename = my_strdup(db->filename) ;
RETVAL->compare = db->compare ;
RETVAL->dup_compare = db->dup_compare ;
#ifdef AT_LEAST_DB_3_3
RETVAL->associated = db->associated ;
RETVAL->secondary_db = db->secondary_db;
RETVAL->primary_recno_or_queue = db->primary_recno_or_queue ;
#endif
BerkeleyDB.xs view on Meta::CPAN
#ifdef DBM_FILTERING
RETVAL->filtering = FALSE ;
RETVAL->filter_fetch_key = db->filter_fetch_key ;
RETVAL->filter_store_key = db->filter_store_key ;
RETVAL->filter_fetch_value = db->filter_fetch_value ;
RETVAL->filter_store_value = db->filter_store_value ;
#endif
/* RETVAL->info ; */
hash_store_iv("BerkeleyDB::Term::Cursor", (char *)RETVAL, 1) ;
}
safefree(cursor_list) ;
#endif /* Berkeley DB >= 2.5.2 */
}
OUTPUT:
RETVAL
int
ArrayOffset(db)
BerkeleyDB::Common db
PREINIT:
dMY_CXT;
BerkeleyDB.xs view on Meta::CPAN
PREINIT:
dMY_CXT;
INIT:
saveCurrentDB(db->parent_db);
ckActive_Database(db->active) ;
CODE:
{
#ifndef AT_LEAST_DB_3
softCrash("c_dup needs at least Berkeley DB 3.0.x");
#else
DBC * newcursor ;
db->Status = ((db->cursor)->c_dup)(db->cursor, &newcursor, flags) ;
if (db->Status == 0){
ZMALLOC(RETVAL, BerkeleyDB__Cursor_type) ;
db->parent_db->open_cursors ++ ;
RETVAL->parent_db = db->parent_db ;
RETVAL->cursor = newcursor ;
RETVAL->dbp = db->dbp ;
RETVAL->type = db->type ;
RETVAL->recno_or_queue = db->recno_or_queue ;
RETVAL->primary_recno_or_queue = db->primary_recno_or_queue ;
RETVAL->cds_enabled = db->cds_enabled ;
RETVAL->filename = my_strdup(db->filename) ;
RETVAL->compare = db->compare ;
RETVAL->dup_compare = db->dup_compare ;
#ifdef AT_LEAST_DB_3_3
RETVAL->associated = db->associated ;
BerkeleyDB.xs view on Meta::CPAN
_c_close(db)
BerkeleyDB::Cursor db
PREINIT:
dMY_CXT;
INIT:
saveCurrentDB(db->parent_db);
ckActive_Cursor(db->active) ;
hash_delete("BerkeleyDB::Term::Cursor", (char *)db) ;
CODE:
RETVAL = db->Status =
((db->cursor)->c_close)(db->cursor) ;
db->active = FALSE ;
if (db->parent_db->open_cursors)
-- db->parent_db->open_cursors ;
OUTPUT:
RETVAL
void
_DESTROY(db)
BerkeleyDB::Cursor db
PREINIT:
dMY_CXT;
CODE:
saveCurrentDB(db->parent_db);
Trace(("In BerkeleyDB::Cursor::_DESTROY db %p dirty=%d active=%d\n", db, PL_dirty, db->active));
hash_delete("BerkeleyDB::Term::Cursor", (char *)db) ;
if (db->active)
((db->cursor)->c_close)(db->cursor) ;
if (db->parent_db->open_cursors)
-- db->parent_db->open_cursors ;
Safefree(db->filename) ;
Safefree(db) ;
Trace(("End of BerkeleyDB::Cursor::_DESTROY\n")) ;
DualType
status(db)
BerkeleyDB::Cursor db
PREINIT:
dMY_CXT;
CODE:
RETVAL = db->Status ;
OUTPUT:
RETVAL
#define cu_c_del(c,f) (c->Status = ((c->cursor)->c_del)(c->cursor,f))
DualType
cu_c_del(db, flags=0)
int flags
BerkeleyDB::Cursor db
PREINIT:
dMY_CXT;
INIT:
saveCurrentDB(db->parent_db);
ckActive_Cursor(db->active) ;
OUTPUT:
RETVAL
#define cu_c_get(c,k,d,f) (c->Status = (c->cursor->c_get)(c->cursor,&k,&d,f))
DualType
cu_c_get(db, key, data, flags=0)
int flags
BerkeleyDB::Cursor db
DBTKEY_B key
DBT_B data
PREINIT:
dMY_CXT;
INIT:
Trace(("c_get db [%p] in [%p] flags [%d]\n", db->dbp, db, flags)) ;
BerkeleyDB.xs view on Meta::CPAN
ckActive_Cursor(db->active) ;
/* DBT_clear(key); */
/* DBT_clear(data); */
SetPartial(data,db) ;
Trace(("c_get end\n")) ;
OUTPUT:
RETVAL
key
data if (! flagSet(DB_JOIN_ITEM)) OutputValue_B(ST(2), data) ;
#define cu_c_pget(c,k,p,d,f) (c->Status = (c->secondary_db ? (c->cursor->c_pget)(c->cursor,&k,&p,&d,f) : EINVAL))
DualType
cu_c_pget(db, key, pkey, data, flags=0)
int flags
BerkeleyDB::Cursor db
DBTKEY_B key
DBTKEY_Bpr pkey
DBT_B data
PREINIT:
dMY_CXT;
CODE:
BerkeleyDB.xs view on Meta::CPAN
Trace(("c_pget end\n")) ;
#endif
OUTPUT:
RETVAL
key if (writeToKey()) OutputKey(ST(1), key) ;
pkey
data
#define cu_c_put(c,k,d,f) (c->Status = (c->cursor->c_put)(c->cursor,&k,&d,f))
DualType
cu_c_put(db, key, data, flags=0)
int flags
BerkeleyDB::Cursor db
DBTKEY key
DBT data
PREINIT:
dMY_CXT;
INIT:
saveCurrentDB(db->parent_db);
ckActive_Cursor(db->active) ;
/* SetPartial(data,db) ; */
OUTPUT:
RETVAL
#define cu_c_count(c,p,f) (c->Status = (c->cursor->c_count)(c->cursor,&p,f))
DualType
cu_c_count(db, count, flags=0)
int flags
BerkeleyDB::Cursor db
u_int32_t count = NO_INIT
PREINIT:
dMY_CXT;
CODE:
#ifndef AT_LEAST_DB_3_1
softCrash("c_count needs at least Berkeley DB 3.1.x");
BerkeleyDB.xs view on Meta::CPAN
dMY_CXT;
INIT:
saveCurrentDB(db->parent_db);
ckActive_Cursor(db->active) ;
CODE:
{
#ifndef AT_LEAST_DB_6_0
softCrash("db_stream needs at least Berkeley DB 6.0.x");
#else
DB_STREAM * stream = NULL ;
db->Status = ((db->cursor)->db_stream)(db->cursor, &stream, flags) ;
if (db->Status == 0){
ZMALLOC(RETVAL, BerkeleyDB__DbStream_type) ;
RETVAL->stream = stream ;
RETVAL->active = TRUE ;
hash_store_iv("BerkeleyDB::Term::DbStream", (char *)RETVAL, 1) ;
}
else
{
Trace(("db_stream [%s]\n", my_db_strerror(db->Status)));
}
BerkeleyDB.xs view on Meta::CPAN
ckActive_Cursor(db->active) ;
CODE:
{
#ifndef AT_LEAST_DB_6_0
softCrash("db_stream needs at least Berkeley DB 6.0.x");
#else
DBT data;
DB_STREAM * stream = NULL ;
DBT_clear(data);
data.flags = DB_DBT_PARTIAL;
db->Status = (db->cursor->c_get)(db->cursor, &key, &data, cflags);
if (db->Status == 0)
db->Status = ((db->cursor)->db_stream)(db->cursor, &stream, sflags) ;
/* if (db->Status == EINVAL){
db->Status = (db->cursor->c_get)(db->cursor,&key,&data,DB_CURRENT) ;
} */
if (db->Status == 0){
ZMALLOC(RETVAL, BerkeleyDB__DbStream_type) ;
RETVAL->stream = stream ;
RETVAL->active = TRUE ;
hash_store_iv("BerkeleyDB::Term::DbStream", (char *)RETVAL, 1) ;
}
else
{
Trace(("db_stream [%s]\n", my_db_strerror(db->Status)));
BerkeleyDB.xs view on Meta::CPAN
int
FIRSTKEY(db)
BerkeleyDB::Common db
PREINIT:
dMY_CXT;
CODE:
{
DBTKEY key ;
DBT value ;
DBC * cursor ;
/*
TODO!
set partial value to 0 - to eliminate the retrieval of
the value need to store any existing partial settings &
restore at the end.
*/
saveCurrentDB(db) ;
DBT_clear(key) ;
DBT_clear(value) ;
/* If necessary create a cursor for FIRSTKEY/NEXTKEY use */
if (!db->cursor &&
(db->Status = db_cursor(db, db->txn, &cursor, 0)) == 0 )
db->cursor = cursor ;
if (db->cursor)
RETVAL = (db->Status) =
((db->cursor)->c_get)(db->cursor, &key, &value, DB_FIRST);
else
RETVAL = db->Status ;
/* check for end of cursor */
if (RETVAL == DB_NOTFOUND) {
((db->cursor)->c_close)(db->cursor) ;
db->cursor = NULL ;
}
ST(0) = sv_newmortal();
OutputKey(ST(0), key)
}
int
NEXTKEY(db, key)
BerkeleyDB::Common db
BerkeleyDB.xs view on Meta::CPAN
dMY_CXT;
CODE:
{
DBT value ;
saveCurrentDB(db) ;
DBT_clear(key) ;
DBT_clear(value) ;
key.flags = 0 ;
RETVAL = (db->Status) =
((db->cursor)->c_get)(db->cursor, &key, &value, DB_NEXT);
/* check for end of cursor */
if (db->Status == DB_NOTFOUND) {
((db->cursor)->c_close)(db->cursor) ;
db->cursor = NULL ;
}
ST(0) = sv_newmortal();
OutputKey(ST(0), key)
}
MODULE = BerkeleyDB::Recno PACKAGE = BerkeleyDB::Recno
I32
FETCHSIZE(db)
BerkeleyDB::Common db
- Added BerkeleyDB::DbStream class to interface to Blobs
- Added BlobThreshold & BlobDir option to BerkeleyDB::Env
constructor
- Added BlobThreshold & BlobDir option to Hash, Btree & Heap
constructors
- Added get_blob_threshold method to BerkeleyDB::Env
- Added get_blob_dir method to BerkeleyDB::Env
- Added get_blob_threshold method to the Hash, Btree & Heap
- Added get_blob_dir method to the Hash, Btree & Heap
* Added method $cursor->set_partial
* Added method $cursor->partial_clear
* $env->lock_detect dies due to incorrect version check
[RT #84179]
* (Memory leak in db_verify() method. (libdb < 4.2))
[RT #84409]
* Fix a few croaks
0.51 19th March 2012
0.30 11th Sept 2006
* Fixed queue test harness for Berkeley DB 4.5 compliance
* Added $env->lsn_reset, $txn->set_timeout, $env->set_timeout &
$env->get_timeout, $txn->set_tx_max, $txn->get_tx_max
0.29 2nd July 2006
* Fixes for cursor get from secondary where primary os recno.
* Added db_compact
0.28 11th June 2006
* Fixes for secondary where primary is recno.
* GET_BOTH_RANGE wasn't working. It is now.
* Added FreeBSD hints to README - patch supplied by David Landgren
* Added support for set_shm_key & get_shm_key.
* Patch from Mark Jason Dominus to add a better error message
when an odd number of parameters are passed to ParseParameters.
* fixed off-by-one error in my_strdup
* Fixed a problem with push, pop, shift & unshift with Queue &
Recno when used in CDS mode. These methods were not using
a write cursor behind the scenes.
Problem reported by Pavel Hlavnicka.
0.25 1st November 2003
* Minor update to dbinfo
* Fixed a bug in the test harnesses that is only apparent in
perl 5.8.2. Original patch courtesy of Michael Schwern.
0.24 27th September 2003
* added BerkeleyDB::Env::DB_ENV method
* added support for encryption
* the dbinfo script will now indicate if the database is encrypted
* The CLEAR method is now CDB safe.
0.20 2nd September 2002
* More support for building with Berkeley DB 4.1.x
* db->get & db->pget used the wrong output macro for DBM filters
bug spotted by Aaron Ross.
* db_join didn't keep a reference to the cursors it was joining.
Spotted by Winton Davies.
0.19 5th June 2002
* Removed the targets that used mkconsts from Makefile.PL. They relied
on a module that is not available in all versions of Perl.
* added support for env->set_verbose
* added support for db->truncate
* added support for db->rename via BerkeleyDB::db_rename
* added support for db->verify via BerkeleyDB::db_verify
* added support for db->associate, db->pget & cursor->c_pget
* Builds with Berkeley DB 4.1.x
0.18 6th January 2002
* Dropped support for ErrFile as a file handle. It was proving too
difficult to get at the underlying FILE * in XS.
Reported by Jonas Smedegaard (Debian powerpc) & Kenneth Olwing (Win32)
* Fixed problem with abort macro in XSUB.h clashing with txn abort
method in Berkeley DB 4.x -- patch supplied by Kenneth Olwing.
* DB->set_alloc was getting called too late in BerkeleyDB.xs.
* Tidied up the test harness to fix a problem on Solaris where the
"fred" directory wasn't being deleted when it should have been.
* two calls to "open" clashed with a win32 macro.
* size argument for hash_cb is different for Berkeley DB 3.x
* Documented the issue of building on Linux.
* Added -Server, -CacheSize & -LockDetect options
[original patch supplied by Graham Barr]
* Added support for set_mutexlocks, c_count, set_q_extentsize,
key_range, c_dup
* Dropped the "attempted to close a Cursor with an open transaction"
error in c_close. The correct behaviour is that the cursor
should be closed before committing/aborting the transaction.
0.12 2nd August 2000
* Serious bug with get fixed. Spotted by Sleepycat.
* Added hints file for Solaris & Irix (courtesy of Albert Chin-A-Young)
0.11 4th June 2000
* When built with Berkeley Db 3.x there can be a clash with the close
macro.
* Typo in the definition of DB_WRITECURSOR
* The flags parameter wasn't getting sent to db_cursor
* Plugged small memory leak in db_cursor (DESTROY wasn't freeing
memory)
* Can be built with Berkeley DB 3.1
0.10 8th December 1999
* The DESTROY method was missing for BerkeleyDB::Env. This resulted in
a memory leak. Fixed.
* If opening an environment or database failed, there was a small
memory leak. This has been fixed.
* A thread-enabled Perl it could core when a database was closed.
Problem traced to the strdup function.
* Added support for DB_GET_BOTH & DB_NEXT_DUP.
* Added get_dup (from DB_File).
* beefed up the documentation.
* Forgot to add the DB_INIT_CDB in BerkeleyDB.pm in previous release.
* Merged the DBM Filter code from DB_File into BerkeleyDB.
* Fixed a nasty bug where a closed transaction was still used with
with dp_put, db_get etc.
* Added logic to gracefully close everything whenever a fatal error
happens. Previously the plug was just pulled.
* It is now a fatal error to explicitly close an environment if there
is still an open database; a database when there are open cursors or
an open transaction; and a cursor if there is an open transaction.
Using object destruction doesn't have this issue, as object
references will ensure everything gets closed in the correct order.
* The BOOT code now checks that the version of db.h & libdb are the
same - this seems to be a common problem on Linux.
* MLDBM support added.
* Support for the new join cursor added.
* Builds with Berkeley DB 3.x
* Updated dbinfo for Berkeley DB 3.x file formats.
* Deprecated the TxnMgr class. As with Berkeley DB version 3,
txn_begin etc are now accessed via the environment object.
0.06 19 December 1998
* Minor modifications to get the module to build with DB 2.6.x
* Added support for DB 2.6.x's Concurrent Access Method, DB_INIT_CDB.
0.05 9 November 1998
* Proper documentation.
* address or document the "close all cursors if you encounter an error"
* Change the $BerkeleyDB::Error to store the info in the db object,
if possible.
* $BerkeleyDB::db_version is documented. &db_version isn't.
* migrate perl code into the .xs file where necessary
* convert as many of the DB examples files to BerkeleyDB format.
my $Dfile = "dbhash.tmp";
my $Dfile2 = "dbhash2.tmp";
my $Dfile3 = "dbhash3.tmp";
unlink $Dfile;
umask(0) ;
sub isBlob
{
my $cursor = shift ;
my $key = shift;
my $v = '';
$cursor->partial_set(0,0) ;
$cursor->c_get($key, $v, DB_SET) ;
$cursor->partial_clear() ;
return defined $cursor->db_stream(DB_STREAM_WRITE);
}
for my $TYPE ( qw(BerkeleyDB::Hash BerkeleyDB::Btree ))
{
#diag "Test $TYPE";
my $lex = new LexFile $Dfile ;
my $home = "./fred" ;
my $lexd = new LexDir $home ;
my $threshold = 1234 ;
ok $db->db_put("2", $smallData) == 0 ;
my $v2 ;
ok $db->db_get("1", $v2) == 0 ;
is $v2, $bigData;
my $v1 ;
ok $db->db_get("2", $v1) == 0 ;
is $v1, $smallData;
ok my $cursor = $db->db_cursor() ;
ok isBlob($cursor, "1");
ok !isBlob($cursor, "2");
my $k = "1";
my $v = '';
$cursor->partial_set(0,0) ;
ok $cursor->c_get($k, $v, DB_SET) == 0, "set cursor"
or diag "Status is [" . $cursor->status() . "]";
$cursor->partial_clear() ;
is $k, "1";
ok my $dbstream = $cursor->db_stream(DB_STREAM_WRITE)
or diag "Status is [" . $cursor->status() . "]";
isa_ok $dbstream, 'BerkeleyDB::DbStream';
ok $dbstream->size(my $s) == 0 , "size";
is $s, length $bigData, "length ok";
my $new ;
ok $dbstream->read($new, 0, length $bigData) == 0 , "read"
or diag "Status is [" . $cursor->status() . "]";
is $new, $bigData;
my $newData = "hello world" ;
ok $dbstream->write($newData) == 0 , "write";
substr($bigData, 0, length($newData)) = $newData;
my $new1;
ok $dbstream->read($new, 0, 5) == 0 , "read";
is $new, "hello";
ok $dbstream->close() == 0 , "close";
$k = "1";
my $stream = $cursor->c_get_db_stream($k, DB_SET, DB_STREAM_WRITE) ;
isa_ok $stream, 'BerkeleyDB::DbStream';
is $k, "1";
ok $stream->size($s) == 0 , "size";
is $s, length $bigData, "length ok";
$new = 'abc';
ok $stream->read($new, 0, 5) == 0 , "read";
is $new, "hello";
ok $stream->close() == 0 , "close";
ok my $cursor1 = $db->db_cursor() ;
my $d1 ;
my $d2 ;
while (1)
{
my $k = '';
my $v = '';
$cursor->partial_set(0,0) ;
my $status = $cursor1->c_get($k, $v, DB_NEXT) ;
$cursor->partial_clear();
last if $status != 0 ;
my $stream = $cursor1->db_stream(DB_STREAM_WRITE);
if (defined $stream)
{
$stream->size(my $s) ;
my $d = '';
my $delta = 1024;
my $off = 0;
while ($s)
{
$delta = $s if $s - $delta < 0 ;
$stream->read($d, $off, $delta);
$off += $delta ;
$s -= $delta ;
$d1 .= $d ;
}
}
else
{
$cursor1->c_get($k, $d2, DB_CURRENT) ;
}
}
is $d1, $bigData;
is $d2, $smallData;
}
my $value ;
ok $db->db_put("some key", "some value") == 0 ;
ok $db->db_get("some key", $value) == 0 ;
ok $value eq "some value" ;
undef $db ;
undef $env ;
}
{
# cursors
my $lex = new LexFile $Dfile ;
my %hash ;
my ($k, $v) ;
ok my $db = new BerkeleyDB::Btree -Filename => $Dfile,
-Flags => DB_CREATE ;
#print "[$db] [$!] $BerkeleyDB::Error\n" ;
# create some data
my %data = (
"green" => "house",
"blue" => "sea",
) ;
my $ret = 0 ;
while (($k, $v) = each %data) {
$ret += $db->db_put($k, $v) ;
}
ok $ret == 0 ;
# create the cursor
ok my $cursor = $db->db_cursor() ;
$k = $v = "" ;
my %copy = %data ;
my $extras = 0 ;
# sequence forwards
while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
if ( $copy{$k} eq $v )
{ delete $copy{$k} }
else
{ ++ $extras }
}
ok $cursor->status() == DB_NOTFOUND ;
ok $cursor->status() =~ $DB_errors{'DB_NOTFOUND'};
ok keys %copy == 0 ;
ok $extras == 0 ;
# sequence backwards
%copy = %data ;
$extras = 0 ;
my $status ;
for ( $status = $cursor->c_get($k, $v, DB_LAST) ;
$status == 0 ;
$status = $cursor->c_get($k, $v, DB_PREV)) {
if ( $copy{$k} eq $v )
{ delete $copy{$k} }
else
{ ++ $extras }
}
ok $status == DB_NOTFOUND ;
ok $status =~ $DB_errors{'DB_NOTFOUND'};
ok $cursor->status() == $status ;
ok $cursor->status() eq $status ;
ok keys %copy == 0 ;
ok $extras == 0 ;
($k, $v) = ("green", "house") ;
ok $cursor->c_get($k, $v, DB_GET_BOTH) == 0 ;
($k, $v) = ("green", "door") ;
ok $cursor->c_get($k, $v, DB_GET_BOTH) == DB_NOTFOUND ;
($k, $v) = ("black", "house") ;
ok $cursor->c_get($k, $v, DB_GET_BOTH) == DB_NOTFOUND ;
}
{
# Tied Hash interface
my $lex = new LexFile $Dfile ;
my %hash ;
ok tie %hash, 'BerkeleyDB::Btree', -Filename => $Dfile,
-Flags => DB_CREATE ;
my $value = shift @Values ;
$h{$_} = $value ;
$g{$_} = $value ;
$k{$_} = $value ;
}
sub getValues
{
my $hash = shift ;
my $db = tied %$hash ;
my $cursor = $db->db_cursor() ;
my @values = () ;
my ($k, $v) = (0,0) ;
while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
push @values, $v ;
}
return @values ;
}
is_deeply [keys %h], \@srt_1 ;
is_deeply [keys %g], \@srt_2 ;
is_deeply [keys %k], \@srt_3 ;
is_deeply [getValues \%h], [qw(dd 0 0 x 3 1 abc)];
is_deeply [getValues \%g], [qw(dd 1 3 0 x abc 0)]
or diag "Expected [dd 1 0 3 x abc 0] got [@{ [getValues(\%g)] }]\n";
is_deeply [getValues \%k], [qw(0 x 3 0 1 dd abc)];
# test DB_DUP_NEXT
ok my $cur = (tied %g)->db_cursor() ;
my ($k, $v) = (9, "") ;
ok $cur->c_get($k, $v, DB_SET) == 0 ;
ok $k == 9 && $v == 0 ;
ok $cur->c_get($k, $v, DB_NEXT_DUP) == 0 ;
ok $k == 9 && $v eq "x" ;
ok $cur->c_get($k, $v, DB_NEXT_DUP) == DB_NOTFOUND ;
}
{
# override default compare, with duplicates, sort values
) ;
my $ret = 0 ;
while (my ($k, $v) = each %data) {
$ret += $db1->db_put($k, $v) ;
}
ok $ret == 0 ;
# should be able to see all the records
ok my $cursor = $db1->db_cursor() ;
my ($k, $v) = ("", "") ;
my $count = 0 ;
# sequence forwards
while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
++ $count ;
}
ok $count == 3 ;
undef $cursor ;
# now abort the transaction
#ok $txn->txn_abort() == 0 ;
ok (($Z = $txn->txn_abort()) == 0) ;
# there shouldn't be any records in the database
$count = 0 ;
# sequence forwards
ok $cursor = $db1->db_cursor() ;
while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
++ $count ;
}
ok $count == 0 ;
undef $txn ;
undef $cursor ;
undef $db1 ;
undef $env ;
untie %hash ;
}
{
# DB_DUP
my $lex = new LexFile $Dfile ;
my %hash ;
$hash{'Wall'} = 'Larry' ;
$hash{'Wall'} = 'Stone' ;
$hash{'Smith'} = 'John' ;
$hash{'Wall'} = 'Brick' ;
$hash{'Wall'} = 'Brick' ;
$hash{'mouse'} = 'mickey' ;
ok keys %hash == 6 ;
# create a cursor
ok my $cursor = $db->db_cursor() ;
my $key = "Wall" ;
my $value ;
ok $cursor->c_get($key, $value, DB_SET) == 0 ;
ok $key eq "Wall" && $value eq "Larry" ;
ok $cursor->c_get($key, $value, DB_NEXT) == 0 ;
ok $key eq "Wall" && $value eq "Stone" ;
ok $cursor->c_get($key, $value, DB_NEXT) == 0 ;
ok $key eq "Wall" && $value eq "Brick" ;
ok $cursor->c_get($key, $value, DB_NEXT) == 0 ;
ok $key eq "Wall" && $value eq "Brick" ;
#my $ref = $db->db_stat() ;
#ok ($ref->{bt_flags} | DB_DUP) == DB_DUP ;
#print "bt_flags " . $ref->{bt_flags} . " DB_DUP " . DB_DUP ."\n";
undef $db ;
undef $cursor ;
untie %hash ;
}
{
# db_stat
my $lex = new LexFile $Dfile ;
my $recs = ($BerkeleyDB::db_version >= 3.1 ? "bt_ndata" : "bt_nrecs") ;
my %hash ;
ok $k eq "D three" && $v == 3 ;
$k = 4 ;
ok $db->db_get($k, $v, DB_SET_RECNO) == 0;
ok $k eq "E four" && $v == 4 ;
$k = 0 ;
ok $db->db_get($k, $v, DB_SET_RECNO) == 0;
ok $k eq "A zero" && $v == 0 ;
# cursor & DB_SET_RECNO
# create the cursor
ok my $cursor = $db->db_cursor() ;
$k = 2 ;
ok $db->db_get($k, $v, DB_SET_RECNO) == 0;
ok $k eq "C two" && $v == 2 ;
$k = 0 ;
ok $cursor->c_get($k, $v, DB_SET_RECNO) == 0;
ok $k eq "A zero" && $v == 0 ;
$k = 3 ;
ok $db->db_get($k, $v, DB_SET_RECNO) == 0;
ok $k eq "D three" && $v == 3 ;
# cursor & DB_GET_RECNO
ok $cursor->c_get($k, $v, DB_FIRST) == 0 ;
ok $k eq "A zero" && $v == 0 ;
ok $cursor->c_get($k, $v, DB_GET_RECNO) == 0;
ok $v == 0 ;
ok $cursor->c_get($k, $v, DB_NEXT) == 0 ;
ok $k eq "B one" && $v == 1 ;
ok $cursor->c_get($k, $v, DB_GET_RECNO) == 0;
ok $v == 1 ;
ok $cursor->c_get($k, $v, DB_LAST) == 0 ;
ok $k eq "E four" && $v == 4 ;
ok $cursor->c_get($k, $v, DB_GET_RECNO) == 0;
ok $v == 4 ;
}
my $ret = 0 ;
while (@data)
{
my $k = shift @data ;
my $v = shift @data ;
$ret += $db->db_put($k, $v) ;
}
ok $ret == 0 ;
# create a cursor
ok my $cursor = $db->db_cursor() ;
# point to a specific k/v pair
$k = "green" ;
ok $cursor->c_get($k, $v, DB_SET) == 0 ;
ok $v eq "house" ;
# duplicate the cursor
my $dup_cursor = $cursor->c_dup(DB_POSITION);
ok $dup_cursor ;
# move original cursor off green/house
my $s = $cursor->c_get($k, $v, DB_NEXT) ;
ok $k ne "green" ;
ok $v ne "house" ;
# duplicate cursor should still be on green/house
ok $dup_cursor->c_get($k, $v, DB_CURRENT) == 0;
ok $k eq "green" ;
ok $v eq "house" ;
}
$hash{'Wall'} = 'Larry' ;
$hash{'Wall'} = 'Stone' ;
$hash{'Smith'} = 'John' ;
$hash{'Wall'} = 'Brick' ;
$hash{'Wall'} = 'Brick' ;
$hash{'mouse'} = 'mickey' ;
is keys %hash, 6, " keys == 6" ;
# create a cursor
my $cursor = $db->db_cursor() ;
ok $cursor, " created cursor";
my $key = "Wall" ;
my $value ;
cmp_ok $cursor->c_get($key, $value, DB_SET), '==', 0, " c_get ok" ;
is $key, "Wall", " key is 'Wall'";
is $value, "Larry", " value is 'Larry'"; ;
my $count ;
cmp_ok $cursor->c_count($count), '==', 0, " c_count ok" ;
is $count, 4, " count is 4" ;
$key = "Smith" ;
cmp_ok $cursor->c_get($key, $value, DB_SET), '==', 0, " c_get ok" ;
is $key, "Smith", " key is 'Smith'";
is $value, "John", " value is 'John'"; ;
cmp_ok $cursor->c_count($count), '==', 0, " c_count ok" ;
is $count, 1, " count is 1" ;
undef $db ;
undef $cursor ;
untie %hash ;
}
{
title "db_key_range";
my $lex = new LexFile $Dfile ;
my %hash ;
my $db = tie %hash, 'BerkeleyDB::Btree', -Filename => $Dfile,
is $v, "flag";
# pget to primary database is illegal
ok $primary->db_pget('red', $pk, $v) != 0 ;
# pget to secondary database is ok
ok $secondary->db_pget('house', $pk, $v) == 0 ;
is $pk, 'green';
is $v, 'house';
ok my $p_cursor = $primary->db_cursor();
ok my $s_cursor = $secondary->db_cursor();
# c_get from primary
$k = 'green';
ok $p_cursor->c_get($k, $v, DB_SET) == 0;
is $k, 'green';
is $v, 'house';
# c_get from secondary
$k = 'sea';
ok $s_cursor->c_get($k, $v, DB_SET) == 0;
is $k, 'sea';
is $v, 'sea';
# c_pget from primary database should fail
$k = 1;
ok $p_cursor->c_pget($k, $pk, $v, DB_FIRST) != 0;
# c_pget from secondary database
$k = 'flag';
ok $s_cursor->c_pget($k, $pk, $v, DB_SET) == 0
or diag "$BerkeleyDB::Error\n";
is $k, 'flag';
is $pk, 'red';
is $v, 'flag';
# check put to secondary is illegal
ok $secondary->db_put("tom", "dick") != 0;
is countRecords($secondary), 3 ;
# delete from primary
is $v, "sea" ;
# pget to primary database is illegal
ok $primary->db_pget(0, $pk, $v) != 0 ;
# pget to secondary database is ok
ok $secondary->db_pget('house', $pk, $v) == 0 ;
is $pk, 1 ;
is $v, 'house';
ok my $p_cursor = $primary->db_cursor();
ok my $s_cursor = $secondary->db_cursor();
# c_get from primary
$k = 1;
ok $p_cursor->c_get($k, $v, DB_SET) == 0;
is $k, 1;
is $v, 'house';
# c_get from secondary
$k = 'sea';
ok $s_cursor->c_get($k, $v, DB_SET) == 0;
is $k, 'sea'
or warn "# key [$k]\n";
is $v, 'sea';
# c_pget from primary database should fail
$k = 1;
ok $p_cursor->c_pget($k, $pk, $v, DB_FIRST) != 0;
# c_pget from secondary database
$k = 'sea';
ok $s_cursor->c_pget($k, $pk, $v, DB_SET) == 0;
is $k, 'sea' ;
is $pk, 2 ;
is $v, 'sea';
# check put to secondary is illegal
ok $secondary->db_put("tom", "dick") != 0;
is countRecords($secondary), 3 ;
# delete from primary
ok $primary->db_del(2) == 0 ;
# pget to primary database is illegal
ok $primary->db_pget(0, $pk, $v) != 0 ;
# pget to secondary database is ok
ok $secondary->db_pget(4, $pk, $v) == 0 ;
is $pk, 'red'
or warn "# $pk\n";;
is $v, 'flag';
ok my $p_cursor = $primary->db_cursor();
ok my $s_cursor = $secondary->db_cursor();
# c_get from primary
$k = 'green';
ok $p_cursor->c_get($k, $v, DB_SET) == 0;
is $k, 'green';
is $v, 'house';
# c_get from secondary
$k = 3;
ok $s_cursor->c_get($k, $v, DB_SET) == 0;
is $k, 3 ;
is $v, 'sea';
# c_pget from primary database should fail
$k = 1;
ok $p_cursor->c_pget($k, $pk, $v, DB_SET) != 0;
# c_pget from secondary database
$k = 5;
ok $s_cursor->c_pget($k, $pk, $v, DB_SET) == 0
or diag "$BerkeleyDB::Error\n";
is $k, 5 ;
is $pk, 'green';
is $v, 'house';
# check put to secondary is illegal
ok $secondary->db_put(77, "dick") != 0;
is countRecords($secondary), 3 ;
# delete from primary
ok $pk eq 'bar';
ok $v eq 'hello,goodbye';
# pget to DB_GET_BOTH from secondary database
$k = 'house';
$pk = 'green';
ok $secondary->db_pget($k, $pk, $v, DB_GET_BOTH) == 0 ;
ok $k eq 'house';
ok $v eq 'house';
ok my $p_cursor = $primary->db_cursor();
ok my $s_cursor = $secondary->db_cursor();
# c_get from primary
$k = 'green';
ok $p_cursor->c_get($k, $v, DB_SET) == 0;
ok $k eq 'green';
ok $v eq 'house';
# c_get from secondary
$k = 'sea';
ok $s_cursor->c_get($k, $v, DB_SET) == 0;
ok $k eq 'sea';
ok $v eq 'sea';
# c_pget from primary database should fail
$k = 1;
ok $p_cursor->c_pget($k, $pk, $v, DB_FIRST) != 0;
# c_pget from secondary database
$k = 'flag';
ok $s_cursor->c_pget($k, $pk, $v, DB_SET) == 0;
ok $k eq 'flag';
ok $pk eq 'red';
ok $v eq 'flag';
# c_pget with DB_GET_BOTH from secondary database
$k = 'house';
$pk = 'green';
ok $s_cursor->c_pget($k, $pk, $v, DB_GET_BOTH) == 0;
ok $k eq 'house';
ok $v eq 'house';
# check put to secondary is illegal
ok $secondary->db_put("tom", "dick") != 0;
is countRecords($secondary), 5 ;
# delete from primary
ok $primary->db_del("green") == 0 ;
is countRecords($primary), 4 ;
unlink $Dfile;
umask(0) ;
my $db = BerkeleyDB::Btree->new(
-Filename => $Dfile,
-Flags => DB_CREATE,
-Property => DB_DUP | DB_DUPSORT
) || die "Cannot open file $Dfile: $! $BerkeleyDB::Error\n" ;
my $cursor = $db->db_cursor();
my @pairs = qw(
Alabama/Athens
Alabama/Florence
Alaska/Anchorage
Alaska/Fairbanks
Arizona/Avondale
Arizona/Florence
);
my @tests = (
["Alaska", "Fa", "Alaska", "Fairbanks"],
["Arizona", "Fl", "Arizona", "Florence"],
["Alaska", "An", "Alaska", "Anchorage"],
);
#my $i;
while (my $test = shift @tests) {
my ($k1, $v1, $k2, $v2) = @$test;
ok $cursor->c_get($k1, $v1, DB_GET_BOTH_RANGE) == 0;
is $k1, $k2;
is $v1, $v2;
}
undef $db;
unlink $Dfile;
t/destroy.t view on Meta::CPAN
) ;
my $ret = 0 ;
while (my ($k, $v) = each %data) {
$ret += $db1->db_put($k, $v) ;
}
ok $ret == 0 ;
# should be able to see all the records
ok my $cursor = $db1->db_cursor() ;
my ($k, $v) = ("", "") ;
my $count = 0 ;
# sequence forwards
while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
++ $count ;
}
is $count, 3 ;
undef $cursor ;
# now abort the transaction
ok $txn->txn_abort() == 0 ;
# there shouldn't be any records in the database
$count = 0 ;
# sequence forwards
ok $cursor = $db1->db_cursor() ;
while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
++ $count ;
}
is $count, 0 ;
#undef $txn ;
#undef $cursor ;
#undef $db1 ;
#undef $env ;
#untie %hash ;
}
{
my $lex = new LexFile $Dfile ;
my %hash ;
my $cursor ;
my ($k, $v) = ("", "") ;
ok my $db1 = tie %hash, 'BerkeleyDB::Hash',
-Filename => $Dfile,
-Flags => DB_CREATE ;
my $count = 0 ;
# sequence forwards
ok $cursor = $db1->db_cursor() ;
while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
++ $count ;
}
is $count, 0 ;
}
t/examples.t view on Meta::CPAN
$db->db_put("tomato", "red") ;
# Check for existence of a key
print "Banana Exists\n\n" if $db->db_get("banana", $v) == 0;
# Delete a key/value pair.
$db->db_del("apple") ;
# print the contents of the file
my ($k, $v) = ("", "") ;
my $cursor = $db->db_cursor() ;
while ($cursor->c_get($k, $v, DB_NEXT) == 0)
{ print "$k -> $v\n" }
undef $cursor ;
undef $db ;
unlink $filename ;
}
#print "[" . docat($redirect) . "]" ;
is(docat_del($redirect), <<'EOM') ;
Banana Exists
orange -> orange
tomato -> red
t/examples.t.T view on Meta::CPAN
$db->db_put("tomato", "red") ;
# Check for existence of a key
print "Banana Exists\n\n" if $db->db_get("banana", $v) == 0;
# Delete a key/value pair.
$db->db_del("apple") ;
# print the contents of the file
my ($k, $v) = ("", "") ;
my $cursor = $db->db_cursor() ;
while ($cursor->c_get($k, $v, DB_NEXT) == 0)
{ print "$k -> $v\n" }
undef $cursor ;
undef $db ;
## END simpleHash2
unlink $filename ;
}
#print "[" . docat($redirect) . "]" ;
is(docat_del($redirect), <<'EOM') ;
Banana Exists
orange -> orange
t/examples3.t view on Meta::CPAN
# Add a few key/value pairs to the file
$db->db_put("red", "apple") ;
$db->db_put("orange", "orange") ;
$db->db_put("green", "banana") ;
$db->db_put("yellow", "banana") ;
$db->db_put("red", "tomato") ;
$db->db_put("green", "apple") ;
# print the contents of the file
my ($k, $v) = ("", "") ;
my $cursor = $db->db_cursor() ;
while ($cursor->c_get($k, $v, DB_NEXT) == 0)
{ print "$k -> $v\n" }
undef $cursor ;
undef $db ;
unlink $filename ;
}
#print "[" . docat($redirect) . "]" ;
is(docat_del_sort($redirect), <<'EOM') ;
green -> apple
green -> banana
orange -> orange
red -> apple
t/examples3.t view on Meta::CPAN
# Add a few key/value pairs to the file
$db->db_put("red", "apple") ;
$db->db_put("orange", "orange") ;
$db->db_put("green", "banana") ;
$db->db_put("yellow", "banana") ;
$db->db_put("red", "tomato") ;
$db->db_put("green", "apple") ;
# print the contents of the file
my ($k, $v) = ("", "") ;
my $cursor = $db->db_cursor() ;
while ($cursor->c_get($k, $v, DB_NEXT) == 0)
{ print "$k -> $v\n" }
undef $cursor ;
undef $db ;
unlink $filename ;
}
#print "[" . docat($redirect) . "]" ;
is(docat_del_sort($redirect), <<'EOM') ;
green -> apple
green -> banana
orange -> orange
red -> apple
t/examples3.t.T view on Meta::CPAN
# Add a few key/value pairs to the file
$db->db_put("red", "apple") ;
$db->db_put("orange", "orange") ;
$db->db_put("green", "banana") ;
$db->db_put("yellow", "banana") ;
$db->db_put("red", "tomato") ;
$db->db_put("green", "apple") ;
# print the contents of the file
my ($k, $v) = ("", "") ;
my $cursor = $db->db_cursor() ;
while ($cursor->c_get($k, $v, DB_NEXT) == 0)
{ print "$k -> $v\n" }
undef $cursor ;
undef $db ;
## END dupHash
unlink $filename ;
}
#print "[" . docat($redirect) . "]" ;
is(docat_del_sort($redirect), <<'EOM') ;
green -> apple
green -> banana
orange -> orange
t/examples3.t.T view on Meta::CPAN
# Add a few key/value pairs to the file
$db->db_put("red", "apple") ;
$db->db_put("orange", "orange") ;
$db->db_put("green", "banana") ;
$db->db_put("yellow", "banana") ;
$db->db_put("red", "tomato") ;
$db->db_put("green", "apple") ;
# print the contents of the file
my ($k, $v) = ("", "") ;
my $cursor = $db->db_cursor() ;
while ($cursor->c_get($k, $v, DB_NEXT) == 0)
{ print "$k -> $v\n" }
undef $cursor ;
undef $db ;
## END dupSortHash
unlink $filename ;
}
#print "[" . docat($redirect) . "]" ;
is(docat_del_sort($redirect), <<'EOM') ;
green -> apple
green -> banana
orange -> orange
$h{$k} = $v ;
ok $k == 10;
ok $v == 30;
ok $h{$k} == 30;
$k = 3;
ok ! $db->db_get($k, $v, DB_GET_BOTH);
ok $k == 3 ;
ok $v == 5 ;
my $cursor = $db->db_cursor();
my %tmp = ();
while ($cursor->c_get($k, $v, DB_NEXT) == 0)
{
$tmp{$k} = $v;
}
ok keys %tmp == 3 ;
ok $tmp{3} == 5;
undef $cursor ;
undef $db ;
untie %h;
unlink $Dfile;
}
-Flags => DB_CREATE ;
ok $db->db_put("some key", "some value") == 0 ;
ok $db->db_get("some key", $value) == 0 ;
ok $value eq "some value" ;
ok $::count > 0 ;
}
{
# cursors
my $lex = new LexFile $Dfile ;
my %hash ;
my ($k, $v) ;
ok my $db = new BerkeleyDB::Hash -Filename => $Dfile,
-Flags => DB_CREATE ;
# create some data
my %data = (
"red" => 2,
"green" => "house",
"blue" => "sea",
) ;
my $ret = 0 ;
while (($k, $v) = each %data) {
$ret += $db->db_put($k, $v) ;
}
ok $ret == 0 ;
# create the cursor
ok my $cursor = $db->db_cursor() ;
$k = $v = "" ;
my %copy = %data ;
my $extras = 0 ;
# sequence forwards
while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
if ( $copy{$k} eq $v )
{ delete $copy{$k} }
else
{ ++ $extras }
}
ok $cursor->status() == DB_NOTFOUND ;
ok $cursor->status() =~ $DB_errors{'DB_NOTFOUND'} ;
ok keys %copy == 0 ;
ok $extras == 0 ;
# sequence backwards
%copy = %data ;
$extras = 0 ;
my $status ;
for ( $status = $cursor->c_get($k, $v, DB_LAST) ;
$status == 0 ;
$status = $cursor->c_get($k, $v, DB_PREV)) {
if ( $copy{$k} eq $v )
{ delete $copy{$k} }
else
{ ++ $extras }
}
ok $status == DB_NOTFOUND ;
ok $status =~ $DB_errors{'DB_NOTFOUND'} ;
ok $cursor->status() == $status ;
ok $cursor->status() eq $status ;
ok keys %copy == 0 ;
ok $extras == 0 ;
($k, $v) = ("green", "house") ;
ok $cursor->c_get($k, $v, DB_GET_BOTH) == 0 ;
($k, $v) = ("green", "door") ;
ok $cursor->c_get($k, $v, DB_GET_BOTH) == DB_NOTFOUND ;
($k, $v) = ("black", "house") ;
ok $cursor->c_get($k, $v, DB_GET_BOTH) == DB_NOTFOUND ;
}
{
# Tied Hash interface
my $lex = new LexFile $Dfile ;
my %hash ;
ok tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile,
-Flags => DB_CREATE ;
) ;
my $ret = 0 ;
while (my ($k, $v) = each %data) {
$ret += $db1->db_put($k, $v) ;
}
ok $ret == 0 ;
# should be able to see all the records
ok my $cursor = $db1->db_cursor() ;
my ($k, $v) = ("", "") ;
my $count = 0 ;
# sequence forwards
while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
++ $count ;
}
ok $count == 3 ;
undef $cursor ;
# now abort the transaction
ok $txn->txn_abort() == 0 ;
# there shouldn't be any records in the database
$count = 0 ;
# sequence forwards
ok $cursor = $db1->db_cursor() ;
while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
++ $count ;
}
ok $count == 0 ;
undef $txn ;
undef $cursor ;
undef $db1 ;
undef $env ;
untie %hash ;
}
{
# DB_DUP
my $lex = new LexFile $Dfile ;
$hash{'Wall'} = 'Larry' ;
$hash{'Wall'} = 'Stone' ;
$hash{'Smith'} = 'John' ;
$hash{'Wall'} = 'Brick' ;
$hash{'Wall'} = 'Brick' ;
$hash{'mouse'} = 'mickey' ;
ok keys %hash == 6 ;
# create a cursor
ok my $cursor = $db->db_cursor() ;
my $key = "Wall" ;
my $value ;
ok $cursor->c_get($key, $value, DB_SET) == 0 ;
ok $key eq "Wall" && $value eq "Larry" ;
ok $cursor->c_get($key, $value, DB_NEXT) == 0 ;
ok $key eq "Wall" && $value eq "Stone" ;
ok $cursor->c_get($key, $value, DB_NEXT) == 0 ;
ok $key eq "Wall" && $value eq "Brick" ;
ok $cursor->c_get($key, $value, DB_NEXT) == 0 ;
ok $key eq "Wall" && $value eq "Brick" ;
#my $ref = $db->db_stat() ;
#ok $ref->{bt_flags} | DB_DUP ;
# test DB_DUP_NEXT
my ($k, $v) = ("Wall", "") ;
ok $cursor->c_get($k, $v, DB_SET) == 0 ;
ok $k eq "Wall" && $v eq "Larry" ;
ok $cursor->c_get($k, $v, DB_NEXT_DUP) == 0 ;
ok $k eq "Wall" && $v eq "Stone" ;
ok $cursor->c_get($k, $v, DB_NEXT_DUP) == 0 ;
ok $k eq "Wall" && $v eq "Brick" ;
ok $cursor->c_get($k, $v, DB_NEXT_DUP) == 0 ;
ok $k eq "Wall" && $v eq "Brick" ;
ok $cursor->c_get($k, $v, DB_NEXT_DUP) == DB_NOTFOUND ;
undef $db ;
undef $cursor ;
untie %hash ;
}
{
# DB_DUP & DupCompare
my $lex = new LexFile $Dfile, $Dfile2;
my ($key, $value) ;
my (%h, %g) ;
my @Keys = qw( 0123 9 12 -1234 9 987654321 9 def ) ;
-Property => DB_DUP|DB_DUPSORT,
-Flags => DB_CREATE ;
foreach (@Keys) {
local $^W = 0 ;
my $value = shift @Values ;
$h{$_} = $value ;
$g{$_} = $value ;
}
ok my $cursor = (tied %h)->db_cursor() ;
$key = 9 ; $value = "";
ok $cursor->c_get($key, $value, DB_SET) == 0 ;
ok $key == 9 && $value eq 11 ;
ok $cursor->c_get($key, $value, DB_NEXT) == 0 ;
ok $key == 9 && $value == 2 ;
ok $cursor->c_get($key, $value, DB_NEXT) == 0 ;
ok $key == 9 && $value eq "x" ;
$cursor = (tied %g)->db_cursor() ;
$key = 9 ;
ok $cursor->c_get($key, $value, DB_SET) == 0 ;
ok $key == 9 && $value eq "x" ;
ok $cursor->c_get($key, $value, DB_NEXT) == 0 ;
ok $key == 9 && $value == 2 ;
ok $cursor->c_get($key, $value, DB_NEXT) == 0 ;
ok $key == 9 && $value == 11 ;
}
{
# get_dup etc
my $lex = new LexFile $Dfile;
my %hh ;
my $value ;
ok $db->db_put($key, "some value", DB_APPEND) == 0 ;
ok $db->db_get($key, $value) == 0 ;
ok $value eq "some value" ;
undef $db ;
undef $env ;
}
{
# cursors
my $lex = new LexFile $Dfile ;
my %hash ;
my ($k, $v) ;
ok my $db = new BerkeleyDB::Heap -Filename => $Dfile,
-Flags => DB_CREATE ;
#print "[$db] [$!] $BerkeleyDB::Error\n" ;
# create some data
my %data = ();
my $ret = 0 ;
for my $v (qw(2 house sea)){
my $key;
$ret += $db->db_put($key, $v, DB_APPEND) ;
$data{$key} = $v;
$keys{$v} = $key;
}
ok $ret == 0 ;
# create the cursor
ok my $cursor = $db->db_cursor() ;
$k = $v = "" ;
my %copy = %data ;
my $extras = 0 ;
# sequence forwards
while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
if ( $copy{$k} eq $v )
{ delete $copy{$k} }
else
{ ++ $extras }
}
ok $cursor->status() == DB_NOTFOUND ;
ok $cursor->status() =~ $DB_errors{'DB_NOTFOUND'};
ok keys %copy == 0 ;
ok $extras == 0 ;
# sequence backwards
%copy = %data ;
$extras = 0 ;
my $status ;
for ( $status = $cursor->c_get($k, $v, DB_LAST) ;
$status == 0 ;
$status = $cursor->c_get($k, $v, DB_PREV)) {
if ( $copy{$k} eq $v )
{ delete $copy{$k} }
else
{ ++ $extras }
}
ok $status == DB_NOTFOUND ;
ok $status =~ $DB_errors{'DB_NOTFOUND'};
ok $cursor->status() == $status ;
ok $cursor->status() eq $status ;
ok keys %copy == 0 ;
ok $extras == 0, "extras == 0" ;
($k, $v) = ($keys{"house"}, "house") ;
ok $cursor->c_get($k, $v, DB_GET_BOTH) == 0, "c_get BOTH" ;
($k, $v) = ($keys{"house"}, "door") ;
ok $cursor->c_get($k, $v, DB_GET_BOTH) == DB_NOTFOUND, "DB_NOTFOUND" ;
($k, $v) = ("black", "house") ;
ok $cursor->c_get($k, $v, DB_GET_BOTH) == DB_NOTFOUND, "DB_NOTFOUND" ;
}
{
# in-memory file
my $lex = new LexFile $Dfile ;
my $ret = 0 ;
while (my ($k, $v) = each %data) {
my $key;
$ret += $db1->db_put($key, $v, DB_APPEND) ;
}
ok $ret == 0 ;
# should be able to see all the records
ok my $cursor = $db1->db_cursor() ;
my ($k, $v) = ("", "") ;
my $count = 0 ;
# sequence forwards
while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
++ $count ;
}
ok $count == 3 ;
undef $cursor ;
# now abort the transaction
#ok $txn->txn_abort() == 0 ;
ok (($Z = $txn->txn_abort()) == 0) ;
# there shouldn't be any records in the database
$count = 0 ;
# sequence forwards
ok $cursor = $db1->db_cursor() ;
while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
++ $count ;
}
ok $count == 0 ;
undef $txn ;
undef $cursor ;
undef $db1 ;
undef $env ;
untie %hash ;
}
exit;
{
# DB_DUP
my $lex = new LexFile $Dfile ;
$hash{'Wall'} = 'Larry' ;
$hash{'Wall'} = 'Stone' ;
$hash{'Smith'} = 'John' ;
$hash{'Wall'} = 'Brick' ;
$hash{'Wall'} = 'Brick' ;
$hash{'mouse'} = 'mickey' ;
ok keys %hash == 6 ;
# create a cursor
ok my $cursor = $db->db_cursor() ;
my $key = "Wall" ;
my $value ;
ok $cursor->c_get($key, $value, DB_SET) == 0 ;
ok $key eq "Wall" && $value eq "Larry" ;
ok $cursor->c_get($key, $value, DB_NEXT) == 0 ;
ok $key eq "Wall" && $value eq "Stone" ;
ok $cursor->c_get($key, $value, DB_NEXT) == 0 ;
ok $key eq "Wall" && $value eq "Brick" ;
ok $cursor->c_get($key, $value, DB_NEXT) == 0 ;
ok $key eq "Wall" && $value eq "Brick" ;
#my $ref = $db->db_stat() ;
#ok ($ref->{bt_flags} | DB_DUP) == DB_DUP ;
#print "bt_flags " . $ref->{bt_flags} . " DB_DUP " . DB_DUP ."\n";
undef $db ;
undef $cursor ;
untie %hash ;
}
{
# db_stat
my $lex = new LexFile $Dfile ;
my $recs = ($BerkeleyDB::db_version >= 3.1 ? "bt_ndata" : "bt_nrecs") ;
my %hash ;
unlink $Dfile1, $Dfile2, $Dfile3 ;
umask(0) ;
{
# error cases
my $lex = new LexFile $Dfile1, $Dfile2, $Dfile3 ;
my %hash1 ;
my $value ;
my $status ;
my $cursor ;
ok my $db1 = tie %hash1, 'BerkeleyDB::Hash',
-Filename => $Dfile1,
-Flags => DB_CREATE,
-DupCompare => sub { $_[0] lt $_[1] },
-Property => DB_DUP|DB_DUPSORT ;
# no cursors supplied
eval '$cursor = $db1->db_join() ;' ;
ok $@ =~ /Usage: \$db->BerkeleyDB::db_join\Q([cursors], flags=0)/;
# empty list
eval '$cursor = $db1->db_join([]) ;' ;
ok $@ =~ /db_join: No cursors in parameter list/;
# cursor list, isn not a []
eval '$cursor = $db1->db_join({}) ;' ;
ok $@ =~ /db_join: first parameter is not an array reference/;
eval '$cursor = $db1->db_join(\1) ;' ;
ok $@ =~ /db_join: first parameter is not an array reference/;
my ($a, $b) = ("a", "b");
$a = bless [], "fred";
$b = bless [], "fred";
eval '$cursor = $db1->db_join($a, $b) ;' ;
ok $@ =~ /db_join: first parameter is not an array reference/;
}
{
# test a 2-way & 3-way join
my $lex = new LexFile $Dfile1, $Dfile2, $Dfile3 ;
my %hash1 ;
my %hash2 ;
blue blueberry)) ;
ok addData($db3, qw( expensive apple
reasonable raspberry
expensive strawberry
reasonable peach
reasonable pear
expensive gooseberry
reasonable blueberry)) ;
ok my $cursor2 = $db2->db_cursor() ;
my $k = "red" ;
my $v = "" ;
ok $cursor2->c_get($k, $v, DB_SET) == 0 ;
# Two way Join
ok my $cursor1 = $db1->db_join([$cursor2]) ;
my %expected = qw( apple Convenience
raspberry Shopway
strawberry Shopway
) ;
# sequence forwards
while ($cursor1->c_get($k, $v) == 0) {
delete $expected{$k}
if defined $expected{$k} && $expected{$k} eq $v ;
#print "[$k] [$v]\n" ;
}
is keys %expected, 0 ;
ok $cursor1->status() == DB_NOTFOUND ;
# Three way Join
ok $cursor2 = $db2->db_cursor() ;
$k = "red" ;
$v = "" ;
ok $cursor2->c_get($k, $v, DB_SET) == 0 ;
ok my $cursor3 = $db3->db_cursor() ;
$k = "expensive" ;
$v = "" ;
ok $cursor3->c_get($k, $v, DB_SET) == 0 ;
ok $cursor1 = $db1->db_join([$cursor2, $cursor3]) ;
%expected = qw( apple Convenience
strawberry Shopway
) ;
# sequence forwards
while ($cursor1->c_get($k, $v) == 0) {
delete $expected{$k}
if defined $expected{$k} && $expected{$k} eq $v ;
#print "[$k] [$v]\n" ;
}
is keys %expected, 0 ;
ok $cursor1->status() == DB_NOTFOUND ;
# test DB_JOIN_ITEM
# #################
ok $cursor2 = $db2->db_cursor() ;
$k = "red" ;
$v = "" ;
ok $cursor2->c_get($k, $v, DB_SET) == 0 ;
ok $cursor3 = $db3->db_cursor() ;
$k = "expensive" ;
$v = "" ;
ok $cursor3->c_get($k, $v, DB_SET) == 0 ;
ok $cursor1 = $db1->db_join([$cursor2, $cursor3]) ;
%expected = qw( apple 1
strawberry 1
) ;
# sequence forwards
$k = "" ;
$v = "" ;
while ($cursor1->c_get($k, $v, DB_JOIN_ITEM) == 0) {
delete $expected{$k}
if defined $expected{$k} ;
#print "[$k]\n" ;
}
is keys %expected, 0 ;
ok $cursor1->status() == DB_NOTFOUND ;
ok $cursor1->c_close() == 0 ;
ok $cursor2->c_close() == 0 ;
ok $cursor3->c_close() == 0 ;
ok (($status = $txn->txn_commit()) == 0);
undef $txn ;
ok my $cursor1a = $db1->db_cursor() ;
eval { $cursor1 = $db1->db_join([$cursor1a]) };
ok $@ =~ /BerkeleyDB Aborting: attempted to do a self-join at/;
eval { $cursor1 = $db1->db_join([$cursor1]) } ;
ok $@ =~ /BerkeleyDB Aborting: attempted to do a self-join at/;
# undef $cursor1a;
# #undef $cursor1;
# #undef $cursor2;
# #undef $cursor3;
# undef $db1 ;
# undef $db2 ;
# undef $db3 ;
# undef $env ;
# untie %hash1 ;
# untie %hash2 ;
# untie %hash3 ;
}
print "# at the end\n";
my $value ;
ok $db->db_put(1, "some value") == 0 ;
ok $db->db_get(1, $value) == 0 ;
ok $value eq fillout("some value", $rec_len) ;
undef $db ;
undef $env ;
}
{
# cursors
my $lex = new LexFile $Dfile ;
my @array ;
my ($k, $v) ;
my $rec_len = 5 ;
ok my $db = new BerkeleyDB::Queue -Filename => $Dfile,
-ArrayBase => 0,
-Flags => DB_CREATE ,
-Len => $rec_len;
my $i ;
my %data ;
my $ret = 0 ;
for ($i = 0 ; $i < @data ; ++$i) {
$ret += $db->db_put($i, $data[$i]) ;
$data{$i} = $data[$i] ;
}
ok $ret == 0 ;
# create the cursor
ok my $cursor = $db->db_cursor() ;
$k = 0 ; $v = "" ;
my %copy = %data;
my $extras = 0 ;
# sequence forwards
while ($cursor->c_get($k, $v, DB_NEXT) == 0)
{
if ( fillout($copy{$k}, $rec_len) eq $v )
{ delete $copy{$k} }
else
{ ++ $extras }
}
ok $cursor->status() == DB_NOTFOUND ;
ok $cursor->status() =~ $DB_errors{'DB_NOTFOUND'} ;
ok keys %copy == 0 ;
ok $extras == 0 ;
# sequence backwards
%copy = %data ;
$extras = 0 ;
my $status ;
for ( $status = $cursor->c_get($k, $v, DB_LAST) ;
$status == 0 ;
$status = $cursor->c_get($k, $v, DB_PREV)) {
if ( fillout($copy{$k}, $rec_len) eq $v )
{ delete $copy{$k} }
else
{ ++ $extras }
}
ok $status == DB_NOTFOUND ;
ok $status =~ $DB_errors{'DB_NOTFOUND'} ;
ok $cursor->status() == $status ;
ok $cursor->status() eq $status ;
ok keys %copy == 0 ;
ok $extras == 0 ;
}
{
# Tied Array interface
my $lex = new LexFile $Dfile ;
my @array ;
my $db ;
my $rec_len = 10 ;
ok $db = tie @array, 'BerkeleyDB::Queue', -Filename => $Dfile,
-ArrayBase => 0,
-Flags => DB_CREATE ,
-Len => $rec_len;
ok my $cursor = (tied @array)->db_cursor() ;
# check the database is empty
my $count = 0 ;
my ($k, $v) = (0,"") ;
while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
++ $count ;
}
ok $cursor->status() == DB_NOTFOUND ;
ok $count == 0 ;
ok @array == 0 ;
# Add a k/v pair
my $value ;
$array[1] = "some value";
ok ((tied @array)->status() == 0) ;
ok $array[1] eq fillout("some value", $rec_len);
ok defined $array[1];
ok ((tied @array)->status() == 0) ;
ok !defined $array[3];
ok ((tied @array)->status() == DB_NOTFOUND) ;
$array[1] = 2 ;
$array[10] = 20 ;
$array[100] = 200 ;
my ($keys, $values) = (0,0);
$count = 0 ;
for ( my $status = $cursor->c_get($k, $v, DB_FIRST) ;
$status == 0 ;
$status = $cursor->c_get($k, $v, DB_NEXT)) {
$keys += $k ;
$values += $v ;
++ $count ;
}
ok $count == 3 ;
ok $keys == 111 ;
ok $values == 222 ;
# unshift isn't allowed
# eval {
# $FA ? unshift @array, "red", "green", "blue"
# : $db->unshift("red", "green", "blue" ) ;
# } ;
# ok $@ =~ /^unshift is unsupported with Queue databases/ ;
$array[0] = "red" ;
$array[1] = "green" ;
$array[2] = "blue" ;
$array[4] = 2 ;
ok $array[0] eq fillout("red", $rec_len) ;
ok $cursor->c_get($k, $v, DB_FIRST) == 0 ;
ok $k == 0 ;
ok $v eq fillout("red", $rec_len) ;
ok $array[1] eq fillout("green", $rec_len) ;
ok $cursor->c_get($k, $v, DB_NEXT) == 0 ;
ok $k == 1 ;
ok $v eq fillout("green", $rec_len) ;
ok $array[2] eq fillout("blue", $rec_len) ;
ok $cursor->c_get($k, $v, DB_NEXT) == 0 ;
ok $k == 2 ;
ok $v eq fillout("blue", $rec_len) ;
ok $array[4] == 2 ;
ok $cursor->c_get($k, $v, DB_NEXT) == 0 ;
ok $k == 4 ;
ok $v == 2 ;
# shift
ok (($FA ? shift @array : $db->shift()) eq fillout("red", $rec_len)) ;
ok (($FA ? shift @array : $db->shift()) eq fillout("green", $rec_len)) ;
ok (($FA ? shift @array : $db->shift()) eq fillout("blue", $rec_len)) ;
ok (($FA ? shift @array : $db->shift()) == 2) ;
# push
$FA ? push @array, "the", "end"
: $db->push("the", "end") ;
ok $cursor->c_get($k, $v, DB_LAST) == 0 ;
ok $k == 102 ;
ok $v eq fillout("end", $rec_len) ;
ok $cursor->c_get($k, $v, DB_PREV) == 0 ;
ok $k == 101 ;
ok $v eq fillout("the", $rec_len) ;
ok $cursor->c_get($k, $v, DB_PREV) == 0 ;
ok $k == 100 ;
ok $v == 200 ;
# pop
ok (( $FA ? pop @array : $db->pop ) eq fillout("end", $rec_len)) ;
ok (( $FA ? pop @array : $db->pop ) eq fillout("the", $rec_len)) ;
ok (( $FA ? pop @array : $db->pop ) == 200) ;
undef $cursor;
# now clear the array
$FA ? @array = ()
: $db->clear() ;
ok $cursor = (tied @array)->db_cursor() ;
ok $cursor->c_get($k, $v, DB_FIRST) == DB_NOTFOUND ;
undef $cursor ;
undef $db ;
untie @array ;
}
{
# in-memory file
my @array ;
my $fd ;
my $value ;
my $ret = 0 ;
my $i ;
for ($i = 0 ; $i < @data ; ++$i) {
$ret += $db1->db_put($i, $data[$i]) ;
}
ok $ret == 0 ;
# should be able to see all the records
ok my $cursor = $db1->db_cursor() ;
my ($k, $v) = (0, "") ;
my $count = 0 ;
# sequence forwards
while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
++ $count ;
}
ok $count == 3 ;
undef $cursor ;
# now abort the transaction
ok $txn->txn_abort() == 0 ;
# there shouldn't be any records in the database
$count = 0 ;
# sequence forwards
ok $cursor = $db1->db_cursor() ;
while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
++ $count ;
}
ok $count == 0 ;
undef $txn ;
undef $cursor ;
undef $db1 ;
undef $env ;
untie @array ;
}
{
# db_stat
my $lex = new LexFile $Dfile ;
-ArrayBase => 0,
-Flags => DB_CREATE ,
-Env => $env ,
-Txn => $txn ,
-Len => $rec_len;
ok $txn->txn_commit() == 0 ;
ok $txn = $env->txn_begin() ;
$db->Txn($txn);
ok my $cursor = (tied @array)->db_cursor() ;
# check the database is empty
my $count = 0 ;
my ($k, $v) = (0,"") ;
while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
++ $count ;
}
ok $cursor->status() == DB_NOTFOUND ;
ok $count == 0 ;
ok @array == 0 ;
# Add a k/v pair
my $value ;
$array[1] = "some value";
ok ((tied @array)->status() == 0) ;
ok $array[1] eq fillout("some value", $rec_len);
ok defined $array[1];
ok ((tied @array)->status() == 0) ;
ok !defined $array[3];
ok ((tied @array)->status() == DB_NOTFOUND) ;
$array[1] = 2 ;
$array[10] = 20 ;
$array[100] = 200 ;
my ($keys, $values) = (0,0);
$count = 0 ;
for ( my $status = $cursor->c_get($k, $v, DB_FIRST) ;
$status == 0 ;
$status = $cursor->c_get($k, $v, DB_NEXT)) {
$keys += $k ;
$values += $v ;
++ $count ;
}
ok $count == 3 ;
ok $keys == 111 ;
ok $values == 222 ;
# unshift isn't allowed
# eval {
# $FA ? unshift @array, "red", "green", "blue"
# : $db->unshift("red", "green", "blue" ) ;
# } ;
# ok $@ =~ /^unshift is unsupported with Queue databases/ ;
$array[0] = "red" ;
$array[1] = "green" ;
$array[2] = "blue" ;
$array[4] = 2 ;
ok $array[0] eq fillout("red", $rec_len) ;
ok $cursor->c_get($k, $v, DB_FIRST) == 0 ;
ok $k == 0 ;
ok $v eq fillout("red", $rec_len) ;
ok $array[1] eq fillout("green", $rec_len) ;
ok $cursor->c_get($k, $v, DB_NEXT) == 0 ;
ok $k == 1 ;
ok $v eq fillout("green", $rec_len) ;
ok $array[2] eq fillout("blue", $rec_len) ;
ok $cursor->c_get($k, $v, DB_NEXT) == 0 ;
ok $k == 2 ;
ok $v eq fillout("blue", $rec_len) ;
ok $array[4] == 2 ;
ok $cursor->c_get($k, $v, DB_NEXT) == 0 ;
ok $k == 4 ;
ok $v == 2 ;
# shift
ok (($FA ? shift @array : $db->shift()) eq fillout("red", $rec_len)) ;
ok (($FA ? shift @array : $db->shift()) eq fillout("green", $rec_len)) ;
ok (($FA ? shift @array : $db->shift()) eq fillout("blue", $rec_len)) ;
ok (($FA ? shift @array : $db->shift()) == 2) ;
# push
$FA ? push @array, "the", "end"
: $db->push("the", "end") ;
ok $cursor->c_get($k, $v, DB_LAST) == 0 ;
ok $k == 102 ;
ok $v eq fillout("end", $rec_len) ;
ok $cursor->c_get($k, $v, DB_PREV) == 0 ;
ok $k == 101 ;
ok $v eq fillout("the", $rec_len) ;
ok $cursor->c_get($k, $v, DB_PREV) == 0 ;
ok $k == 100 ;
ok $v == 200 ;
# pop
ok (( $FA ? pop @array : $db->pop ) eq fillout("end", $rec_len)) ;
ok (( $FA ? pop @array : $db->pop ) eq fillout("the", $rec_len)) ;
ok (( $FA ? pop @array : $db->pop ) == 200 ) ;
undef $cursor ;
# now clear the array
$FA ? @array = ()
: $db->clear() ;
ok $cursor = (tied @array)->db_cursor() ;
ok $cursor->c_get($k, $v, DB_FIRST) == DB_NOTFOUND ;
undef $cursor ;
ok $txn->txn_commit() == 0 ;
undef $db ;
untie @array ;
}
{
# RT #75691: scalar(@array) returns incorrect value after shift() on tied array
my $lex = new LexFile $Dfile ;
my @array ;
my $value ;
ok $db->db_put(1, "some value") == 0 ;
ok $db->db_get(1, $value) == 0 ;
ok $value eq "some value" ;
undef $db ;
undef $env ;
}
{
# cursors
my $lex = new LexFile $Dfile ;
my @array ;
my ($k, $v) ;
ok my $db = new BerkeleyDB::Recno -Filename => $Dfile,
-ArrayBase => 0,
-Flags => DB_CREATE ;
# create some data
my @data = (
my $i ;
my %data ;
my $ret = 0 ;
for ($i = 0 ; $i < @data ; ++$i) {
$ret += $db->db_put($i, $data[$i]) ;
$data{$i} = $data[$i] ;
}
ok $ret == 0 ;
# create the cursor
ok my $cursor = $db->db_cursor() ;
$k = 0 ; $v = "" ;
my %copy = %data;
my $extras = 0 ;
# sequence forwards
while ($cursor->c_get($k, $v, DB_NEXT) == 0)
{
if ( $copy{$k} eq $v )
{ delete $copy{$k} }
else
{ ++ $extras }
}
ok $cursor->status() == DB_NOTFOUND ;
ok $cursor->status() =~ $DB_errors{'DB_NOTFOUND'} ;
ok keys %copy == 0 ;
ok $extras == 0 ;
# sequence backwards
%copy = %data ;
$extras = 0 ;
my $status ;
for ( $status = $cursor->c_get($k, $v, DB_LAST) ;
$status == 0 ;
$status = $cursor->c_get($k, $v, DB_PREV)) {
if ( $copy{$k} eq $v )
{ delete $copy{$k} }
else
{ ++ $extras }
}
ok $status == DB_NOTFOUND ;
ok $status =~ $DB_errors{'DB_NOTFOUND'} ;
ok $cursor->status() == $status ;
ok $cursor->status() eq $status ;
ok keys %copy == 0 ;
ok $extras == 0 ;
}
{
# Tied Array interface
my $lex = new LexFile $Dfile ;
my @array ;
my $db ;
ok $db = tie @array, 'BerkeleyDB::Recno', -Filename => $Dfile,
-Property => DB_RENUMBER,
-ArrayBase => 0,
-Flags => DB_CREATE ;
ok my $cursor = ((tied @array)->db_cursor()) ;
# check the database is empty
my $count = 0 ;
my ($k, $v) = (0,"") ;
while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
++ $count ;
}
ok $cursor->status() == DB_NOTFOUND ;
ok $count == 0 ;
ok @array == 0 ;
# Add a k/v pair
my $value ;
$array[1] = "some value";
ok ((tied @array)->status() == 0) ;
ok $array[1] eq "some value";
ok defined $array[1];
ok ((tied @array)->status() == 0) ;
ok ! defined $array[1];
ok ((tied @array)->status() == DB_NOTFOUND) ;
$array[1] = 2 ;
$array[10] = 20 ;
$array[1000] = 2000 ;
my ($keys, $values) = (0,0);
$count = 0 ;
for ( my $status = $cursor->c_get($k, $v, DB_FIRST) ;
$status == 0 ;
$status = $cursor->c_get($k, $v, DB_NEXT)) {
$keys += $k ;
$values += $v ;
++ $count ;
}
ok $count == 3 ;
ok $keys == 1011 ;
ok $values == 2022 ;
# unshift
$FA ? unshift @array, "red", "green", "blue"
: $db->unshift("red", "green", "blue" ) ;
ok $array[1] eq "red" ;
ok $cursor->c_get($k, $v, DB_FIRST) == 0 ;
ok $k == 1 ;
ok $v eq "red" ;
ok $array[2] eq "green" ;
ok $cursor->c_get($k, $v, DB_NEXT) == 0 ;
ok $k == 2 ;
ok $v eq "green" ;
ok $array[3] eq "blue" ;
ok $cursor->c_get($k, $v, DB_NEXT) == 0 ;
ok $k == 3 ;
ok $v eq "blue" ;
ok $array[4] == 2 ;
ok $cursor->c_get($k, $v, DB_NEXT) == 0 ;
ok $k == 4 ;
ok $v == 2 ;
# shift
ok (($FA ? shift @array : $db->shift()) eq "red") ;
ok (($FA ? shift @array : $db->shift()) eq "green") ;
ok (($FA ? shift @array : $db->shift()) eq "blue") ;
ok (($FA ? shift @array : $db->shift()) == 2) ;
# push
$FA ? push @array, "the", "end"
: $db->push("the", "end") ;
ok $cursor->c_get($k, $v, DB_LAST) == 0 ;
ok $k == 1001 ;
ok $v eq "end" ;
ok $cursor->c_get($k, $v, DB_PREV) == 0 ;
ok $k == 1000 ;
ok $v eq "the" ;
ok $cursor->c_get($k, $v, DB_PREV) == 0 ;
ok $k == 999 ;
ok $v == 2000 ;
# pop
ok (( $FA ? pop @array : $db->pop ) eq "end") ;
ok (( $FA ? pop @array : $db->pop ) eq "the") ;
ok (( $FA ? pop @array : $db->pop ) == 2000) ;
undef $cursor;
# now clear the array
$FA ? @array = ()
: $db->clear() ;
ok $cursor = $db->db_cursor() ;
ok $cursor->c_get($k, $v, DB_FIRST) == DB_NOTFOUND ;
undef $cursor ;
undef $db ;
untie @array ;
}
{
# in-memory file
my @array ;
my $fd ;
my $value ;
my $ret = 0 ;
my $i ;
for ($i = 0 ; $i < @data ; ++$i) {
$ret += $db1->db_put($i, $data[$i]) ;
}
ok $ret == 0 ;
# should be able to see all the records
ok my $cursor = $db1->db_cursor() ;
my ($k, $v) = (0, "") ;
my $count = 0 ;
# sequence forwards
while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
++ $count ;
}
ok $count == 3 ;
undef $cursor ;
# now abort the transaction
ok $txn->txn_abort() == 0 ;
# there shouldn't be any records in the database
$count = 0 ;
# sequence forwards
ok $cursor = $db1->db_cursor() ;
while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
++ $count ;
}
ok $count == 0 ;
undef $txn ;
undef $cursor ;
undef $db1 ;
undef $env ;
untie @array ;
}
{
# db_stat
my $lex = new LexFile $Dfile ;
-Txn => $txn ;
eval { $db->db_close() ; } ;
ok $@ =~ /BerkeleyDB Aborting: attempted to close a database while a transaction was still open at/ ;
#print "[$@]\n" ;
$txn->txn_abort();
$db->db_close();
}
{
# closing a cursor & a database
my $lex = new LexFile $Dfile ;
my %hash ;
my $status ;
ok my $db = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile,
-Flags => DB_CREATE ;
ok my $cursor = $db->db_cursor() ;
ok $cursor->c_close() == 0 ;
eval { $status = $db->db_close() ; } ;
ok $status == 0 ;
ok $@ eq "" ;
#print "[$@]\n" ;
}
{
# closing a database with an open cursor
my $lex = new LexFile $Dfile ;
my %hash ;
ok my $db = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile,
-Flags => DB_CREATE ;
ok my $cursor = $db->db_cursor() ;
eval { $db->db_close() ; } ;
ok $@ =~ /\QBerkeleyDB Aborting: attempted to close a database with 1 open cursor(s) at/;
#print "[$@]\n" ;
}
{
# closing a transaction & a cursor
my $lex = new LexFile $Dfile ;
my %hash ;
my $status ;
my $home = 'fred1';
ok my $lexD = new LexDir($home);
ok my $env = new BerkeleyDB::Env -Home => $home,@StdErrFile,
-Flags => DB_CREATE|DB_INIT_TXN|
DB_INIT_MPOOL|DB_INIT_LOCK ;
ok my $txn = $env->txn_begin() ;
ok my $db = tie %hash, 'BerkeleyDB::Hash', -Filename => $Dfile,
-Flags => DB_CREATE ,
-Env => $env,
-Txn => $txn ;
ok my $cursor = $db->db_cursor() ;
eval { $status = $cursor->c_close() ; } ;
ok $status == 0 ;
ok $txn->txn_commit() == 0 ;
ok $@ eq "" ;
eval { $status = $db->db_close() ; } ;
ok $status == 0 ;
ok $@ eq "" ;
#print "[$@]\n" ;
eval { $status = $env->db_appexit() ; } ;
ok $status == 0 ;
ok $@ eq "" ;
umask(0) ;
sub countDatabases
{
my $file = shift ;
ok my $db = new BerkeleyDB::Unknown -Filename => $file ,
-Flags => DB_RDONLY ;
#my $type = $db->type() ; print "type $type\n" ;
ok my $cursor = $db->db_cursor() ;
my ($k, $v) = ("", "") ;
my $status ;
my @dbnames = () ;
while (($status = $cursor->c_get($k, $v, DB_NEXT)) == 0) {
push @dbnames, $k ;
}
ok $status == DB_NOTFOUND;
return wantarray ? sort @dbnames : scalar @dbnames ;
}
) ;
my $ret = 0 ;
while (my ($k, $v) = each %data) {
$ret += $db1->db_put($k, $v) ;
}
ok $ret == 0 ;
# should be able to see all the records
ok my $cursor = $db1->db_cursor() ;
my ($k, $v) = ("", "") ;
my $count = 0 ;
# sequence forwards
while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
++ $count ;
}
ok $count == 3 ;
undef $cursor ;
# now abort the transaction
ok $txn->txn_abort() == 0 ;
# there shouldn't be any records in the database
$count = 0 ;
# sequence forwards
ok $cursor = $db1->db_cursor() ;
while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
++ $count ;
}
ok $count == 0 ;
my $stat = $env->txn_stat() ;
ok $stat->{'st_naborts'} == 1 ;
undef $txn ;
undef $cursor ;
undef $db1 ;
undef $env ;
untie %hash ;
}
{
# transaction - abort works via txnmgr
my $lex = new LexFile $Dfile ;
my %hash ;
) ;
my $ret = 0 ;
while (my ($k, $v) = each %data) {
$ret += $db1->db_put($k, $v) ;
}
ok $ret == 0 ;
# should be able to see all the records
ok my $cursor = $db1->db_cursor() ;
my ($k, $v) = ("", "") ;
my $count = 0 ;
# sequence forwards
while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
++ $count ;
}
ok $count == 3 ;
undef $cursor ;
# now abort the transaction
ok $txn->txn_abort() == 0 ;
# there shouldn't be any records in the database
$count = 0 ;
# sequence forwards
ok $cursor = $db1->db_cursor() ;
while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
++ $count ;
}
ok $count == 0 ;
my $stat = $txn_mgr->txn_stat() ;
ok $stat->{'st_naborts'} == 1 ;
undef $txn ;
undef $cursor ;
undef $db1 ;
undef $txn_mgr ;
undef $env ;
untie %hash ;
}
{
# transaction - commit works
my $lex = new LexFile $Dfile ;
) ;
my $ret = 0 ;
while (my ($k, $v) = each %data) {
$ret += $db1->db_put($k, $v) ;
}
ok $ret == 0 ;
# should be able to see all the records
ok my $cursor = $db1->db_cursor() ;
my ($k, $v) = ("", "") ;
my $count = 0 ;
# sequence forwards
while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
++ $count ;
}
ok $count == 3 ;
undef $cursor ;
# now commit the transaction
ok $txn->txn_commit() == 0 ;
$count = 0 ;
# sequence forwards
ok $cursor = $db1->db_cursor() ;
while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
++ $count ;
}
ok $count == 3 ;
my $stat = $env->txn_stat() ;
ok $stat->{'st_naborts'} == 0 ;
undef $txn ;
undef $cursor ;
undef $db1 ;
undef $env ;
untie %hash ;
}
{
# transaction - commit works via txnmgr
my $lex = new LexFile $Dfile ;
my %hash ;
) ;
my $ret = 0 ;
while (my ($k, $v) = each %data) {
$ret += $db1->db_put($k, $v) ;
}
ok $ret == 0 ;
# should be able to see all the records
ok my $cursor = $db1->db_cursor() ;
my ($k, $v) = ("", "") ;
my $count = 0 ;
# sequence forwards
while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
++ $count ;
}
ok $count == 3 ;
undef $cursor ;
# now commit the transaction
ok $txn->txn_commit() == 0 ;
$count = 0 ;
# sequence forwards
ok $cursor = $db1->db_cursor() ;
while ($cursor->c_get($k, $v, DB_NEXT) == 0) {
++ $count ;
}
ok $count == 3 ;
my $stat = $txn_mgr->txn_stat() ;
ok $stat->{'st_naborts'} == 0 ;
undef $txn ;
undef $cursor ;
undef $db1 ;
undef $txn_mgr ;
undef $env ;
untie %hash ;
}
close(CAT);
}
sub joiner
{
my $db = shift ;
my $sep = shift ;
my ($k, $v) = (0, "") ;
my @data = () ;
my $cursor = $db->db_cursor() or return () ;
for ( my $status = $cursor->c_get($k, $v, DB_FIRST) ;
$status == 0 ;
$status = $cursor->c_get($k, $v, DB_NEXT)) {
push @data, $v ;
}
(scalar(@data), join($sep, @data)) ;
}
sub joinkeys
{
my $db = shift ;
my $sep = shift || " " ;
my ($k, $v) = (0, "") ;
my @data = () ;
my $cursor = $db->db_cursor() or return () ;
for ( my $status = $cursor->c_get($k, $v, DB_FIRST) ;
$status == 0 ;
$status = $cursor->c_get($k, $v, DB_NEXT)) {
push @data, $k ;
}
return join($sep, @data) ;
}
sub dumpdb
{
my $db = shift ;
my $sep = shift || " " ;
my ($k, $v) = (0, "") ;
my @data = () ;
my $cursor = $db->db_cursor() or return () ;
for ( my $status = $cursor->c_get($k, $v, DB_FIRST) ;
$status == 0 ;
$status = $cursor->c_get($k, $v, DB_NEXT)) {
print " [$k][$v]\n" ;
}
}
sub countRecords
{
my $db = shift ;
my ($k, $v) = (0,0) ;
my ($count) = 0 ;
my ($cursor) = $db->db_cursor() ;
#for ($status = $cursor->c_get($k, $v, DB_FIRST) ;
# $status == 0 ;
# $status = $cursor->c_get($k, $v, DB_NEXT) )
while ($cursor->c_get($k, $v, DB_NEXT) == 0)
{ ++ $count }
return $count ;
}
sub addData
{
my $db = shift ;
my @data = @_ ;
die "addData odd data\n" if @data % 2 != 0 ;
( run in 0.512 second using v1.01-cache-2.11-cpan-4d50c553e7e )