Author: timbo
Date: Mon Sep 20 15:29:43 2010
New Revision: 14436
Modified:
dbi/trunk/Changes
dbi/trunk/lib/DBD/File.pm
dbi/trunk/lib/DBI/DBD.pm
dbi/trunk/t/49dbd_file.t
dbi/trunk/t/51dbm_file.t
dbi/trunk/t/lib.pl
Log:
Fixed portability to VMS (Craig A. Berry)
Modified: dbi/trunk/Changes
==============================================================================
--- dbi/trunk/Changes (original)
+++ dbi/trunk/Changes Mon Sep 20 15:29:43 2010
@@ -8,9 +8,11 @@
=head2 Changes in DBI 1.XXX (svn nnnnn) nth Month 2010
+ Fixed test for file/directory names with whitespaces in them
Fixed compiler warnings from ignored hv_store result (Martin J. Evans)
+ Fixed portability to VMS (Craig A. Berry)
-=head2 Changes in DBI 1.614 (svn r14385) 9th September 2010
+=head2 Changes in DBI 1.614 (svn r14408) 17th September 2010
Fixed bind_param () in DBI::DBD::SqlEngine (rt#61281)
Fixed internals to not refer to old perl symbols that
Modified: dbi/trunk/lib/DBD/File.pm
==============================================================================
--- dbi/trunk/lib/DBD/File.pm (original)
+++ dbi/trunk/lib/DBD/File.pm Mon Sep 20 15:29:43 2010
@@ -141,11 +141,6 @@
$driver = $drh->{ImplementorClass} =~ m/^dbd\:\:([^\:]+)\:\:/i ? $1 :
"File";
while (defined ($file = readdir ($dirh))) {
- if ($^O eq "VMS") {
- # if on VMS then avoid warnings from catdir if you use a file
- # (not a dir) as the file below
- $file !~ m/\.dir$/oi and next;
- }
my $d = File::Spec->catdir ($dir, $file);
# allow current dir ... it can be a data_source too
$file ne File::Spec->updir () && -d $d and
@@ -776,6 +771,7 @@
if ($respect_case) {
$cmpsub = sub {
my ($fn, undef, $sfx) = File::Basename::fileparse ($_,
$fn_any_ext_regex);
+ $sfx = '' if $^O eq 'VMS' and $sfx eq '.'; # no extension
turns up as a dot
$fn eq $basename and
return (lc $sfx eq lc $ext or !$req && !$sfx);
return 0;
@@ -784,6 +780,7 @@
else {
$cmpsub = sub {
my ($fn, undef, $sfx) = File::Basename::fileparse ($_,
$fn_any_ext_regex);
+ $sfx = '' if $^O eq 'VMS' and $sfx eq '.'; # no extension
turns up as a dot
lc $fn eq lc $basename and
return (lc $sfx eq lc $ext or !$req && !$sfx);
return 0;
Modified: dbi/trunk/lib/DBI/DBD.pm
==============================================================================
--- dbi/trunk/lib/DBI/DBD.pm (original)
+++ dbi/trunk/lib/DBI/DBD.pm Mon Sep 20 15:29:43 2010
@@ -3324,15 +3324,18 @@
my %test_variants = (
p => { name => "DBI::PurePerl",
match => qr/^\d/,
- add => [ '$ENV{DBI_PUREPERL} = 2' ],
+ add => [ '$ENV{DBI_PUREPERL} = 2',
+ 'END { delete $ENV{DBI_PUREPERL}; }' ],
},
g => { name => "DBD::Gofer",
match => qr/^\d/,
- add => [ q{$ENV{DBI_AUTOPROXY} =
'dbi:Gofer:transport=null;policy=pedantic'} ],
+ add => [ q{$ENV{DBI_AUTOPROXY} =
'dbi:Gofer:transport=null;policy=pedantic'},
+ q|END { delete $ENV{DBI_AUTOPROXY}; }| ],
},
n => { name => "DBI::SQL::Nano",
match => qr/^(?:49dbd_file|5\ddbm_\w+|85gofer)\.t$/,
- add => [ q{$ENV{DBI_SQL_NANO} = 1} ],
+ add => [ q{$ENV{DBI_SQL_NANO} = 1},
+ q|END { delete $ENV{DBI_SQL_NANO}; }| ],
},
# mx => { name => "DBD::Multiplex",
# add => [ q{local $ENV{DBI_AUTOPROXY} = 'dbi:Multiplex:';} ],
Modified: dbi/trunk/t/49dbd_file.t
==============================================================================
--- dbi/trunk/t/49dbd_file.t (original)
+++ dbi/trunk/t/49dbd_file.t Mon Sep 20 15:29:43 2010
@@ -99,7 +99,7 @@
my @tfhl;
# Now test some basic SQL statements
-my $tbl_file = File::Spec->catfile ($dir, "$tbl.txt");
+my $tbl_file = File::Spec->catfile (Cwd::abs_path( $dir ), "$tbl.txt");
ok ($dbh->do ("create table $tbl (txt varchar (20))"), "Create table $tbl") or
diag $dbh->errstr;
ok (-f $tbl_file, "Test table exists");
Modified: dbi/trunk/t/51dbm_file.t
==============================================================================
--- dbi/trunk/t/51dbm_file.t (original)
+++ dbi/trunk/t/51dbm_file.t Mon Sep 20 15:29:43 2010
@@ -25,8 +25,10 @@
ok( $dbh->do(q/drop table if exists FRED/), 'drop table' );
+my $dirfext = $^O eq 'VMS' ? '.sdbm_dir' : '.dir';
+
$dbh->do(q/create table fred (a integer, b integer)/);
-ok( -f File::Spec->catfile( $dir, "FRED.dir" ), "FRED.dir exists" );
+ok( -f File::Spec->catfile( $dir, "FRED$dirfext" ), "FRED$dirfext exists" );
rmtree $dir;
mkpath $dir;
@@ -48,7 +50,7 @@
}
$dbh->do(q/create table FRED (a integer, b integer)/);
-ok( -f File::Spec->catfile( $dir, "fred.dir" ), "fred.dir exists" );
+ok( -f File::Spec->catfile( $dir, "fred$dirfext" ), "fred$dirfext exists" );
ok( $dbh->do(q/insert into fRED (a,b) values(1,2)/), 'insert into mixed case
table' );
Modified: dbi/trunk/t/lib.pl
==============================================================================
--- dbi/trunk/t/lib.pl (original)
+++ dbi/trunk/t/lib.pl Mon Sep 20 15:29:43 2010
@@ -22,6 +22,9 @@
$test_dir = VMS::Filespec::unixify($test_dir) if $^O eq 'VMS';
rmtree $test_dir;
mkpath $test_dir;
+ # There must be at least one directory in the test directory,
+ # and nothing guarantees that dot or dot-dot directories will exist.
+ mkpath ( File::Spec->catdir( $test_dir, '000_just_testing' ) );
}
return $test_dir;
