Author: timbo
Date: Tue Mar 9 06:42:56 2004
New Revision: 206
Modified:
dbi/trunk/lib/DBD/DBM.pm
dbi/trunk/lib/DBD/File.pm
dbi/trunk/t/50dbm.t
Log:
Fix up (or workaround) some issues with DBD::File/DBD::DBM
Works under PurePerl now (though there is an undef warning from BerkeleyDB
when inserting a record with a null column - but the warning only appears
with DBI::PurePerl - not sure what's happening there. Jeff!)
Modified: dbi/trunk/lib/DBD/DBM.pm
==============================================================================
--- dbi/trunk/lib/DBD/DBM.pm (original)
+++ dbi/trunk/lib/DBD/DBM.pm Tue Mar 9 06:42:56 2004
@@ -111,6 +111,7 @@
#
$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;
}
}
@@ -174,7 +175,7 @@
sub FETCH ($$) {
my ($dbh, $attrib) = @_;
- return $dbh->SUPER::STORE($attrib) unless $attrib =~ /^dbm_/;
+ return $dbh->SUPER::FETCH($attrib) unless $attrib =~ /^dbm_/;
# throw an error if it has our prefix but isn't a valid attr name
#
@@ -295,6 +296,8 @@
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';
@@ -303,18 +306,11 @@
if defined $dbh->{dbm_tables}->{$file}->{ext};
$ext = '' unless defined $ext;
- die "Cannot CREATE '$file$ext', already exists!"
- if $createMode and (-e "$file$ext");
- die "Cannot open '$file$ext', file not found!"
- if !$createMode
- and !($self->{command} eq 'DROP')
- and !(-e "$file$ext");
-
my $open_mode = O_RDONLY;
$open_mode = O_RDWR if $lockMode;
$open_mode = O_RDWR|O_CREAT|O_TRUNC if $createMode;
- my(%h,$tie_type);
+ my($tie_type);
if ( $serializer ) {
require 'MLDBM.pm';
@@ -328,6 +324,19 @@
$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', already exists!"
+ if $createMode and (-e "$file$ext");
+
+ # let tie() fail instead of this explicit test
+ #die "Cannot open '$file$ext', file not found!"
+ # if !$createMode
+ # and !($self->{command} eq 'DROP')
+ # and !(-e "$file$ext");
+
# LOCKING
#
my($nolock,$lockext,$lock_table);
@@ -353,6 +362,7 @@
#
# 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; #
@@ -368,16 +378,17 @@
$flags{'-Flags'} = $DB_CREATE if $lockMode or $createMode;
my $t = 'BerkeleyDB::Hash';
$t = 'MLDBM' if $serializer;
- if ( $self->{command} ne 'DROP') {
- eval { tie %h, $t, -Filename=>$file, %flags }
- }
- # warn $BerkeleyDB::db_version;
+ @tie_args = ($t, -Filename=>$file, %flags);
+ }
+ else {
+ @tie_args = ($tie_type, $file, $open_mode, 0666);
}
- elsif (!%h) {
- eval { tie(%h, $tie_type, $file, $open_mode, 0666) }
- unless $self->{command} eq 'DROP';
+ 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 $@;
}
- die "Cannot tie file '$file': $@" if $@;
# COLUMN NAMES
Modified: dbi/trunk/lib/DBD/File.pm
==============================================================================
--- dbi/trunk/lib/DBD/File.pm (original)
+++ dbi/trunk/lib/DBD/File.pm Tue Mar 9 06:42:56 2004
@@ -45,6 +45,7 @@
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';
@@ -137,7 +138,7 @@
$attr->{'f_dir'} : $haveFileSpec ? File::Spec->curdir() : '.';
my($dirh) = Symbol::gensym();
if (!opendir($dirh, $dir)) {
- DBI::set_err($drh, 1, "Cannot open directory $dir");
+ $drh->set_err(1, "Cannot open directory $dir: $!");
return undef;
}
my($file, @dsns, %names, $driver);
@@ -173,11 +174,10 @@
sub prepare ($$;@) {
my($dbh, $statement, @attribs)= @_;
- # create a 'blank' dbh
+ # create a 'blank' sth
my $sth = DBI::_new_sth($dbh, {'Statement' => $statement});
if ($sth) {
- $@ = '';
my $class = $sth->FETCH('ImplementorClass');
$class =~ s/::st$/::Statement/;
my($stmt);
@@ -190,9 +190,8 @@
and $dbh->{sql_statement_version} > 1)
{
my $parser = $dbh->{csv_sql_parser_object};
- eval { $parser ||= $dbh->func('csv_cache_sql_parser_object') };
+ $parser ||= eval { $dbh->func('csv_cache_sql_parser_object') };
if ($@) {
- undef $@;
$stmt = eval { $class->new($statement) };
}
else {
@@ -203,7 +202,7 @@
$stmt = eval { $class->new($statement) };
}
if ($@) {
- DBI::set_err($dbh, 1, $@);
+ $dbh->set_err(1, $@);
undef $sth;
} else {
$sth->STORE('f_stmt', $stmt);
@@ -231,7 +230,7 @@
return $dbh->{$attrib};
}
# else pass up to DBI to handle
- return $dbh->DBD::_::db::FETCH($attrib);
+ return $dbh->SUPER::FETCH($attrib);
}
sub STORE ($$$) {
@@ -268,7 +267,7 @@
$dbh->{$attrib} = $value;
return 1;
}
- return $dbh->DBD::_::db::STORE($attrib, $value);
+ return $dbh->SUPER::STORE($attrib, $value);
}
sub DESTROY ($) {
@@ -327,7 +326,7 @@
my($dir) = $dbh->{f_dir};
my($dirh) = Symbol::gensym();
if (!opendir($dirh, $dir)) {
- DBI::set_err($dbh, 1, "Cannot open directory $dir");
+ $dbh->set_err(1, "Cannot open directory $dir: $!");
return undef;
}
my($file, @tables, %names);
@@ -338,7 +337,7 @@
}
}
if (!closedir($dirh)) {
- DBI::set_err($dbh, 1, "Cannot close directory $dir");
+ $dbh->set_err(1, "Cannot close directory $dir: $!");
return undef;
}
@@ -346,7 +345,7 @@
if (!$dbh2) {
$dbh2 = $dbh->{'csv_sponge_driver'} = DBI->connect("DBI:Sponge:");
if (!$dbh2) {
- DBI::set_err($dbh, 1, $DBI::errstr);
+ $dbh->set_err(1, $DBI::errstr);
return undef;
}
}
@@ -357,7 +356,7 @@
my $sth = $dbh2->prepare("TABLE_INFO", { 'rows' => [EMAIL PROTECTED],
'NAMES' => $names });
if (!$sth) {
- DBI::set_err($dbh, 1, $dbh2->errstr());
+ $dbh->set_err(1, $dbh2->errstr);
}
$sth;
}
@@ -443,8 +442,7 @@
my $sth = shift;
my $data = $sth->{f_stmt}->{data};
if (!$data || ref($data) ne 'ARRAY') {
- DBI::set_err($sth, 1,
- "Attempt to fetch row from a Non-SELECT statement");
+ $sth->set_err(1, "Attempt to fetch row from a Non-SELECT statement");
return undef;
}
my $dav = shift @$data;
@@ -479,7 +477,7 @@
return $sth->{$attrib};
}
# else pass up to DBI to handle
- return $sth->DBD::_::st::FETCH($attrib);
+ return $sth->SUPER::FETCH($attrib);
}
sub STORE ($$$) {
@@ -489,7 +487,7 @@
$sth->{$attrib} = $value;
return 1;
}
- return $sth->DBD::_::st::STORE($attrib, $value);
+ return $sth->SUPER::STORE($attrib, $value);
}
sub DESTROY ($) {
Modified: dbi/trunk/t/50dbm.t
==============================================================================
--- dbi/trunk/t/50dbm.t (original)
+++ dbi/trunk/t/50dbm.t Tue Mar 9 06:42:56 2004
@@ -48,6 +48,7 @@
);
for my $mldbm ( @mldbm_types ) {
for my $dbm_type ( @dbm_types ) {
+ print "\n--- Using $dbm_type ($mldbm) ---\n";
do_test( $dbm_type, $sql{$mldbm}, $mldbm );
}
}
@@ -63,10 +64,10 @@
my $dsn ="dbi:DBM(RaiseError=1,PrintError=0):dbm_type=$dtype;mldbm=$ml";
my $dbh = DBI->connect( $dsn );
if ($DBI::VERSION >= 1.37 ) { # needed for install_method
- diag( $dbh->dbm_versions );
+ print $dbh->dbm_versions;
}
else {
- diag( $dbh->func('dbm_versions') );
+ print $dbh->func('dbm_versions');
}
ok($dbh);
@@ -97,9 +98,10 @@
2 => '12',
3 => '13',
} if $ml;
+ print " $sql\n";
my $sth = $dbh->prepare($sql) or die $dbh->errstr;
$sth->execute;
- die $sth->errstr if $sth->errstr and $sql !~ /DROP/;
+ die $sth->errstr if $sth->err and $sql !~ /DROP/;
next unless $sql =~ /SELECT/;
my $results='';
# Note that we can't rely on the order here, it's not portable,
