view release on metacpan or  search on metacpan

BerkeleyDB.pm  view on Meta::CPAN

    #print "Tie method REF=[$self] [" . (ref $self) . "]\n" ;

    croak("usage \$x->Tie \\%hash\n") unless @_ ;
    my $ref  = shift ;

    croak("Tie needs a reference to a hash")
	if defined $ref and $ref !~ /HASH/ ;

    #tie %{ $ref }, ref($self), $self ;
    tie %{ $ref }, "BerkeleyDB::_tiedHash", $self ;
    return undef ;
}


sub TIEHASH
{
    my $self = shift ;
    my $db_object = shift ;
    #return bless $db_object, 'BerkeleyDB::Common' ;
    return $db_object ;
}

sub STORE
{
    my $self = shift ;
    my $key  = shift ;
    my $value = shift ;

    $self->db_put($key, $value) ;
}

sub FETCH
{
    my $self = shift ;
    my $key  = shift ;
    my $value = undef ;
    $self->db_get($key, $value) ;

    return $value ;
}

sub EXISTS
{
    my $self = shift ;
    my $key  = shift ;
    my $value = undef ;
    $self->db_get($key, $value) == 0 ;
}

sub DELETE
{
    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 ;

#sub DESTROY
#{
#    my $self = shift ;
#    print "BerkeleyDB::_tieHash::DESTROY\n" ;
#    $self->{Cursor}->c_close() if $self->{Cursor} ;
#}

package BerkeleyDB::_tiedArray ;

use Carp ;

sub Tie
{
    # Usage:
    #
    #   $db->Tie \@array ;
    #

    my $self = shift ;

    #print "Tie method REF=[$self] [" . (ref $self) . "]\n" ;

    croak("usage \$x->Tie \\%hash\n") unless @_ ;
    my $ref  = shift ;

    croak("Tie needs a reference to an array")
	if defined $ref and $ref !~ /ARRAY/ ;

    #tie %{ $ref }, ref($self), $self ;
    tie @{ $ref }, "BerkeleyDB::_tiedArray", $self ;
    return undef ;
}


#sub TIEARRAY
#{
#    my $self = shift ;
#    my $db_object = shift ;
#
#print "Tiearray REF=[$self] [" . (ref $self) . "]\n" ;
#
#    return bless { Obj => $db_object}, $self ;
#}

sub TIEARRAY
{
    my $self = shift ;
    my $db_object = shift ;
    #return bless $db_object, 'BerkeleyDB::Common' ;
    return $db_object ;
}

sub STORE
{
    my $self = shift ;
    my $key  = shift ;
    my $value = shift ;

    $self->db_put($key, $value) ;
}

sub FETCH
{
    my $self = shift ;
    my $key  = shift ;
    my $value = undef ;
    $self->db_get($key, $value) ;

    return $value ;
}

*CLEAR =    \&BerkeleyDB::_tiedHash::CLEAR ;
*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" ;
}

*shift = \&SHIFT ;
*unshift = \&UNSHIFT ;
*push = \&PUSH ;
*pop = \&POP ;
*clear = \&CLEAR ;
*length = \&FETCHSIZE ;

sub STORESIZE
{
    croak "STORESIZE is not implemented yet" ;
#print "STORESIZE @_\n" ;
#    my $self = shift;
#    my $length = shift ;
#    my $current_length = $self->FETCHSIZE() ;
#print "length is $current_length\n";
#
#    if ($length < $current_length) {
#print "Make smaller $length < $current_length\n" ;
#        my $key ;
#        for ($key = $current_length - 1 ; $key >= $length ; -- $key)
#          { $self->db_del($key) }
#    }
#    elsif ($length > $current_length) {
#print "Make larger $length > $current_length\n" ;
#        $self->db_put($length-1, "") ;
#    }
#    else { print "stay the same\n" }

}



#sub DESTROY
#{
#    my $self = shift ;
#    print "BerkeleyDB::_tieArray::DESTROY\n" ;
#}


package BerkeleyDB::Common ;


use Carp ;


sub STORABLE_freeze
{
    my $type = ref shift;
    croak "Cannot freeze $type object\n";
}

sub STORABLE_thaw
{
    my $type = ref shift;
    croak "Cannot thaw $type object\n";
}

sub DESTROY
{
    my $self = shift ;
    $self->_DESTROY() ;
}
sub Env
{
    my $self = shift ;
    $self->[1] ;
}

sub Txn
{
    my $self = shift ;
    my $txn  = shift ;
    #print "BerkeleyDB::Common::Txn db [$self] txn [$txn]\n" ;
    if ($txn) {
        $self->_Txn($txn) ;
        push @{ $txn }, $self ;
    }
    else {
        $self->_Txn() ;
    }
    #print "end BerkeleyDB::Common::Txn \n";
}


sub get_dup
{
    croak "Usage: \$db->get_dup(key [,flag])\n"
        unless @_ == 2 or @_ == 3 ;

    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() ;
}


package BerkeleyDB::TxnMgr ;

sub DESTROY
{
    my $self = shift ;
    $self->_DESTROY() ;
}

sub txn_begin
{
    my $txnmgr = shift ;
    my ($addr) = $txnmgr->_txn_begin(@_) ;
    my $obj ;
    $obj = bless [$addr, $txnmgr] , "BerkeleyDB::Txn" if $addr ;
    return $obj ;
}

package BerkeleyDB::Txn ;

sub Txn
{
    my $self = shift ;
    my $db ;
    # keep a reference to each db in the txn object
    foreach $db (@_) {
        $db->_Txn($self) ;
	push @{ $self}, $db ;
    }
}

sub txn_commit
{
    my $self = shift ;
    $self->disassociate() ;
    my $status = $self->_txn_commit() ;
    return $status ;
}

sub txn_abort
{
    my $self = shift ;
    $self->disassociate() ;
    my $status = $self->_txn_abort() ;
    return $status ;
}

sub disassociate
{
    my $self = shift ;
    my $db ;
    while ( @{ $self } > 2) {
        $db = pop @{ $self } ;
        $db->Txn() ;
    }
    #print "end disassociate\n" ;
}


sub DESTROY
{
    my $self = shift ;

    $self->disassociate() ;
    # first close the close the transaction
    $self->_DESTROY() ;
}

package BerkeleyDB::CDS::Lock;

use vars qw(%Object %Count);
use Carp;

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
{
    my $self = shift ;
    my $db = $self->[0] ;

    if ($self->[1])
    {
        $self->[1] = 0 ;
        -- $Count{"$db"} if $Count{"$db"} > 0 ;

        if ($Count{"$db"} == 0)
        {
            $Object{"$db"}->c_close() ;
            delete $Object{"$db"};
            delete $Count{"$db"};
        }

        return 1 ;
    }

    return undef ;
}

sub DESTROY
{
    my $self = shift ;
    $self->cds_unlock() ;
}

package BerkeleyDB::Term ;

END
{
    close_everything() ;
}


package BerkeleyDB ;




1;
__END__