dbm.pm

Astercon2 开源软交换 2.2.0

       $tie_type = 'MLDBM';
    }
    else {
       require "$dbm_type.pm";
       $tie_type = $dbm_type;
    }

    # Second-guessing the file extension isn't great here (or in general)
    # could replace this by trying to open the file in non-create mode
    # first and dieing if that succeeds.
    # Currently this test doesn't work where NDBM is actually Berkeley (.db)
    die "Cannot CREATE '$file$ext' because it already exists"
        if $createMode and (-e "$file$ext");

    # LOCKING
    #
    my($nolock,$lockext,$lock_table);
    $lockext = $dbh->{dbm_tables}->{$tname}->{lockfile};
    $lockext = $dbh->{dbm_lockfile} if !defined $lockext;
    if ( (defined $lockext and $lockext == 0) or !$HAS_FLOCK
    ) {
        undef $lockext;
        $nolock = 1;
    }
    else {
        $lockext ||= '.lck';
    }
    # open and flock the lockfile, creating it if necessary
    #
    if (!$nolock) {
        $lock_table = $self->SUPER::open_table(
            $data, "$table$lockext", $createMode, $lockMode
        );
    }

    # TIEING
    #
    # allow users to pass in a pre-created tied object
    #
    my @tie_args;
    if ($dbm_type eq 'BerkeleyDB') {
       my $DB_CREATE = 1;  # but import constants if supplied
       my $DB_RDONLY = 16; #
       my %flags;
       if (my $f = $dbh->{dbm_berkeley_flags}) {
           $DB_CREATE  = $f->{DB_CREATE} if $f->{DB_CREATE};
           $DB_RDONLY  = $f->{DB_RDONLY} if $f->{DB_RDONLY};
           delete $f->{DB_CREATE};
           delete $f->{DB_RDONLY};
           %flags = %$f;
       }
       $flags{'-Flags'} = $DB_RDONLY;
       $flags{'-Flags'} = $DB_CREATE if $lockMode or $createMode;
        my $t = 'BerkeleyDB::Hash';
           $t = 'MLDBM' if $serializer;
	@tie_args = ($t, -Filename=>$file, %flags);
    }
    else {
        @tie_args = ($tie_type, $file, $open_mode, 0666);
    }
    my %h;
    if ( $self->{command} ne 'DROP') {
	my $tie_class = shift @tie_args;
	eval { tie %h, $tie_class, @tie_args };
	die "Cannot tie(%h $tie_class @tie_args): $@" if $@;
    }


    # COLUMN NAMES
    #
    my $store = $dbh->{dbm_tables}->{$tname}->{store_metadata};
       $store = $dbh->{dbm_store_metadata} unless defined $store;
       $store = 1 unless defined $store;
    $dbh->{dbm_tables}->{$tname}->{store_metadata} = $store;

    my($meta_data,$schema,$col_names);
    $meta_data = $col_names = $h{"_metadata \0"} if $store;
    if ($meta_data and $meta_data =~ m~<dbd_metadata>(.+)</dbd_metadata>~is) {
        $schema  = $col_names = $1;
        $schema  =~ s~.*<schema>(.+)</schema>.*~$1~is;
        $col_names =~ s~.*<col_names>(.+)</col_names>.*~$1~is;
    }
    $col_names ||= $dbh->{dbm_tables}->{$tname}->{c_cols}
               || $dbh->{dbm_tables}->{$tname}->{cols}
               || $dbh->{dbm_cols}
               || ['k','v'];
    $col_names = [split /,/,$col_names] if (ref $col_names ne 'ARRAY');
    $dbh->{dbm_tables}->{$tname}->{cols}   = $col_names;
    $dbh->{dbm_tables}->{$tname}->{schema} = $schema;

    my $i;
    my %col_nums  = map { $_ => $i++ } @$col_names;

    my $tbl = {
	table_name     => $tname,
	file           => $file,
	ext            => $ext,
        hash           => \%h,
        dbm_type       => $dbm_type,
        store_metadata => $store,
        mldbm          => $serializer,
        lock_fh        => $lock_table->{fh},
        lock_ext       => $lockext,
        nolock         => $nolock,
	col_nums       => \%col_nums,
	col_names      => $col_names
    };

    my $class = ref($self);
    $class =~ s/::Statement/::Table/;
    bless($tbl, $class);
    $tbl;
}

########################
package DBD::DBM::Table;
########################
use base qw( DBD::File::Table );

# you must define drop
# it is called from execute of a SQL DROP statement
#
sub drop ($$) {
    my($self,$data) = @_;
    untie %{$self->{hash}} if $self->{hash};
    my $ext = $self->{ext};
    unlink $self->{file}.$ext if -f $self->{file}.$ext;
    unlink $self->{file}.'.dir' if -f $self->{file}.'.dir'
                               and $ext eq '.pag';
    if (!$self->{nolock}) {
        $self->{lock_fh}->close if $self->{lock_fh};
        unlink $self->{file}.$self->{lock_ext}
            if -f $self->{file}.$self->{lock_ext};
    }
    return 1;
}

# you must define fetch_row, it is called on all fetches;
# it MUST return undef when no rows are left to fetch;
# checking for $ary[0] is specific to hashes so you'll
# probably need some other kind of check for nothing-left.
# as Janis might say: "undef's just another word for
# nothing left to fetch" :-)
#
sub fetch_row ($$$) {
    my($self, $data, $row) = @_;
    # fetch with %each
    #
    my @ary = each %{$self->{hash}};
    @ary = each %{$self->{hash}} if $self->{store_metadata}
                                 and $ary[0]
                                 and $ary[0] eq "_metadata \0";

    my($key,$val) = @ary;
    return undef unless $key;
    my @row = (ref($val) eq 'ARRAY') ? ($key,@$val) : ($key,$val);
    return (@row) if wantarray;
    return \@row;

    # fetch without %each
    #
    # $self->{keys} = [sort keys %{$self->{hash}}] unless $self->{keys};
    # my $key = shift @{$self->{keys}};
    # $key = shift @{$self->{keys}} if $self->{store_metadata}
    #                             and $key
    #                             and $key eq "_metadata \0";
    # return undef unless defined $key;
    # my @ary;
    # $row = $self->{hash}->{$key};
    # if (ref $row eq 'ARRAY') {
    #   @ary = ( $key, @{$row} );
    # }
    # else {
    #    @ary = ($key,$row);
    # }
    # return (@ary) if wantarray;
    # return \@ary;
}

# you must define push_row
# it is called on inserts and updates
#
sub push_row ($$$) {
    my($self, $data, $row_aryref) = @_;
    my $key = shift @$row_aryref;
    if ( $self->{mldbm} ) {
        $self->{hash}->{$key}= $row_aryref;
    }
    else {
        $self->{hash}->{$key}=$row_aryref->[0];
    }
    1;
}

# this is where you grab the column names from a CREATE statement
# if you don't need to do that, it must be defined but can be empty
#
sub push_names ($$$) {
    my($self, $data, $row_aryref) = @_;
    $data->{Database}->{dbm_tables}->{$self->{table_name}}->{c_cols}
       = $row_aryref;
    next unless $self->{store_metadata};
    my $stmt = $data->{f_stmt};
    my $col_names = join ',', @{$row_aryref};
    my $schema = $data->{Database}->{Statement};
       $schema =~ s/^[^\(]+\((.+)\)$/$1/s;
       $schema = $stmt->schema_str if $stmt->can('schema_str');
    $self->{hash}->{"_metadata \0"} = "<dbd_metadata>"
                                    . "<schema>$schema</schema>"
                                    . "<col_names>$col_names</col_names>"
                                    . "</dbd_metadata>"
                                    ;
}

# fetch_one_row, delete_one_row, update_one_row
# are optimized for hash-style lookup without looping;
# if you don't need them, omit them, they're optional
# but, in that case you may need to define
# truncate() and seek(), see below
#
sub fetch_one_row ($$;$) {
    my($self,$key_only,$key) = @_;
    return $self->{col_names}->[0] if $key_only;
    return undef unless exists $self->{hash}->{$key};
    my $val = $self->{hash}->{$key};
    $val = (ref($val)eq'ARRAY') ? $val : [$val];
    my $row = [$key, @$val];
    return @$row if wantarray;
    return $row;
}
sub delete_one_row ($$$) {
    my($self,$data,$aryref) = @_;
    delete $self->{hash}->{$aryref->[0]};
}
sub update_one_row ($$$) {
    my($self,$data,$aryref) = @_;
    my $key = shift @$aryref;
    return undef unless defined $key;
    my $row = (ref($aryref)eq'ARRAY') ? $aryref : [$aryref];
    if ( $self->{mldbm} ) {
        $self->{hash}->{$key}= $row;
    }
    else {
        $self->{hash}->{$key}=$row->[0];
    }
}

# you may not need to explicitly DESTROY the ::Table
# put cleanup code to run when the execute is done
#
sub DESTROY ($) {
    my $self=shift;
    untie %{$self->{hash}} if $self->{hash};
    # release the flock on the lock file
    $self->{lock_fh}->close if !$self->{nolock} and $self->{lock_fh};
}

# truncate() and seek() must be defined to satisfy DBI::SQL::Nano
# *IF* you define the *_one_row methods above, truncate() and
# seek() can be empty or you can use them without actually
# truncating or seeking anything but if you don't define the
# *_one_row methods, you may need to define these

# if you need to do something after a series of
# deletes or updates, you can put it in truncate()
# which is called at the end of executing
#
sub truncate ($$) {
    my($self,$data) = @_;
    1;
}

# seek() is only needed if you use IO::File
# though it could be used for other non-file operations
# that you need to do before "writes" or truncate()
#
sub seek ($$$$) {
    my($self, $data, $pos, $whence) = @_;
}

# Th, th, th, that's all folks!  See DBD::File and DBD::CSV for other
# examples of creating pure perl DBDs.  I hope this helped.
# Now it's time to go forth and create your own DBD!
# Remember to check in with [e-mail] before you get too far.
# We may be able to make suggestions or point you to other related
# projects.

1;
__END__

=pod

=head1 NAME

DBD::DBM - a DBI driver for DBM & MLDBM files

=head1 SYNOPSIS

 use DBI;
 $dbh = DBI->connect('dbi:DBM:');                # defaults to SDBM_File
 $dbh = DBI->connect('DBI:DBM(RaiseError=1):');  # defaults to SDBM_File
 $dbh = DBI->connect('dbi:DBM:type=GDBM_File');  # defaults to GDBM_File
 $dbh = DBI->connect('dbi:DBM:mldbm=Storable');  # MLDBM with SDBM_File
                                                 # and Storable

or

 $dbh = DBI->connect('dbi:DBM:', undef, undef);
 $dbh = DBI->connect('dbi:DBM:', undef, undef, { dbm_type => 'ODBM_File' });

and other variations on connect() as shown in the DBI docs and with
the dbm_ attributes shown below

... and then use standard DBI prepare, execute, fetch, placeholders, etc.,
see L<QUICK START> for an example

=head1 DESCRIPTION

DBD::DBM is a database management sytem that can work right out of the box.  If you have a standard installation of Perl and a standard installation of DBI, you can begin creating, accessing, and modifying database tables without any further installation.  You can also add some other modules to it for more robust capabilities if you wish.

The module uses a DBM file storage layer.  DBM file storage is common on many platforms and files can be created with it in many languges.  That means that, in addition to creating files with DBI/SQL, you can also use DBI/SQL to access and modify files created by other DBM modules and programs.  You can also use those programs to access files created with DBD::DBM.

DBM files are stored in binary format optimized for quick retrieval when using a key field.  That optimization can be used advantageously to make DBD::DBM SQL operations that use key fields very fast.  There are several different "flavors" of DBM - different storage formats supported by different sorts of perl modules such as SDBM_File and MLDBM.  This module supports all of the flavors that perl supports and, when used with MLDBM, supports tables with any number of columns and insertion of Perl objects into tables.

DBD::DBM has been tested with the following DBM types: SDBM_File, NDBM_File, ODBM_File, GDBM_File, DB_File, BerekeleyDB.  Each type was tested both with and without MLDBM.