Bug #29492 for DBI: PATCH to get tests to pass on VMS

On Wed Sep 19 08:44:12 2007, cpan@pjedwards.co.uk wrote: Show quoted text
After a bit of discussion on perlvms, I've amended the patch to avoid File::Spec->catdir() being called with anything that is not a directory on VMS. Thanks Peter (Stig) Edwards

Index: trunk/lib/DBD/ExampleP.pm =================================================================== --- trunk/lib/DBD/ExampleP.pm (revision 9950) +++ trunk/lib/DBD/ExampleP.pm (working copy) @@ -152,6 +152,13 @@ opendir($dh, $dir) or return $dbh->set_err(int($!), "Failed to open directory $dir: $!"); while (defined(my $item = readdir($dh))) { + if($^O eq 'VMS'){ + # if on VMS then avoid warnings from catdir if you use a file + # (not a dir) as the item below + if($item!~/\.dir$/oi){ + next; + } + } my $file = ($haveFileSpec) ? File::Spec->catdir($dir,$item) : $item; next unless -d $file; my($dev, $ino, $mode, $nlink, $uid) = lstat($file); Index: trunk/lib/DBD/File.pm =================================================================== --- trunk/lib/DBD/File.pm (revision 9950) +++ trunk/lib/DBD/File.pm (working copy) @@ -139,6 +139,13 @@ $driver = '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 + if($file!~/\.dir$/oi){ + next; + } + } my $d = $haveFileSpec ? File::Spec->catdir($dir, $file) : "$dir/$file"; # allow current dir ... it can be a data_source too Index: trunk/lib/DBI/ProfileData.pm =================================================================== --- trunk/lib/DBI/ProfileData.pm (revision 9950) +++ trunk/lib/DBI/ProfileData.pm (working copy) @@ -196,9 +196,15 @@ if ($self->{DeleteFiles}) { my $newfilename = $filename . ".deleteme"; + if($^O eq 'VMS'){ + # VMS default filesystem can only have one period + $newfilename = $filename . 'deleteme'; + } # will clobber an existing $newfilename rename($filename, $newfilename) or croak "Can't rename($filename, $newfilename): $!"; + # On a versioned filesystem we want old versions to be removed + 1 while (unlink $filename); $filename = $newfilename; } @@ -219,7 +225,13 @@ push @files_to_delete, $filename if $self->{DeleteFiles}; } - unlink $_ or warn "Can't delete '$_': $!" for @files_to_delete; + for (@files_to_delete){ + # for versioned file systems + 1 while (unlink $_); + if(-e $_){ + warn "Can't delete '$_': $!"; + } + } # discard node_lookup now that all files are read delete $self->{_node_lookup}; Index: trunk/t/85gofer.t =================================================================== --- trunk/t/85gofer.t (revision 9950) +++ trunk/t/85gofer.t (working copy) @@ -80,7 +80,7 @@ or next; # XXX temporary restrictions, hopefully - if ($^O eq 'MSWin32') { + if ( ($^O eq 'MSWin32') || ($^O eq 'VMS') ) { # stream needs Fcntl macro F_GETFL for non-blocking # and pipe seems to hang on some windows systems next if $transport eq 'stream' or $transport eq 'pipeone'; Index: trunk/t/19fhtrace.t =================================================================== --- trunk/t/19fhtrace.t (revision 9950) +++ trunk/t/19fhtrace.t (working copy) @@ -188,7 +188,10 @@ # read new file size and verify its different # my $newfsz = (stat $tracefd)[7]; -ok(($filesz != $newfsz), '... regular fh: trace_msg'); +SKIP: { + skip 'on VMS autoflush using select does not work', 1 unless ($^O ne 'VMS'); + ok(($filesz != $newfsz), '... regular fh: trace_msg'); +} $dbh->trace(undef, "STDOUT"); # close $trace_file ok(-f $trace_file, '... regular fh: file successfully changed'); Index: trunk/t/50dbm.t =================================================================== --- trunk/t/50dbm.t (revision 9950) +++ trunk/t/50dbm.t (working copy) @@ -3,6 +3,7 @@ use strict; use File::Path; +use File::Spec; use Test::More; use Cwd; use Config qw(%Config); @@ -64,7 +65,7 @@ } } -my $dir = getcwd().'/test_output'; +my $dir = File::Spec->catdir(getcwd(),'test_output'); rmtree $dir; mkpath $dir;