dbm.pm

Astercon2 开源软交换 2.2.0

#######################################################################
#
#  DBD::DBM - a DBI driver for DBM files
#
#  Copyright (c) 2004 by Jeff Zucker < jzucker AT cpan.org >
#
#  All rights reserved.
#
#  You may freely distribute and/or modify this  module under the terms
#  of either the GNU  General Public License (GPL) or the Artistic License,
#  as specified in the Perl README file.
#
#  USERS - see the pod at the bottom of this file
#
#  DBD AUTHORS - see the comments in the code
#
#######################################################################
require 5.005_03;
use strict;

#################
package DBD::DBM;
#################
use base qw( DBD::File );
use vars qw($VERSION $ATTRIBUTION $drh $methods_already_installed);
$VERSION     = '0.03';
$ATTRIBUTION = 'DBD::DBM by Jeff Zucker';

# no need to have driver() unless you need private methods
#
sub driver ($;$) {
    my($class, $attr) = @_;
    return $drh if $drh;

    # do the real work in DBD::File
    #
    $attr->{Attribution} = 'DBD::DBM by Jeff Zucker';
    my $this = $class->SUPER::driver($attr);

    # install private methods
    #
    # this requires that dbm_ (or foo_) be a registered prefix
    # but you can write private methods before official registration
    # by hacking the $dbd_prefix_registry in a private copy of DBI.pm
    #
    if ( $DBI::VERSION >= 1.37 and !$methods_already_installed++ ) {
        DBD::DBM::db->install_method('dbm_versions');
        DBD::DBM::st->install_method('dbm_schema');
    }

    $this;
}

sub CLONE {
    undef $drh;
}

#####################
package DBD::DBM::dr;
#####################
$DBD::DBM::dr::imp_data_size = 0;
@DBD::DBM::dr::ISA = qw(DBD::File::dr);

# you can get by without connect() if you don't have to check private
# attributes, DBD::File will gather the connection string arguements for you
#
sub connect ($$;$$$) {
    my($drh, $dbname, $user, $auth, $attr)= @_;

    # create a 'blank' dbh
    my $this = DBI::_new_dbh($drh, {
	Name => $dbname,
    });

    # parse the connection string for name=value pairs
    if ($this) {

        # define valid private attributes
        #
        # attempts to set non-valid attrs in connect() or
        # with $dbh->{attr} will throw errors
        #
        # the attrs here *must* start with dbm_ or foo_
        #
        # see the STORE methods below for how to check these attrs
        #
        $this->{dbm_valid_attrs} = {
            dbm_tables            => 1  # per-table information
          , dbm_type              => 1  # the global DBM type e.g. SDBM_File
          , dbm_mldbm             => 1  # the global MLDBM serializer
          , dbm_cols              => 1  # the global column names
          , dbm_version           => 1  # verbose DBD::DBM version
          , dbm_ext               => 1  # file extension
          , dbm_lockfile          => 1  # lockfile extension
          , dbm_store_metadata    => 1  # column names, etc.
          , dbm_berkeley_flags    => 1  # for BerkeleyDB
        };

	my($var, $val);
	$this->{f_dir} = $DBD::File::haveFileSpec ? File::Spec->curdir() : '.';
	while (length($dbname)) {
	    if ($dbname =~ s/^((?:[^\\;]|\\.)*?);//s) {
		$var = $1;
	    } else {
		$var = $dbname;
		$dbname = '';
	    }
	    if ($var =~ /^(.+?)=(.*)/s) {
		$var = $1;
		($val = $2) =~ s/\\(.)/$1/g;

                # in the connect string the attr names
                # can either have dbm_ (or foo_) prepended or not
                # this will add the prefix if it's missing
                #
                $var = 'dbm_' . $var unless $var =~ /^dbm_/
                                     or     $var eq 'f_dir';
		# XXX should pass back to DBI via $attr for connect() to STORE
		$this->{$var} = $val;
	    }
	}
	$this->{f_version} = $DBD::File::VERSION;
        $this->{dbm_version} = $DBD::DBM::VERSION;
        for (qw( nano_version statement_version)) {
            $this->{'sql_'.$_} = $DBI::SQL::Nano::versions->{$_}||'';
        }
        $this->{sql_handler} = ($this->{sql_statement_version})
                             ? 'SQL::Statement'
   	                     : 'DBI::SQL::Nano';
    }
    $this->STORE('Active',1);
    return $this;
}

# you could put some :dr private methods here

# you may need to over-ride some DBD::File::dr methods here
# but you can probably get away with just letting it do the work
# in most cases

#####################
package DBD::DBM::db;
#####################
$DBD::DBM::db::imp_data_size = 0;
@DBD::DBM::db::ISA = qw(DBD::File::db);

# the ::db::STORE method is what gets called when you set
# a lower-cased database handle attribute such as $dbh->{somekey}=$someval;
#
# STORE should check to make sure that "somekey" is a valid attribute name
# but only if it is really one of our attributes (starts with dbm_ or foo_)
# You can also check for valid values for the attributes if needed
# and/or perform other operations
#
sub STORE ($$$) {
    my ($dbh, $attrib, $value) = @_;

    # use DBD::File's STORE unless its one of our own attributes
    #
    return $dbh->SUPER::STORE($attrib,$value) unless $attrib =~ /^dbm_/;

    # throw an error if it has our prefix but isn't a valid attr name
    #
    if ( $attrib ne 'dbm_valid_attrs'          # gotta start somewhere :-)
     and !$dbh->{dbm_valid_attrs}->{$attrib} ) {
        return $dbh->set_err( 1,"Invalid attribute '$attrib'!");
    }
    else {

        # check here if you need to validate values
        # or conceivably do other things as well
        #
	$dbh->{$attrib} = $value;
        return 1;
    }
}

# and FETCH is done similar to STORE
#
sub FETCH ($$) {
    my ($dbh, $attrib) = @_;

    return $dbh->SUPER::FETCH($attrib) unless $attrib =~ /^dbm_/;

    # throw an error if it has our prefix but isn't a valid attr name
    #
    if ( $attrib ne 'dbm_valid_attrs'          # gotta start somewhere :-)
     and !$dbh->{dbm_valid_attrs}->{$attrib} ) {
        return $dbh->set_err( 1,"Invalid attribute '$attrib'");
    }
    else {

        # check here if you need to validate values
        # or conceivably do other things as well
        #
	return $dbh->{$attrib};
    }
}


# this is an example of a private method
# these used to be done with $dbh->func(...)
# see above in the driver() sub for how to install the method
#
sub dbm_versions {
    my $dbh   = shift;
    my $table = shift || '';
    my $dtype = $dbh->{dbm_tables}->{$table}->{type}
             || $dbh->{dbm_type}
             || 'SDBM_File';
    my $mldbm = $dbh->{dbm_tables}->{$table}->{mldbm}
             || $dbh->{dbm_mldbm}
             || '';
    $dtype   .= ' + MLDBM + ' . $mldbm if $mldbm;

    my %version = ( DBI => $DBI::VERSION );
    $version{"DBI::PurePerl"} = $DBI::PurePerl::VERSION	if $DBI::PurePerl;
    $version{OS}   = "$^O ($Config::Config{osvers})";
    $version{Perl} = "$] ($Config::Config{archname})";
    my $str = sprintf "%-16s %s\n%-16s %s\n%-16s %s\n",
      'DBD::DBM'         , $dbh->{Driver}->{Version} . " using $dtype"
    , '  DBD::File'      , $dbh->{f_version}
    , '  DBI::SQL::Nano' , $dbh->{sql_nano_version}
    ;
    $str .= sprintf "%-16s %s\n",
    , '  SQL::Statement' , $dbh->{sql_statement_version}
      if $dbh->{sql_handler} eq 'SQL::Statement';
    for (sort keys %version) {
        $str .= sprintf "%-16s %s\n", $_, $version{$_};
    }
    return "$str\n";
}

# you may need to over-ride some DBD::File::db methods here
# but you can probably get away with just letting it do the work
# in most cases

#####################
package DBD::DBM::st;
#####################
$DBD::DBM::st::imp_data_size = 0;
@DBD::DBM::st::ISA = qw(DBD::File::st);

sub dbm_schema {
    my($sth,$tname)=@_;
    return $sth->set_err(1,'No table name supplied!') unless $tname;
    return $sth->set_err(1,"Unknown table '$tname'!")
       unless $sth->{Database}->{dbm_tables}
          and $sth->{Database}->{dbm_tables}->{$tname};
    return $sth->{Database}->{dbm_tables}->{$tname}->{schema};
}
# you could put some :st private methods here

# you may need to over-ride some DBD::File::st methods here
# but you can probably get away with just letting it do the work
# in most cases

############################
package DBD::DBM::Statement;
############################
use base qw( DBD::File::Statement );
use IO::File;  # for locking only
use Fcntl;

my $HAS_FLOCK = eval { flock STDOUT, 0; 1 };

# you must define open_table;
# it is done at the start of all executes;
# it doesn't necessarily have to "open" anything;
# you must define the $tbl and at least the col_names and col_nums;
# anything else you put in depends on what you need in your
# ::Table methods below; you must bless the $tbl into the
# appropriate class as shown
#
# see also the comments inside open_table() showing the difference
# between global, per-table, and default settings
#
sub open_table ($$$$$) {
    my($self, $data, $table, $createMode, $lockMode) = @_;
    my $dbh = $data->{Database};

    my $tname = $table || $self->{tables}->[0]->{name};
    my $file;
    ($table,$file) = $self->get_file_name($data,$tname);

    # note the use of three levels of attribute settings below
    # first it looks for a per-table setting
    # if none is found, it looks for a global setting
    # if none is found, it sets a default
    #
    # your DBD may not need this, gloabls and defaults may be enough
    #
    my $dbm_type = $dbh->{dbm_tables}->{$tname}->{type}
                || $dbh->{dbm_type}
                || 'SDBM_File';
    $dbh->{dbm_tables}->{$tname}->{type} = $dbm_type;

    my $serializer = $dbh->{dbm_tables}->{$tname}->{mldbm}
                  || $dbh->{dbm_mldbm}
                  || '';
    $dbh->{dbm_tables}->{$tname}->{mldbm} = $serializer if $serializer;

    my $ext =  '' if $dbm_type eq 'GDBM_File'
                  or $dbm_type eq 'DB_File'
                  or $dbm_type eq 'BerkeleyDB';
    # XXX NDBM_File on FreeBSD (and elsewhere?) may actually be Berkeley
    # behind the scenes and so create a single .db file.
    $ext = '.pag' if $dbm_type eq 'NDBM_File'
                  or $dbm_type eq 'SDBM_File'
                  or $dbm_type eq 'ODBM_File';
    $ext = $dbh->{dbm_ext} if defined $dbh->{dbm_ext};
    $ext = $dbh->{dbm_tables}->{$tname}->{ext}
        if defined $dbh->{dbm_tables}->{$tname}->{ext};
    $ext = '' unless defined $ext;

    my $open_mode = O_RDONLY;
       $open_mode = O_RDWR                 if $lockMode;
       $open_mode = O_RDWR|O_CREAT|O_TRUNC if $createMode;

    my($tie_type);

    if ( $serializer ) {
       require 'MLDBM.pm';
       $MLDBM::UseDB      = $dbm_type;
       $MLDBM::UseDB      = 'BerkeleyDB::Hash' if $dbm_type eq 'BerkeleyDB';
       $MLDBM::Serializer = $serializer;