[svn:dbi] r14436 - in dbi/trunk: . lib/DBD lib/DBI t

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;