berkeleydb.pm

BerkeleyDB源码

					Config		=> undef,
					}, @_) ;

    if (defined $got->{Config}) {
    	croak("Config parameter must be a hash reference")
            if ! ref $got->{Config} eq 'HASH' ;

        @BerkeleyDB::a = () ;
	my $k = "" ; my $v = "" ;
	while (($k, $v) = each %{$got->{Config}}) {
	    push @BerkeleyDB::a, "$k\t$v" ;
	}

        $got->{"Config"} = pack("p*", @BerkeleyDB::a, undef) 
	    if @BerkeleyDB::a ;
    }

    return _env_remove($got) ;
}

sub db_remove
{
    my $got = BerkeleyDB::ParseParameters(
		      {
			Filename 	=> undef,
			Subname		=> undef,
			Flags		=> 0,
			Env		=> undef,
			Txn		=> undef,
		      }, @_) ;

    croak("Must specify a filename")
	if ! defined $got->{Filename} ;

    croak("Env not of type BerkeleyDB::Env")
	if defined $got->{Env} and ! isa($got->{Env},'BerkeleyDB::Env');

    return _db_remove($got);
}

sub db_rename
{
    my $got = BerkeleyDB::ParseParameters(
		      {
			Filename 	=> undef,
			Subname		=> undef,
			Newname		=> undef,
			Flags		=> 0,
			Env		=> undef,
			Txn		=> undef,
		      }, @_) ;

    croak("Env not of type BerkeleyDB::Env")
	if defined $got->{Env} and ! isa($got->{Env},'BerkeleyDB::Env');

    croak("Must specify a filename")
	if ! defined $got->{Filename} ;

    #croak("Must specify a Subname")
    #if ! defined $got->{Subname} ;

    croak("Must specify a Newname")
	if ! defined $got->{Newname} ;

    return _db_rename($got);
}

sub db_verify
{
    my $got = BerkeleyDB::ParseParameters(
		      {
			Filename 	=> undef,
			Subname		=> undef,
			Outfile		=> undef,
			Flags		=> 0,
			Env		=> undef,
		      }, @_) ;

    croak("Env not of type BerkeleyDB::Env")
	if defined $got->{Env} and ! isa($got->{Env},'BerkeleyDB::Env');

    croak("Must specify a filename")
	if ! defined $got->{Filename} ;

    return _db_verify($got);
}

package BerkeleyDB::Env ;

use UNIVERSAL qw( isa ) ;
use Carp ;
use IO::File;
use vars qw( %valid_config_keys ) ;

sub isaFilehandle
{
    my $fh = shift ;

    return ((isa($fh,'GLOB') or isa(\$fh,'GLOB')) and defined fileno($fh) )

}

%valid_config_keys = map { $_, 1 } qw( DB_DATA_DIR DB_LOG_DIR DB_TEMP_DIR
DB_TMP_DIR ) ;

sub new
{
    # Usage:
    #
    #	$env = new BerkeleyDB::Env
    #			[ -Home		=> $path, ]
    #			[ -Mode		=> mode, ]
    #			[ -Config	=> { name => value, name => value }
    #			[ -ErrFile   	=> filename, ]
    #			[ -ErrPrefix 	=> "string", ]
    #			[ -Flags	=> DB_INIT_LOCK| ]
    #			[ -Set_Flags	=> $flags,]
    #			[ -Cachesize	=> number ]
    #			[ -LockDetect	=>  ]
    #			[ -Verbose	=> boolean ]
    #			[ -Encrypt	=> { Password => string, Flags => value}
    #
    #			;

    my $pkg = shift ;
    my $got = BerkeleyDB::ParseParameters({
					Home		=> undef,
					Server		=> undef,
					Mode		=> 0666,
					ErrFile  	=> undef,
					ErrPrefix 	=> undef,
					Flags     	=> 0,
					SetFlags     	=> 0,
					Cachesize     	=> 0,
					LockDetect     	=> 0,
					Verbose		=> 0,
					Config		=> undef,
					Encrypt		=> undef,
					SharedMemKey	=> undef,
					}, @_) ;

    my $errfile  = $got->{ErrFile} ;				
    if (defined $got->{ErrFile}) {
	if (!isaFilehandle($got->{ErrFile})) {
	    my $handle = new IO::File ">$got->{ErrFile}"
		or croak "Cannot open file $got->{ErrFile}: $!\n" ;
	    $errfile = $got->{ErrFile} = $handle ;
	}
    }

    my %config ;
    if (defined $got->{Config}) {
    	croak("Config parameter must be a hash reference")
            if ! ref $got->{Config} eq 'HASH' ;

	%config = %{ $got->{Config} } ;
        @BerkeleyDB::a = () ;
	my $k = "" ; my $v = "" ;
	while (($k, $v) = each %config) {
	    if ($BerkeleyDB::db_version >= 3.1 && ! $valid_config_keys{$k} ){
	        $BerkeleyDB::Error = "illegal name-value pair: $k $v\n" ; 
                croak $BerkeleyDB::Error ;
	    }
	    push @BerkeleyDB::a, "$k\t$v" ;
	}

        $got->{"Config"} = pack("p*", @BerkeleyDB::a, undef) 
	    if @BerkeleyDB::a ;
    }

    BerkeleyDB::parseEncrypt($got);

    my ($addr) = _db_appinit($pkg, $got, $errfile) ;
    my $obj ;
    $obj = bless [$addr] , $pkg if $addr ;
    if ($obj && $BerkeleyDB::db_version >= 3.1 && keys %config) {
	my ($k, $v);
	while (($k, $v) = each %config) {
	    if ($k eq 'DB_DATA_DIR')
	      { $obj->set_data_dir($v) }
	    elsif ($k eq 'DB_LOG_DIR')
	      { $obj->set_lg_dir($v) }
	    elsif ($k eq 'DB_TEMP_DIR' || $k eq 'DB_TMP_DIR')
	      { $obj->set_tmp_dir($v) }
	    else {
	      $BerkeleyDB::Error = "illegal name-value pair: $k $v\n" ; 
              croak $BerkeleyDB::Error 
            }
	}
    }
    return $obj ;
}


sub TxnMgr
{
    my $env = shift ;
    my ($addr) = $env->_TxnMgr() ;
    my $obj ;
    $obj = bless [$addr, $env] , "BerkeleyDB::TxnMgr" if $addr ;
    return $obj ;
}

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

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

package BerkeleyDB::Hash ;

use vars qw(@ISA) ;
@ISA = qw( BerkeleyDB::Common BerkeleyDB::_tiedHash ) ;
use UNIVERSAL qw( isa ) ;
use Carp ;

sub new
{
    my $self = shift ;
    my $got = BerkeleyDB::ParseParameters(
		      {
			# Generic Stuff
			Filename 	=> undef,
			Subname		=> undef,
			#Flags		=> BerkeleyDB::DB_CREATE(),
			Flags		=> 0,
			Property	=> 0,
			Mode		=> 0666,
			Cachesize 	=> 0,
			Lorder 		=> 0,
			Pagesize 	=> 0,
			Env		=> undef,
			#Tie 		=> undef,
			Txn		=> undef,
			Encrypt		=> undef,

			# Hash specific
			Ffactor		=> 0,
			Nelem 		=> 0,
			Hash 		=> undef,
			DupCompare	=> undef,

			# BerkeleyDB specific
			ReadKey		=> undef,
			WriteKey	=> undef,
			ReadValue	=> undef,
			WriteValue	=> undef,
		      }, @_) ;

    croak("Env not of type BerkeleyDB::Env")
	if defined $got->{Env} and ! isa($got->{Env},'BerkeleyDB::Env');

    croak("Txn not of type BerkeleyDB::Txn")
	if defined $got->{Txn} and ! isa($got->{Txn},'BerkeleyDB::Txn');

    croak("-Tie needs a reference to a hash")
	if defined $got->{Tie} and $got->{Tie} !~ /HASH/ ;

    BerkeleyDB::parseEncrypt($got);

    my ($addr) = _db_open_hash($self, $got);
    my $obj ;
    if ($addr) {
        $obj = bless [$addr] , $self ;
	push @{ $obj }, $got->{Env} if $got->{Env} ;
        $obj->Txn($got->{Txn}) 
            if $got->{Txn} ;
    }
    return $obj ;
}

*TIEHASH = \&new ;

 
package BerkeleyDB::Btree ;

use vars qw(@ISA) ;
@ISA = qw( BerkeleyDB::Common BerkeleyDB::_tiedHash ) ;
use UNIVERSAL qw( isa ) ;
use Carp ;

sub new
{
    my $self = shift ;
    my $got = BerkeleyDB::ParseParameters(
		      {
			# Generic Stuff
			Filename 	=> undef,
			Subname		=> undef,
			#Flags		=> BerkeleyDB::DB_CREATE(),
			Flags		=> 0,
			Property	=> 0,
			Mode		=> 0666,
			Cachesize 	=> 0,
			Lorder 		=> 0,
			Pagesize 	=> 0,
			Env		=> undef,
			#Tie 		=> undef,
			Txn		=> undef,
			Encrypt		=> undef,

			# Btree specific
			Minkey		=> 0,
			Compare		=> undef,
			DupCompare	=> undef,
			Prefix 		=> undef,
		      }, @_) ;

    croak("Env not of type BerkeleyDB::Env")
	if defined $got->{Env} and ! isa($got->{Env},'BerkeleyDB::Env');

    croak("Txn not of type BerkeleyDB::Txn")
	if defined $got->{Txn} and ! isa($got->{Txn},'BerkeleyDB::Txn');

    croak("-Tie needs a reference to a hash")
	if defined $got->{Tie} and $got->{Tie} !~ /HASH/ ;

    BerkeleyDB::parseEncrypt($got);

    my ($addr) = _db_open_btree($self, $got);
    my $obj ;
    if ($addr) {
        $obj = bless [$addr] , $self ;
	push @{ $obj }, $got->{Env} if $got->{Env} ;
        $obj->Txn($got->{Txn}) 
            if $got->{Txn} ;
    }
    return $obj ;
}

*BerkeleyDB::Btree::TIEHASH = \&BerkeleyDB::Btree::new ;


package BerkeleyDB::Recno ;

use vars qw(@ISA) ;
@ISA = qw( BerkeleyDB::Common BerkeleyDB::_tiedArray ) ;
use UNIVERSAL qw( isa ) ;
use Carp ;

sub new
{
    my $self = shift ;
    my $got = BerkeleyDB::ParseParameters(
		      {
			# Generic Stuff
			Filename 	=> undef,
			Subname		=> undef,
			#Flags		=> BerkeleyDB::DB_CREATE(),
			Flags		=> 0,
			Property	=> 0,
			Mode		=> 0666,
			Cachesize 	=> 0,
			Lorder 		=> 0,
			Pagesize 	=> 0,
			Env		=> undef,
			#Tie 		=> undef,
			Txn		=> undef,
			Encrypt		=> undef,

			# Recno specific
			Delim		=> undef,
			Len		=> undef,
			Pad		=> undef,
			Source 		=> undef,
			ArrayBase 	=> 1, # lowest index in array
		      }, @_) ;

    croak("Env not of type BerkeleyDB::Env")
	if defined $got->{Env} and ! isa($got->{Env},'BerkeleyDB::Env');

    croak("Txn not of type BerkeleyDB::Txn")
	if defined $got->{Txn} and ! isa($got->{Txn},'BerkeleyDB::Txn');

    croak("Tie needs a reference to an array")
	if defined $got->{Tie} and $got->{Tie} !~ /ARRAY/ ;

    croak("ArrayBase can only be 0 or 1, parsed $got->{ArrayBase}")
	if $got->{ArrayBase} != 1 and $got->{ArrayBase} != 0 ;


    BerkeleyDB::parseEncrypt($got);

    $got->{Fname} = $got->{Filename} if defined $got->{Filename} ;

    my ($addr) = _db_open_recno($self, $got);
    my $obj ;
    if ($addr) {
        $obj = bless [$addr] , $self ;
	push @{ $obj }, $got->{Env} if $got->{Env} ;
        $obj->Txn($got->{Txn}) 
            if $got->{Txn} ;
    }	
    return $obj ;
}

*BerkeleyDB::Recno::TIEARRAY = \&BerkeleyDB::Recno::new ;
*BerkeleyDB::Recno::db_stat = \&BerkeleyDB::Btree::db_stat ;

package BerkeleyDB::Queue ;

use vars qw(@ISA) ;
@ISA = qw( BerkeleyDB::Common BerkeleyDB::_tiedArray ) ;
use UNIVERSAL qw( isa ) ;
use Carp ;

sub new
{
    my $self = shift ;
    my $got = BerkeleyDB::ParseParameters(
		      {
			# Generic Stuff
			Filename 	=> undef,
			Subname		=> undef,
			#Flags		=> BerkeleyDB::DB_CREATE(),
			Flags		=> 0,
			Property	=> 0,
			Mode		=> 0666,
			Cachesize 	=> 0,
			Lorder 		=> 0,
			Pagesize 	=> 0,
			Env		=> undef,
			#Tie 		=> undef,
			Txn		=> undef,
			Encrypt		=> undef,

			# Queue specific
			Len		=> undef,
			Pad		=> undef,
			ArrayBase 	=> 1, # lowest index in array
			ExtentSize      => undef,
		      }, @_) ;

    croak("Env not of type BerkeleyDB::Env")
	if defined $got->{Env} and ! isa($got->{Env},'BerkeleyDB::Env');

    croak("Txn not of type BerkeleyDB::Txn")
	if defined $got->{Txn} and ! isa($got->{Txn},'BerkeleyDB::Txn');

    croak("Tie needs a reference to an array")
	if defined $got->{Tie} and $got->{Tie} !~ /ARRAY/ ;

    croak("ArrayBase can only be 0 or 1, parsed $got->{ArrayBase}")
	if $got->{ArrayBase} != 1 and $got->{ArrayBase} != 0 ;

    BerkeleyDB::parseEncrypt($got);

    $got->{Fname} = $got->{Filename} if defined $got->{Filename} ;

    my ($addr) = _db_open_queue($self, $got);
    my $obj ;
    if ($addr) {
        $obj = bless [$addr] , $self ;
	push @{ $obj }, $got->{Env} if $got->{Env} ;
        $obj->Txn($got->{Txn})
            if $got->{Txn} ;
    }	
    return $obj ;
}

*BerkeleyDB::Queue::TIEARRAY = \&BerkeleyDB::Queue::new ;

sub UNSHIFT
{
    my $self = shift;
    croak "unshift is unsupported with Queue databases";
}

## package BerkeleyDB::Text ;
## 
## use vars qw(@ISA) ;
## @ISA = qw( BerkeleyDB::Common BerkeleyDB::_tiedArray ) ;
## use UNIVERSAL qw( isa ) ;
## use Carp ;
## 
## sub new
## {
##     my $self = shift ;
##     my $got = BerkeleyDB::ParseParameters(
## 		      {
## 			# Generic Stuff
## 			Filename 	=> undef,
## 			#Flags		=> BerkeleyDB::DB_CREATE(),
## 			Flags		=> 0,
## 			Property	=> 0,
## 			Mode		=> 0666,
## 			Cachesize 	=> 0,
## 			Lorder 		=> 0,
## 			Pagesize 	=> 0,
## 			Env		=> undef,
## 			#Tie 		=> undef,
## 			Txn		=> undef,
## 
## 			# Recno specific
## 			Delim		=> undef,
## 			Len		=> undef,
## 			Pad		=> undef,
## 			Btree 		=> undef,
## 		      }, @_) ;
## 
##     croak("Env not of type BerkeleyDB::Env")
## 	if defined $got->{Env} and ! isa($got->{Env},'BerkeleyDB::Env');
## 
##     croak("Txn not of type BerkeleyDB::Txn")
## 	if defined $got->{Txn} and ! isa($got->{Txn},'BerkeleyDB::Txn');
## 
##     croak("-Tie needs a reference to an array")
## 	if defined $got->{Tie} and $got->{Tie} !~ /ARRAY/ ;
## 
##     # rearange for recno
##     $got->{Source} = $got->{Filename} if defined $got->{Filename} ;
##     delete $got->{Filename} ;
##     $got->{Fname} = $got->{Btree} if defined $got->{Btree} ;
##     return BerkeleyDB::Recno::_db_open_recno($self, $got);
## }
## 
## *BerkeleyDB::Text::TIEARRAY = \&BerkeleyDB::Text::new ;
## *BerkeleyDB::Text::db_stat = \&BerkeleyDB::Btree::db_stat ;

package BerkeleyDB::Unknown ;

use vars qw(@ISA) ;
@ISA = qw( BerkeleyDB::Common BerkeleyDB::_tiedArray ) ;
use UNIVERSAL qw( isa ) ;
use Carp ;

sub new
{
    my $self = shift ;
    my $got = BerkeleyDB::ParseParameters(
		      {
			# Generic Stuff
			Filename 	=> undef,
			Subname		=> undef,
			#Flags		=> BerkeleyDB::DB_CREATE(),
			Flags		=> 0,
			Property	=> 0,
			Mode		=> 0666,
			Cachesize 	=> 0,
			Lorder 		=> 0,
			Pagesize 	=> 0,
			Env		=> undef,
			#Tie 		=> undef,
			Txn		=> undef,
			Encrypt		=> undef,

		      }, @_) ;

    croak("Env not of type BerkeleyDB::Env")
	if defined $got->{Env} and ! isa($got->{Env},'BerkeleyDB::Env');

    croak("Txn not of type BerkeleyDB::Txn")
	if defined $got->{Txn} and ! isa($got->{Txn},'BerkeleyDB::Txn');

    croak("-Tie needs a reference to a hash")