Author: timbo
Date: Wed Mar 10 16:28:59 2004
New Revision: 211
Modified:
dbi/trunk/lib/DBD/DBM.pm
dbi/trunk/lib/DBD/File.pm
dbi/trunk/t/50dbm.t
Log:
DBD::File:
simplify driver(), add CLONE(), remove finish()
DBD::DBM:
fix dbm_lockfile attribute so locking can be disabled.
remove abbreviated forms of dbm_mldbm attribute.
t/50dbm.t:
disable locking (to avoid NFS issues)
add Storable to MLDBM tests
Modified: dbi/trunk/lib/DBD/DBM.pm
==============================================================================
--- dbi/trunk/lib/DBD/DBM.pm (original)
+++ dbi/trunk/lib/DBD/DBM.pm Wed Mar 10 16:28:59 2004
@@ -21,20 +21,21 @@
#################
package DBD::DBM;
#################
-use DBD::File ();
-use vars qw($VERSION $ATTRIBUTION $methods_already_installed);
use base qw( DBD::File );
-$VERSION = '0.01'; # CHANGE THIS !
-$ATTRIBUTION = 'DBD::DBM by Jeff Zucker'; # CHANGE THIS !
+use vars qw($VERSION $ATTRIBUTION $drh $methods_already_installed);
+$VERSION = '0.01';
+$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
#
- my $this = $class->DBD::File::driver($attr);
+ $attr->{Attribution} = 'DBD::DBM by Jeff Zucker';
+ my $this = $class->SUPER::driver($attr);
# install private methods
#
@@ -49,6 +50,9 @@
$this;
}
+sub CLONE {
+ undef $drh;
+}
#####################
package DBD::DBM::dr;
@@ -64,9 +68,7 @@
# create a 'blank' dbh
my $this = DBI::_new_dbh($drh, {
- 'Name' => $dbname,
- 'USER' => $user,
- 'CURRENT_USER' => $user,
+ Name => $dbname,
});
# parse the connection string for name=value pairs
@@ -88,6 +90,7 @@
, 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
};
@@ -206,9 +209,6 @@
my $mldbm = $dbh->{dbm_tables}->{$table}->{mldbm}
|| $dbh->{dbm_mldbm}
|| '';
- $mldbm = 'Storable' if $mldbm =~ /^S$/i;
- $mldbm = 'FreezeThaw' if $mldbm =~ /^F$/i;
- $mldbm = 'Data::Dumper' if $mldbm =~ /^D$/i;
$dtype .= ' + MLDBM + ' . $mldbm if $mldbm;
my %version = ( DBI => $DBI::VERSION );
@@ -288,9 +288,6 @@
my $serializer = $dbh->{dbm_tables}->{$file}->{mldbm}
|| $dbh->{dbm_mldbm}
|| '';
- $serializer = 'Storable' if $serializer =~ /^S$/i;
- $serializer = 'FreezeThaw' if $serializer =~ /^F$/i;
- $serializer = 'Data::Dumper' if $serializer =~ /^D$/i;
$dbh->{dbm_tables}->{$file}->{mldbm} = $serializer if $serializer;
my $ext = '' if $dbm_type eq 'GDBM_File'
@@ -666,7 +663,6 @@
$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
- $dbh = DBI->connect('dbi:DBM:mldbm=S'); # same as above
or
@@ -820,23 +816,22 @@
MLDBM can use three different modules to serialize the column - Data::Dumper,
Storable, and FreezeThaw. Data::Dumper is the default, Storable is the fastest.
MLDBM can also make use of user-defined serialization methods. All of this is
available to you through DBD::DBM with just one attribute setting.
-To use MLDBM with DBD::DBM, you need to set the dbm_mldbm attribute to the name of
the serialization module. For convenience, you can abbreviate the three standard
modules with D = Data::Dumper, S = Storable, and F = FreezeThaw.
+To use MLDBM with DBD::DBM, you need to set the dbm_mldbm attribute to the name of
the serialization module.
Some examples:
- $dbh=DBI->connect('dbi:DBM:mldbm=Storage'); # use MLDBM with Storable
- $dbh=DBI->connect('dbi:DBM:mldbm=S'); # same as above
+ $dbh=DBI->connect('dbi:DBM:mldbm=Storable'); # use MLDBM with Storable
$dbh=DBI->connect(
- 'dbi:DBM:mldbm=MySerializer' # use MLDBM with a user defined module
+ 'dbi:DBM:mldbm=MySerializer' # use MLDBM with a user defined module
);
- $dbh->{mldbm} = 'MySerializer'; # same as above
+ $dbh->{mldbm} = 'MySerializer'; # same as above
print $dbh->{mldbm} # show the MLDBM serializer
- $dbh->{dbm_tables}->{foo}->{mldbm}='D'; # set Data::Dumper for table "foo"
+ $dbh->{dbm_tables}->{foo}->{mldbm}='Data::Dumper'; # set Data::Dumper for table
"foo"
print $dbh->{dbm_tables}->{foo}->{mldbm}; # show serializer for table "foo"
MLDBM works on top of other DBM modules so you can also set a DBM type along with
setting dbm_mldbm. The examples above would default to using SDBM_File with MLDBM.
If you wanted GDBM_File instead, here's how:
- $dbh = DBI->connect('dbi:DBM:type=GDBM_File;mldbm=S');
+ $dbh = DBI->connect('dbi:DBM:type=GDBM_File;mldbm=Storable');
#
# uses GDBM_File with MLDBM and Storable
@@ -852,7 +847,7 @@
With BerkeleyDB, you can specify initialization flags by setting them in your script
like this:
- my $dbh = DBI->connect('dbi:DBM:type=BerkeleyDB;mldbm=S');
+ my $dbh = DBI->connect('dbi:DBM:type=BerkeleyDB;mldbm=Storable');
use BerkeleyDB;
my $env = new BerkeleyDB::Env -Home => $dir; # and/or other Env flags
$dbh->{dbm_berkeley_flags} = {
Modified: dbi/trunk/lib/DBD/File.pm
==============================================================================
--- dbi/trunk/lib/DBD/File.pm (original)
+++ dbi/trunk/lib/DBD/File.pm Wed Mar 10 16:28:59 2004
@@ -18,62 +18,42 @@
# General Public License or the Artistic License, as specified in
# the Perl README file.
#
-BEGIN { use lib '../' }
require 5.004;
use strict;
-
-require DynaLoader;
+use DBI ();
require DBI::SQL::Nano;
-require DBI;
my $haveFileSpec = eval { require File::Spec };
package DBD::File;
-use vars qw(@ISA $VERSION $drh $err $errstr $sqlstate $valid_attrs);
-
[EMAIL PROTECTED] = qw(DynaLoader);
+use vars qw(@ISA $VERSION $drh $valid_attrs);
$VERSION = '0.30'; # bumped from 0.22 to 0.30 with inclusion in DBI
-$err = 0; # holds error code for DBI::err
-$errstr = ""; # holds error string for DBI::errstr
-$sqlstate = ""; # holds error state for DBI::state
$drh = undef; # holds driver handle once initialised
sub driver ($;$) {
my($class, $attr) = @_;
- my $drh = eval '$' . $class . "::drh";
- if (!$drh) {
- DBI->setup_driver('DBD::File');
- if (!$attr) { $attr = {} };
- if (!exists($attr->{Attribution})) {
- $attr->{Attribution} = eval '$' . $class . '::ATTRIBUTION';
- $attr->{Attribution} = "$class by Jeff Zucker"
- if $class eq 'DBD::File';
- $attr->{Attribution} ||=
- "oops the author of $class forgot to define this";
- }
- if (!exists($attr->{Version})) {
- $attr->{Version} = eval '$' . $class . '::VERSION';
- }
- if (!exists($attr->{Err})) {
- $attr->{Err} = eval '\$' . $class . '::err';
- }
- if (!exists($attr->{Errstr})) {
- $attr->{Errstr} = eval '\$' . $class . '::errstr';
- }
- if (!exists($attr->{State})) {
- $attr->{State} = eval '\$' . $class . '::state';
- }
- if (!exists($attr->{Name})) {
- my $c = $class;
- $c =~ s/^DBD\:\://;
- $attr->{Name} = $c;
- }
- $drh = DBI::_new_drh($class . "::dr", $attr);
- }
- $drh;
+ return $drh if $drh;
+
+ DBI->setup_driver('DBD::File');
+ $attr ||= {};
+ no strict qw(refs);
+ if (!$attr->{Attribution}) {
+ $attr->{Attribution} = "$class by Jeff Zucker"
+ if $class eq 'DBD::File';
+ $attr->{Attribution} ||= ${$class . '::ATTRIBUTION'}
+ || "oops the author of $class forgot to define this";
+ }
+ $attr->{Version} ||= ${$class . '::VERSION'};
+ ($attr->{Name} = $class) =~ s/^DBD\:\:// unless $attr->{Name};
+ $drh = DBI::_new_drh($class . "::dr", $attr);
+ return $drh;
+}
+
+sub CLONE {
+ undef $drh;
}
package DBD::File::dr; # ====== DRIVER ======
@@ -496,11 +476,11 @@
sub rows ($) { shift->{'f_stmt'}->{'NUM_OF_ROWS'} };
-sub finish ($) { 1; }
-
package DBD::File::Statement;
+# We may have a working flock() built-in but that doesn't mean that locking
+# will work on NFS (flock() may hang hard)
my $locking = eval { flock STDOUT, 0; 1 };
# Jochen's old check for flock()
Modified: dbi/trunk/t/50dbm.t
==============================================================================
--- dbi/trunk/t/50dbm.t (original)
+++ dbi/trunk/t/50dbm.t Wed Mar 10 16:28:59 2004
@@ -1,32 +1,28 @@
#!perl
use strict;
-use DBI;
use File::Path;
use Test::More;
+
+use DBI;
use vars qw( @mldbm_types @dbm_types );
BEGIN {
- use lib qw(./ ../../lib);
-
# 0=SQL::Statement if avail, 1=DBI::SQL::Nano
# next line forces use of Nano rather than default behaviour
$ENV{DBI_SQL_NANO}=1;
- # test without MLDBM
- # also test with MLDBM if both it and Data::Dumper are available
- #
- @mldbm_types = ('plain');
- eval { require 'MLDBM.pm'; require 'Data/Dumper.pm' };
- push @mldbm_types, 'mldbm' unless $@;
+ if (eval { require 'MLDBM.pm'; }) {
+ push @mldbm_types, 'Data::Dumper' if eval { require 'Data/Dumper.pm' };
+ push @mldbm_types, 'Storable' if eval { require 'Storable.pm' };
+ }
# test with as many of the 5 major DBM types as are available
#
for (qw( SDBM_File GDBM_File NDBM_File ODBM_File DB_File BerkeleyDB )){
- undef $@;
eval { require "$_.pm" };
push @dbm_types, $_ unless $@;
}
- my $num_tests = @mldbm_types * @dbm_types * 11;
+ my $num_tests = ([EMAIL PROTECTED]) * @dbm_types * 11;
if (!$num_tests) {
plan tests => 1;
SKIP: {
@@ -34,22 +30,22 @@
}
exit;
}
- else {
- plan tests => $num_tests;
- }
+ plan tests => $num_tests;
}
+
my $dir = './test_output';
+
rmtree $dir;
mkpath $dir;
+
my( $two_col_sql,$three_col_sql ) = split /\n\n/,join '',<DATA>;
-my %sql = (
- mldbm => [ split /\s*;\n/, $three_col_sql ]
- , plain => [ split /\s*;\n/, $two_col_sql ]
-);
-for my $mldbm ( @mldbm_types ) {
+
+for my $mldbm ( '', @mldbm_types ) {
+ my $sql = ($mldbm) ? $three_col_sql : $two_col_sql;
+ my @sql = split /\s*;\n/, $sql;
for my $dbm_type ( @dbm_types ) {
print "\n--- Using $dbm_type ($mldbm) ---\n";
- do_test( $dbm_type, $sql{$mldbm}, $mldbm );
+ do_test( $dbm_type, [EMAIL PROTECTED], $mldbm );
}
}
rmtree $dir;
@@ -59,10 +55,14 @@
my $stmts = shift;
my $mldbm = shift;
$|=1;
- my $ml = '' if $mldbm eq 'plain';
- $ml = 'D' if $mldbm eq 'mldbm';
- my $dsn ="dbi:DBM(RaiseError=1,PrintError=0):dbm_type=$dtype;mldbm=$ml";
+
+ # The DBI can't test locking here, sadly, because of the risk it'll hang
+ # on systems with broken NFS locking daemons.
+ # (This test script doesn't test that locking actually works anyway.)
+
+ my $dsn
="dbi:DBM(RaiseError=1,PrintError=0):dbm_type=$dtype;mldbm=$mldbm;lockfile=0";
my $dbh = DBI->connect( $dsn );
+
if ($DBI::VERSION >= 1.37 ) { # needed for install_method
print $dbh->dbm_versions;
}
@@ -75,7 +75,7 @@
#
eval {$dbh->{f_dir}=$dir};
ok(!$@);
- eval {$dbh->{dbm_mldbm}=$ml};
+ eval {$dbh->{dbm_mldbm}=$mldbm};
ok(!$@);
# test if it correctly rejects invalid $dbh attributes
@@ -97,7 +97,7 @@
1 => '11',
2 => '12',
3 => '13',
- } if $ml;
+ } if $mldbm;
print " $sql\n";
my $sth = $dbh->prepare($sql) or die $dbh->errstr;
$sth->execute;
