db_file.pm

UNIX下perl实现代码

# DB_File.pm -- Perl 5 interface to Berkeley DB 
#
# written by Paul Marquess ([e-mail])
# last modified 17th December 2000
# version 1.75
#
#     Copyright (c) 1995-2000 Paul Marquess. All rights reserved.
#     This program is free software; you can redistribute it and/or
#     modify it under the same terms as Perl itself.


package DB_File::HASHINFO ;

require 5.003 ;

use warnings;
use strict;
use Carp;
require Tie::Hash;
@DB_File::HASHINFO::ISA = qw(Tie::Hash);

sub new
{
    my $pkg = shift ;
    my %x ;
    tie %x, $pkg ;
    bless \%x, $pkg ;
}


sub TIEHASH
{
    my $pkg = shift ;

    bless { VALID => { map {$_, 1} 
		       qw( bsize ffactor nelem cachesize hash lorder)
		     }, 
	    GOT   => {}
          }, $pkg ;
}


sub FETCH 
{  
    my $self  = shift ;
    my $key   = shift ;

    return $self->{GOT}{$key} if exists $self->{VALID}{$key}  ;

    my $pkg = ref $self ;
    croak "${pkg}::FETCH - Unknown element '$key'" ;
}


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

    if ( exists $self->{VALID}{$key} )
    {
        $self->{GOT}{$key} = $value ;
        return ;
    }
    
    my $pkg = ref $self ;
    croak "${pkg}::STORE - Unknown element '$key'" ;
}

sub DELETE 
{
    my $self = shift ;
    my $key  = shift ;

    if ( exists $self->{VALID}{$key} )
    {
        delete $self->{GOT}{$key} ;
        return ;
    }
    
    my $pkg = ref $self ;
    croak "DB_File::HASHINFO::DELETE - Unknown element '$key'" ;
}

sub EXISTS
{
    my $self = shift ;
    my $key  = shift ;

    exists $self->{VALID}{$key} ;
}

sub NotHere
{
    my $self = shift ;
    my $method = shift ;

    croak ref($self) . " does not define the method ${method}" ;
}

sub FIRSTKEY { my $self = shift ; $self->NotHere("FIRSTKEY") }
sub NEXTKEY  { my $self = shift ; $self->NotHere("NEXTKEY") }
sub CLEAR    { my $self = shift ; $self->NotHere("CLEAR") }

package DB_File::RECNOINFO ;

use warnings;
use strict ;

@DB_File::RECNOINFO::ISA = qw(DB_File::HASHINFO) ;

sub TIEHASH
{
    my $pkg = shift ;

    bless { VALID => { map {$_, 1} 
		       qw( bval cachesize psize flags lorder reclen bfname )
		     },
	    GOT   => {},
          }, $pkg ;
}

package DB_File::BTREEINFO ;

use warnings;
use strict ;

@DB_File::BTREEINFO::ISA = qw(DB_File::HASHINFO) ;

sub TIEHASH
{
    my $pkg = shift ;

    bless { VALID => { map {$_, 1} 
		       qw( flags cachesize maxkeypage minkeypage psize 
			   compare prefix lorder )
	    	     },
	    GOT   => {},
          }, $pkg ;
}


package DB_File ;

use warnings;
use strict;
use vars qw($VERSION @ISA @EXPORT $AUTOLOAD $DB_BTREE $DB_HASH $DB_RECNO 
            $db_version $use_XSLoader
           ) ;
use Carp;


$VERSION = "1.75" ;

#typedef enum { DB_BTREE, DB_HASH, DB_RECNO } DBTYPE;
$DB_BTREE = new DB_File::BTREEINFO ;
$DB_HASH  = new DB_File::HASHINFO ;
$DB_RECNO = new DB_File::RECNOINFO ;

require Tie::Hash;
require Exporter;
use AutoLoader;
BEGIN {
    $use_XSLoader = 1 ;
    eval { require XSLoader } ;

    if ($@) {
        $use_XSLoader = 0 ;
        require DynaLoader;
        @ISA = qw(DynaLoader);
    }
}

push @ISA, qw(Tie::Hash Exporter);
@EXPORT = qw(
        $DB_BTREE $DB_HASH $DB_RECNO 

	BTREEMAGIC
	BTREEVERSION
	DB_LOCK
	DB_SHMEM
	DB_TXN
	HASHMAGIC
	HASHVERSION
	MAX_PAGE_NUMBER
	MAX_PAGE_OFFSET
	MAX_REC_NUMBER
	RET_ERROR
	RET_SPECIAL
	RET_SUCCESS
	R_CURSOR
	R_DUP
	R_FIRST
	R_FIXEDLEN
	R_IAFTER
	R_IBEFORE
	R_LAST
	R_NEXT
	R_NOKEY
	R_NOOVERWRITE
	R_PREV
	R_RECNOSYNC
	R_SETCURSOR
	R_SNAPSHOT
	__R_UNUSED

);

sub AUTOLOAD {
    my($constname);
    ($constname = $AUTOLOAD) =~ s/.*:://;
    my $val = constant($constname, @_ ? $_[0] : 0);
    if ($! != 0) {
	if ($! =~ /Invalid/ || $!{EINVAL}) {
	    $AutoLoader::AUTOLOAD = $AUTOLOAD;
	    goto &AutoLoader::AUTOLOAD;
	}
	else {
	    my($pack,$file,$line) = caller;
	    croak "Your vendor has not defined DB macro $constname, used at $file line $line.
";
	}
    }
    eval "sub $AUTOLOAD { $val }";
    goto &$AUTOLOAD;
}


eval {
    # Make all Fcntl O_XXX constants available for importing
    require Fcntl;
    my @O = grep /^O_/, @Fcntl::EXPORT;
    Fcntl->import(@O);  # first we import what we want to export
    push(@EXPORT, @O);
};

if ($use_XSLoader)
  { XSLoader::load("DB_File", $VERSION)}
else
  { bootstrap DB_File $VERSION }

# Preloaded methods go here.  Autoload methods go after __END__, and are
# processed by the autosplit program.

sub tie_hash_or_array
{
    my (@arg) = @_ ;
    my $tieHASH = ( (caller(1))[3] =~ /TIEHASH/ ) ;

    $arg[4] = tied %{ $arg[4] } 
	if @arg >= 5 && ref $arg[4] && $arg[4] =~ /=HASH/ && tied %{ $arg[4] } ;

    # make recno in Berkeley DB version 2 work like recno in version 1.
    if ($db_version > 1 and defined $arg[4] and $arg[4] =~ /RECNO/ and 
	$arg[1] and ! -e $arg[1]) {
	open(FH, ">$arg[1]") or return undef ;
	close FH ;
	chmod $arg[3] ? $arg[3] : 0666 , $arg[1] ;
    }

    DoTie_($tieHASH, @arg) ;
}

sub TIEHASH
{
    tie_hash_or_array(@_) ;
}

sub TIEARRAY
{
    tie_hash_or_array(@_) ;
}

sub CLEAR 
{
    my $self = shift;
    my $key = 0 ;
    my $value = "" ;
    my $status = $self->seq($key, $value, R_FIRST());
    my @keys;
 
    while ($status == 0) {
        push @keys, $key;
        $status = $self->seq($key, $value, R_NEXT());
    }
    foreach $key (reverse @keys) {
        my $s = $self->del($key); 
    }
}

sub EXTEND { }

sub STORESIZE
{
    my $self = shift;
    my $length = shift ;
    my $current_length = $self->length() ;

    if ($length < $current_length) {
	my $key ;
        for ($key = $current_length - 1 ; $key >= $length ; -- $key)
	  { $self->del($key) }
    }
    elsif ($length > $current_length) {
        $self->put($length-1, "") ;
    }
}
 
sub find_dup
{
    croak "Usage: \$db->find_dup(key,value)\n"
        unless @_ == 3 ;
 
    my $db        = shift ;
    my ($origkey, $value_wanted) = @_ ;
    my ($key, $value) = ($origkey, 0);
    my ($status) = 0 ;

    for ($status = $db->seq($key, $value, R_CURSOR() ) ;
         $status == 0 ;
         $status = $db->seq($key, $value, R_NEXT() ) ) {

        return 0 if $key eq $origkey and $value eq $value_wanted ;
    }

    return $status ;
}

sub del_dup
{
    croak "Usage: \$db->del_dup(key,value)\n"
        unless @_ == 3 ;
 
    my $db        = shift ;
    my ($key, $value) = @_ ;
    my ($status) = $db->find_dup($key, $value) ;
    return $status if $status != 0 ;

    $status = $db->del($key, R_CURSOR() ) ;
    return $status ;
}

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 ;
 
    # iterate through the database until either EOF ($status == 0)
    # or a different key is encountered ($key ne $origkey).
    for ($status = $db->seq($key, $value, R_CURSOR()) ;
	 $status == 0 and $key eq $origkey ;
         $status = $db->seq($key, $value, R_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) ;
}


1;
__END__

=head1 NAME

DB_File - Perl5 access to Berkeley DB version 1.x

=head1 SYNOPSIS

 use DB_File ;
 
 [$X =] tie %hash,  'DB_File', [$filename, $flags, $mode, $DB_HASH] ;
 [$X =] tie %hash,  'DB_File', $filename, $flags, $mode, $DB_BTREE ;
 [$X =] tie @array, 'DB_File', $filename, $flags, $mode, $DB_RECNO ;

 $status = $X->del($key [, $flags]) ;
 $status = $X->put($key, $value [, $flags]) ;
 $status = $X->get($key, $value [, $flags]) ;
 $status = $X->seq($key, $value, $flags) ;
 $status = $X->sync([$flags]) ;
 $status = $X->fd ;

 # BTREE only
 $count = $X->get_dup($key) ;
 @list  = $X->get_dup($key) ;
 %list  = $X->get_dup($key, 1) ;
 $status = $X->find_dup($key, $value) ;
 $status = $X->del_dup($key, $value) ;

 # RECNO only
 $a = $X->length;
 $a = $X->pop ;
 $X->push(list);
 $a = $X->shift;
 $X->unshift(list);

 # DBM Filters
 $old_filter = $db->filter_store_key  ( sub { ... } ) ;
 $old_filter = $db->filter_store_value( sub { ... } ) ;
 $old_filter = $db->filter_fetch_key  ( sub { ... } ) ;
 $old_filter = $db->filter_fetch_value( sub { ... } ) ;

 untie %hash ;
 untie @array ;

=head1 DESCRIPTION

B<DB_File> is a module which allows Perl programs to make use of the
facilities provided by Berkeley DB version 1.x (if you have a newer
version of DB, see L<Using DB_File with Berkeley DB version 2 or 3>).
It is assumed that you have a copy of the Berkeley DB manual pages at
hand when reading this documentation. The interface defined here
mirrors the Berkeley DB interface closely.

Berkeley DB is a C library which provides a consistent interface to a
number of database formats.  B<DB_File> provides an interface to all
three of the database types currently supported by Berkeley DB.

The file types are:

=over 5

=item B<DB_HASH>

This database type allows arbitrary key/value pairs to be stored in data
files. This is equivalent to the functionality provided by other
hashing packages like DBM, NDBM, ODBM, GDBM, and SDBM. Remember though,
the files created using DB_HASH are not compatible with any of the
other packages mentioned.

A default hashing algorithm, which will be adequate for most
applications, is built into Berkeley DB. If you do need to use your own
hashing algorithm it is possible to write your own in Perl and have
B<DB_File> use it instead.

=item B<DB_BTREE>

The btree format allows arbitrary key/value pairs to be stored in a
sorted, balanced binary tree.

As with the DB_HASH format, it is possible to provide a user defined
Perl routine to perform the comparison of keys. By default, though, the
keys are stored in lexical order.

=item B<DB_RECNO>

DB_RECNO allows both fixed-length and variable-length flat text files
to be manipulated using the same key/value pair interface as in DB_HASH
and DB_BTREE.  In this case the key will consist of a record (line)
number.

=back

=head2 Using DB_File with Berkeley DB version 2 or 3

Although B<DB_File> is intended to be used with Berkeley DB version 1,
it can also be used with version 2.or 3 In this case the interface is
limited to the functionality provided by Berkeley DB 1.x. Anywhere the
version 2 or 3 interface differs, B<DB_File> arranges for it to work
like version 1. This feature allows B<DB_File> scripts that were built
with version 1 to be migrated to version 2 or 3 without any changes.

If you want to make use of the new features available in Berkeley DB
2.x or greater, use the Perl module B<BerkeleyDB> instead.

B<Note:> The database file format has changed in both Berkeley DB
version 2 and 3. If you cannot recreate your databases, you must dump
any existing databases with the C<db_dump185> utility that comes with
Berkeley DB.
Once you have rebuilt DB_File to use Berkeley DB version 2 or 3, your
databases can be recreated using C<db_load>. Refer to the Berkeley DB
documentation for further details.

Please read L<"COPYRIGHT"> before using version 2.x or 3.x of Berkeley
DB with DB_File.

=head2 Interface to Berkeley DB

B<DB_File> allows access to Berkeley DB files using the tie() mechanism
in Perl 5 (for full details, see L<perlfunc/tie()>). This facility
allows B<DB_File> to access Berkeley DB files using either an
associative array (for DB_HASH & DB_BTREE file types) or an ordinary
array (for the DB_RECNO file type).

In addition to the tie() interface, it is also possible to access most
of the functions provided in the Berkeley DB API directly.
See L<THE API INTERFACE>.

=head2 Opening a Berkeley DB Database File

Berkeley DB uses the function dbopen() to open or create a database.
Here is the C prototype for dbopen():

      DB*
      dbopen (const char * file, int flags, int mode, 
              DBTYPE type, const void * openinfo)

The parameter C<type> is an enumeration which specifies which of the 3