diff -urN perl-5.10.0/lib/File/Spec.old/Cygwin.pm perl-5.10.0/lib/File/Spec/Cygwin.pm --- perl-5.10.0/lib/File/Spec.old/Cygwin.pm 2007-12-18 11:47:07.000000000 +0100 +++ perl-5.10.0/lib/File/Spec/Cygwin.pm 2009-05-10 10:58:10.000000000 +0200 @@ -4,7 +4,8 @@ use vars qw(@ISA $VERSION); require File::Spec::Unix; -$VERSION = '3.2501'; +$VERSION = '3.30'; +$VERSION = eval $VERSION; @ISA = qw(File::Spec::Unix); @@ -39,6 +40,8 @@ sub canonpath { my($self,$path) = @_; + return unless defined $path; + $path =~ s|\\|/|g; # Handle network path names beginning with double slash @@ -51,6 +54,7 @@ sub catdir { my $self = shift; + return unless @_; # Don't create something that looks like a //network/path if ($_[0] and ($_[0] eq '/' or $_[0] eq '\\')) { @@ -108,10 +112,10 @@ =cut -sub case_tolerant () { - if ($^O ne 'cygwin') { - return 1; - } +sub case_tolerant { + return 1 unless $^O eq 'cygwin' + and defined &Cygwin::mount_flags; + my $drive = shift; if (! $drive) { my @flags = split(/,/, Cygwin::mount_flags('/cygwin')); diff -urN perl-5.10.0/lib/File/Spec.old/Epoc.pm perl-5.10.0/lib/File/Spec/Epoc.pm --- perl-5.10.0/lib/File/Spec.old/Epoc.pm 2007-12-18 11:47:07.000000000 +0100 +++ perl-5.10.0/lib/File/Spec/Epoc.pm 2009-05-10 10:58:10.000000000 +0200 @@ -3,7 +3,8 @@ use strict; use vars qw($VERSION @ISA); -$VERSION = '3.2501'; +$VERSION = '3.30'; +$VERSION = eval $VERSION; require File::Spec::Unix; @ISA = qw(File::Spec::Unix); @@ -45,6 +46,7 @@ sub canonpath { my ($self,$path) = @_; + return unless defined $path; $path =~ s|/+|/|g; # xx////xx -> xx/xx $path =~ s|(/\.)+/|/|g; # xx/././xx -> xx/xx diff -urN perl-5.10.0/lib/File/Spec.old/Functions.pm perl-5.10.0/lib/File/Spec/Functions.pm --- perl-5.10.0/lib/File/Spec.old/Functions.pm 2007-12-18 11:47:07.000000000 +0100 +++ perl-5.10.0/lib/File/Spec/Functions.pm 2009-05-10 10:58:10.000000000 +0200 @@ -5,7 +5,8 @@ use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION); -$VERSION = '3.2501'; +$VERSION = '3.30'; +$VERSION = eval $VERSION; require Exporter; diff -urN perl-5.10.0/lib/File/Spec.old/Mac.pm perl-5.10.0/lib/File/Spec/Mac.pm --- perl-5.10.0/lib/File/Spec.old/Mac.pm 2007-12-18 11:47:07.000000000 +0100 +++ perl-5.10.0/lib/File/Spec/Mac.pm 2009-05-10 10:58:10.000000000 +0200 @@ -4,7 +4,8 @@ use vars qw(@ISA $VERSION); require File::Spec::Unix; -$VERSION = '3.2501'; +$VERSION = '3.30'; +$VERSION = eval $VERSION; @ISA = qw(File::Spec::Unix); @@ -530,7 +531,7 @@ my @result = (); my ($head, $sep, $tail, $volume, $directories); - return ('') if ( (!defined($path)) || ($path eq '') ); + return @result if ( (!defined($path)) || ($path eq '') ); return (':') if ($path eq ':'); ( $volume, $sep, $directories ) = $path =~ m|^((?:[^:]+:)?)(:*)(.*)|s; diff -urN perl-5.10.0/lib/File/Spec.old/OS2.pm perl-5.10.0/lib/File/Spec/OS2.pm --- perl-5.10.0/lib/File/Spec.old/OS2.pm 2007-12-18 11:47:07.000000000 +0100 +++ perl-5.10.0/lib/File/Spec/OS2.pm 2009-05-10 10:58:10.000000000 +0200 @@ -4,7 +4,8 @@ use vars qw(@ISA $VERSION); require File::Spec::Unix; -$VERSION = '3.2501'; +$VERSION = '3.30'; +$VERSION = eval $VERSION; @ISA = qw(File::Spec::Unix); @@ -54,6 +55,8 @@ sub canonpath { my ($self,$path) = @_; + return unless defined $path; + $path =~ s/^([a-z]:)/\l$1/s; $path =~ s|\\|/|g; $path =~ s|([^/])/+|$1/|g; # xx////xx -> xx/xx diff -up perl-5.10.0/lib/File/Spec/t/crossplatform.t.aa perl-5.10.0/lib/File/Spec/t/crossplatform.t --- perl-5.10.0/lib/File/Spec/t/crossplatform.t.aa 2007-12-18 11:47:07.000000000 +0100 +++ perl-5.10.0/lib/File/Spec/t/crossplatform.t 2009-05-10 10:58:10.000000000 +0200 @@ -7,7 +7,36 @@ use Test::More; local $|=1; my @platforms = qw(Cygwin Epoc Mac OS2 Unix VMS Win32); -my $tests_per_platform = 7; +my $tests_per_platform = 10; + +my $vms_unix_rpt = 0; +my $vms_efs = 0; +my $vms_unix_mode = 0; +my $vms_real_root = 0; + +if ($^O eq 'VMS') { + $vms_unix_mode = 0; + if (eval 'require VMS::Feature') { + $vms_unix_rpt = VMS::Feature::current("filename_unix_report"); + $vms_efs = VMS::Feature::current("efs_charset"); + } else { + my $unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || ''; + my $efs_charset = $ENV{'DECC$EFS_CHARSET'} || ''; + $vms_unix_rpt = $unix_rpt =~ /^[ET1]/i; + $vms_efs = $efs_charset =~ /^[ET1]/i; + } + + # Traditional VMS mode only if VMS is not in UNIX compatible mode. + $vms_unix_mode = ($vms_efs && $vms_unix_rpt); + + # If we are in UNIX mode, we may or may not have a real root. + if ($vms_unix_mode) { + my $rootdir = File::Spec->rootdir; + $vms_real_root = 1 if ($rootdir eq '/'); + } + +} + plan tests => 1 + @platforms * $tests_per_platform; @@ -56,37 +85,82 @@ foreach my $platform (@platforms) { is $module->file_name_is_absolute($base), 1, "$base is absolute on $platform"; + # splitdir('') -> () + my @result = $module->splitdir(''); + is @result, 0, "$platform->splitdir('') -> ()"; + + # canonpath() -> undef + $result = $module->canonpath(); + is $result, undef, "$platform->canonpath() -> undef"; + + # canonpath(undef) -> undef + $result = $module->canonpath(undef); + is $result, undef, "$platform->canonpath(undef) -> undef"; # abs2rel('A:/foo/bar', 'A:/foo') -> 'bar' $file = $module->catpath($v, $module->catdir($module->rootdir, 'foo', 'bar'), 'file'); $base = $module->catpath($v, $module->catdir($module->rootdir, 'foo'), ''); $result = $module->catfile('bar', 'file'); + + if ($vms_unix_mode and $platform eq 'VMS') { + # test 56 special + # If VMS is in UNIX mode, so is the result, but having the volume + # parameter present forces the abs2rel into VMS mode. + $result = VMS::Filespec::vmsify($result); + $result =~ s/\.$//; + + # If we have a real root, then we are dealing with absolute directories + $result =~ s/\[\./\[/ if $vms_real_root; + } + is $module->abs2rel($file, $base), $result, "$platform->abs2rel($file, $base)"; + # abs2rel('A:/foo/bar', 'B:/foo') -> 'A:/foo/bar' $base = $module->catpath($other_v, $module->catdir($module->rootdir, 'foo'), ''); $result = volumes_differ($module, $file, $base) ? $file : $module->catfile('bar', 'file'); is $module->abs2rel($file, $base), $result, "$platform->abs2rel($file, $base)"; + # abs2rel('A:/foo/bar', '/foo') -> 'A:/foo/bar' $base = $module->catpath('', $module->catdir($module->rootdir, 'foo'), ''); $result = volumes_differ($module, $file, $base) ? $file : $module->catfile('bar', 'file'); is $module->abs2rel($file, $base), $result, "$platform->abs2rel($file, $base)"; + # abs2rel('/foo/bar/file', 'A:/foo') -> '/foo/bar' $file = $module->catpath('', $module->catdir($module->rootdir, 'foo', 'bar'), 'file'); $base = $module->catpath($v, $module->catdir($module->rootdir, 'foo'), ''); $result = volumes_differ($module, $file, $base) ? $module->rel2abs($file) : $module->catfile('bar', 'file'); + + if ($vms_unix_mode and $platform eq 'VMS') { + # test 59 special + # If VMS is in UNIX mode, so is the result, but having the volume + # parameter present forces the abs2rel into VMS mode. + $result = VMS::Filespec::vmsify($result); + } + is $module->abs2rel($file, $base), $result, "$platform->abs2rel($file, $base)"; + # abs2rel('/foo/bar', 'B:/foo') -> '/foo/bar' $base = $module->catpath($other_v, $module->catdir($module->rootdir, 'foo'), ''); $result = volumes_differ($module, $file, $base) ? $module->rel2abs($file) : $module->catfile('bar', 'file'); + + if ($vms_unix_mode and $platform eq 'VMS') { + # test 60 special + # If VMS is in UNIX mode, so is the result, but having the volume + # parameter present forces the abs2rel into VMS mode. + $result = VMS::Filespec::vmsify($result); + } + is $module->abs2rel($file, $base), $result, "$platform->abs2rel($file, $base)"; + # abs2rel('/foo/bar', '/foo') -> 'bar' $base = $module->catpath('', $module->catdir($module->rootdir, 'foo'), ''); $result = $module->catfile('bar', 'file'); + is $module->abs2rel($file, $base), $result, "$platform->abs2rel($file, $base)"; } } diff -up perl-5.10.0/lib/File/Spec/t/Functions.t.aa perl-5.10.0/lib/File/Spec/t/Functions.t diff -up perl-5.10.0/lib/File/Spec/t/rel2abs2rel.t.aa perl-5.10.0/lib/File/Spec/t/rel2abs2rel.t diff -up perl-5.10.0/lib/File/Spec/t/Spec.t.aa perl-5.10.0/lib/File/Spec/t/Spec.t --- perl-5.10.0/lib/File/Spec/t/Spec.t.aa 2007-12-18 11:47:07.000000000 +0100 +++ perl-5.10.0/lib/File/Spec/t/Spec.t 2009-05-10 10:58:10.000000000 +0200 @@ -13,6 +13,22 @@ eval { require VMS::Filespec ; } ; +my $vms_unix_rpt; +my $vms_efs; + +if ($^O eq 'VMS') { + if (eval 'require VMS::Feature') { + $vms_unix_rpt = VMS::Feature::current("filename_unix_report"); + $vms_efs = VMS::Feature::current("efs_charset"); + } else { + my $unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || ''; + my $efs_charset = $ENV{'DECC$EFS_CHARSET'} || ''; + $vms_unix_rpt = $unix_rpt =~ /^[ET1]/i; + $vms_efs = $efs_charset =~ /^[ET1]/i; + } +} + + my $skip_exception = "Install VMS::Filespec (from vms/ext)" ; if ( $@ ) { @@ -85,6 +101,7 @@ if ($^O eq 'MacOS') { [ "Unix->splitdir('d1/d2/d3')", 'd1,d2,d3' ], [ "Unix->catdir()", '' ], +[ "Unix->catdir('')", '/' ], [ "Unix->catdir('/')", '/' ], [ "Unix->catdir('','d1','d2','d3','')", '/d1/d2/d3' ], [ "Unix->catdir('d1','d2','d3','')", 'd1/d2/d3' ], @@ -191,10 +208,10 @@ if ($^O eq 'MacOS') { [ "Win32->catdir('\\d1','d2')", '\\d1\\d2' ], [ "Win32->catdir('\\d1','\\d2')", '\\d1\\d2' ], [ "Win32->catdir('\\d1','\\d2\\')", '\\d1\\d2' ], -[ "Win32->catdir('','/d1','d2')", '\\\\d1\\d2' ], -[ "Win32->catdir('','','/d1','d2')", '\\\\\\d1\\d2' ], -[ "Win32->catdir('','//d1','d2')", '\\\\\\d1\\d2' ], -[ "Win32->catdir('','','//d1','d2')", '\\\\\\\\d1\\d2' ], +[ "Win32->catdir('','/d1','d2')", '\\d1\\d2' ], +[ "Win32->catdir('','','/d1','d2')", '\\d1\\d2' ], +[ "Win32->catdir('','//d1','d2')", '\\d1\\d2' ], +[ "Win32->catdir('','','//d1','d2')", '\\d1\\d2' ], [ "Win32->catdir('','d1','','d2','')", '\\d1\\d2' ], [ "Win32->catdir('','d1','d2','d3','')", '\\d1\\d2\\d3' ], [ "Win32->catdir('d1','d2','d3','')", 'd1\\d2\\d3' ], @@ -206,13 +223,16 @@ if ($^O eq 'MacOS') { [ "Win32->catdir('A:/d1','B:/d2','d3','')", 'A:\\d1\\B:\\d2\\d3' ], [ "Win32->catdir('A:/')", 'A:\\' ], [ "Win32->catdir('\\', 'foo')", '\\foo' ], - +[ "Win32->catdir('','','..')", '\\' ], +[ "Win32->catdir('A:', 'foo')", 'A:\\foo' ], [ "Win32->catfile('a','b','c')", 'a\\b\\c' ], [ "Win32->catfile('a','b','.\\c')", 'a\\b\\c' ], [ "Win32->catfile('.\\a','b','c')", 'a\\b\\c' ], [ "Win32->catfile('c')", 'c' ], [ "Win32->catfile('.\\c')", 'c' ], +[ "Win32->catfile('a/..','../b')", '..\\b' ], +[ "Win32->catfile('A:', 'foo')", 'A:\\foo' ], [ "Win32->canonpath('')", '' ], @@ -224,9 +244,9 @@ if ($^O eq 'MacOS') { [ "Win32->canonpath('//a\\b//c')", '\\\\a\\b\\c' ], [ "Win32->canonpath('/a/..../c')", '\\a\\....\\c' ], [ "Win32->canonpath('//a/b\\c')", '\\\\a\\b\\c' ], -[ "Win32->canonpath('////')", '\\\\\\' ], +[ "Win32->canonpath('////')", '\\' ], [ "Win32->canonpath('//')", '\\' ], -[ "Win32->canonpath('/.')", '\\.' ], +[ "Win32->canonpath('/.')", '\\' ], [ "Win32->canonpath('//a/b/../../c')", '\\\\a\\b\\c' ], [ "Win32->canonpath('//a/b/c/../d')", '\\\\a\\b\\d' ], [ "Win32->canonpath('//a/b/c/../../d')",'\\\\a\\b\\d' ], @@ -282,40 +302,81 @@ if ($^O eq 'MacOS') { [ "VMS->case_tolerant()", '1' ], -[ "VMS->catfile('a','b','c')", '[.a.b]c' ], +[ "VMS->catfile('a','b','c')", $vms_unix_rpt ? 'a/b/c' : '[.a.b]c' ], [ "VMS->catfile('a','b','[]c')", '[.a.b]c' ], [ "VMS->catfile('[.a]','b','c')", '[.a.b]c' ], [ "VMS->catfile('c')", 'c' ], [ "VMS->catfile('[]c')", 'c' ], -[ "VMS->catfile('0','b','c')", '[.0.b]c' ], -[ "VMS->catfile('a','0','c')", '[.a.0]c' ], -[ "VMS->catfile('a','b','0')", '[.a.b]0' ], -[ "VMS->catfile('0','0','c')", '[.0.0]c' ], -[ "VMS->catfile('a','0','0')", '[.a.0]0' ], -[ "VMS->catfile('0','b','0')", '[.0.b]0' ], -[ "VMS->catfile('0','0','0')", '[.0.0]0' ], +[ "VMS->catfile('0','b','c')", $vms_unix_rpt ? '0/b/c' : '[.0.b]c' ], +[ "VMS->catfile('a','0','c')", $vms_unix_rpt ? 'a/0/c' : '[.a.0]c' ], +[ "VMS->catfile('a','b','0')", $vms_unix_rpt ? 'a/b/0' : '[.a.b]0' ], +[ "VMS->catfile('0','0','c')", $vms_unix_rpt ? '0/0/c' : '[.0.0]c' ], +[ "VMS->catfile('a','0','0')", $vms_unix_rpt ? 'a/0/0' : '[.a.0]0' ], +[ "VMS->catfile('0','b','0')", $vms_unix_rpt ? '0/b/0' : '[.0.b]0' ], +[ "VMS->catfile('0','0','0')", $vms_unix_rpt ? '0/0/0' : '[.0.0]0' ], [ "VMS->splitpath('file')", ',,file' ], [ "VMS->splitpath('[d1.d2.d3]')", ',[d1.d2.d3],' ], [ "VMS->splitpath('[.d1.d2.d3]')", ',[.d1.d2.d3],' ], [ "VMS->splitpath('[d1.d2.d3]file')", ',[d1.d2.d3],file' ], -[ "VMS->splitpath('d1/d2/d3/file')", ',[.d1.d2.d3],file' ], -[ "VMS->splitpath('/d1/d2/d3/file')", 'd1:,[d2.d3],file' ], +[ "VMS->splitpath('d1/d2/d3/file')", + $vms_efs ? ',d1/d2/d3/,file' : ',[.d1.d2.d3],file' ], +[ "VMS->splitpath('/d1/d2/d3/file')", + $vms_efs ? ',/d1/d2/d3/,file' : 'd1:,[d2.d3],file' ], [ "VMS->splitpath('[.d1.d2.d3]file')", ',[.d1.d2.d3],file' ], [ "VMS->splitpath('node::volume:[d1.d2.d3]')", 'node::volume:,[d1.d2.d3],' ], [ "VMS->splitpath('node::volume:[d1.d2.d3]file')", 'node::volume:,[d1.d2.d3],file' ], [ "VMS->splitpath('node\"access_spec\"::volume:[d1.d2.d3]')", 'node"access_spec"::volume:,[d1.d2.d3],' ], [ "VMS->splitpath('node\"access_spec\"::volume:[d1.d2.d3]file')", 'node"access_spec"::volume:,[d1.d2.d3],file' ], +[ "VMS->splitpath('[]')", ',[],' ], +[ "VMS->splitpath('[-]')", ',[-],' ], +[ "VMS->splitpath('[]file')", ',[],file' ], +[ "VMS->splitpath('[-]file')", ',[-],file' ], +[ "VMS->splitpath('')", ',,' ], +[ "VMS->splitpath('0')", ',,0' ], +[ "VMS->splitpath('[0]')", ',[0],' ], +[ "VMS->splitpath('[.0]')", ',[.0],' ], +[ "VMS->splitpath('[0.0.0]')", ',[0.0.0],' ], +[ "VMS->splitpath('[.0.0.0]')", ',[.0.0.0],' ], +[ "VMS->splitpath('[0]0')", ',[0],0' ], +[ "VMS->splitpath('[0.0.0]0')", ',[0.0.0],0' ], +[ "VMS->splitpath('[.0.0.0]0')", ',[.0.0.0],0' ], +[ "VMS->splitpath('0/0')", $vms_efs ? ',0/,0' : ',[.0],0' ], +[ "VMS->splitpath('0/0/0')", $vms_efs ? ',0/0/,0' : ',[.0.0],0' ], +[ "VMS->splitpath('/0/0')", $vms_efs ? ',/0/,0' : '0:,[000000],0' ], +[ "VMS->splitpath('/0/0/0')", $vms_efs ? ',/0/0/,0' : '0:,[0],0' ], +[ "VMS->splitpath('d1',1)", ',d1,' ], +# $no_file tests +[ "VMS->splitpath('[d1.d2.d3]',1)", ',[d1.d2.d3],' ], +[ "VMS->splitpath('[.d1.d2.d3]',1)", ',[.d1.d2.d3],' ], +[ "VMS->splitpath('d1/d2/d3',1)", $vms_efs ? ',d1/d2/d3,' : ',[.d1.d2.d3],' ], +[ "VMS->splitpath('/d1/d2/d3',1)", $vms_efs ? ',/d1/d2/d3,' : 'd1:,[d2.d3],' ], +[ "VMS->splitpath('node::volume:[d1.d2.d3]',1)", 'node::volume:,[d1.d2.d3],' ], +[ "VMS->splitpath('node\"access_spec\"::volume:[d1.d2.d3]',1)", 'node"access_spec"::volume:,[d1.d2.d3],' ], +[ "VMS->splitpath('[]',1)", ',[],' ], +[ "VMS->splitpath('[-]',1)", ',[-],' ], +[ "VMS->splitpath('',1)", ',,' ], +[ "VMS->splitpath('0',1)", ',0,' ], +[ "VMS->splitpath('[0]',1)", ',[0],' ], +[ "VMS->splitpath('[.0]',1)", ',[.0],' ], +[ "VMS->splitpath('[0.0.0]',1)", ',[0.0.0],' ], +[ "VMS->splitpath('[.0.0.0]',1)", ',[.0.0.0],' ], +[ "VMS->splitpath('0/0',1)", $vms_efs ? ',0/0,' : ',[.0.0],' ], +[ "VMS->splitpath('0/0/0',1)", $vms_efs ? ',0/0/0,' : ',[.0.0.0],' ], +[ "VMS->splitpath('/0/0',1)", $vms_efs ? ',/0/0,' : '0:,[000000.0],' ], +[ "VMS->splitpath('/0/0/0',1)", $vms_efs ? ',/0/0/0,' : '0:,[0.0],' ], + [ "VMS->catpath('','','file')", 'file' ], [ "VMS->catpath('','[d1.d2.d3]','')", '[d1.d2.d3]' ], [ "VMS->catpath('','[.d1.d2.d3]','')", '[.d1.d2.d3]' ], [ "VMS->catpath('','[d1.d2.d3]','file')", '[d1.d2.d3]file' ], [ "VMS->catpath('','[.d1.d2.d3]','file')", '[.d1.d2.d3]file' ], -[ "VMS->catpath('','d1/d2/d3','file')", '[.d1.d2.d3]file' ], -[ "VMS->catpath('v','d1/d2/d3','file')", 'v:[.d1.d2.d3]file' ], +[ "VMS->catpath('','d1/d2/d3','file')", + $vms_efs ? 'd1/d2/d3/file' : '[.d1.d2.d3]file' ], +[ "VMS->catpath('v','d1/d2/d3','file')", 'v:[.d1.d2.d3]file' ], [ "VMS->catpath('v','w:[d1.d2.d3]','file')", 'v:[d1.d2.d3]file' ], [ "VMS->catpath('node::volume:','[d1.d2.d3]','')", 'node::volume:[d1.d2.d3]' ], [ "VMS->catpath('node::volume:','[d1.d2.d3]','file')", 'node::volume:[d1.d2.d3]file' ], @@ -370,15 +431,18 @@ if ($^O eq 'MacOS') { [ "VMS->splitdir('[d1.][000000.d2]')", 'd1,d2' ], [ "VMS->splitdir('[.d1.d2^.d3]')", 'd1,d2^.d3' ], -[ "VMS->catdir('')", '' ], -[ "VMS->catdir('d1','d2','d3')", '[.d1.d2.d3]' ], -[ "VMS->catdir('d1','d2/','d3')", '[.d1.d2.d3]' ], -[ "VMS->catdir('','d1','d2','d3')", '[.d1.d2.d3]' ], -[ "VMS->catdir('','-','d2','d3')", '[-.d2.d3]' ], -[ "VMS->catdir('','-','','d3')", '[-.d3]' ], -[ "VMS->catdir('dir.dir','d2.dir','d3.dir')", '[.dir.d2.d3]' ], -[ "VMS->catdir('[.name]')", '[.name]' ], -[ "VMS->catdir('[.name]','[.name]')", '[.name.name]'], +[ "VMS->catdir('')", '' ], +[ "VMS->catdir('d1','d2','d3')", $vms_unix_rpt ? 'd1/d2/d3' : '[.d1.d2.d3]' ], +[ "VMS->catdir('d1','d2/','d3')", $vms_efs ? 'd1/d2/d3' : '[.d1.d2.d3]' ], +[ "VMS->catdir('','d1','d2','d3')", + $vms_unix_rpt ? '/d1/d2/d3' : + $vms_efs ? '[d1.d2.d3]' : '[.d1.d2.d3]' ], +[ "VMS->catdir('','-','d2','d3')", '[-.d2.d3]' ], +[ "VMS->catdir('','-','','d3')", '[-.d3]' ], +[ "VMS->catdir('dir.dir','d2.dir','d3.dir')", + $vms_unix_rpt ? 'dir.dir/d2.dir/d3.dir' : '[.dir.d2.d3]' ], +[ "VMS->catdir('[.name]')", '[.name]' ], +[ "VMS->catdir('[.name]','[.name]')", '[.name.name]'], [ "VMS->abs2rel('node::volume:[t1.t2.t3]','node::volume:[t1.t2.t3]')", '[]' ], [ "VMS->abs2rel('node::volume:[t1.t2.t3]','[t1.t2.t3]')", 'node::volume:[t1.t2.t3]' ], @@ -694,10 +758,11 @@ if ($^O eq 'MacOS') { [ "Cygwin->rel2abs('..','/t1/t2/t3')", '/t1/t2/t3/..' ], [ "Cygwin->rel2abs('../t4','/t1/t2/t3')", '/t1/t2/t3/../t4' ], [ "Cygwin->rel2abs('/t1','/t1/t2/t3')", '/t1' ], +[ "Cygwin->rel2abs('//t1/t2/t3','/foo')", '//t1/t2/t3' ], ) ; - +my $test_count = scalar @tests; plan tests => scalar @tests; diff -up perl-5.10.0/lib/File/Spec/t/tmpdir.t.aa perl-5.10.0/lib/File/Spec/t/tmpdir.t --- perl-5.10.0/lib/File/Spec/t/tmpdir.t.aa 2007-12-18 11:47:07.000000000 +0100 +++ perl-5.10.0/lib/File/Spec/t/tmpdir.t 2009-05-10 10:58:10.000000000 +0200 @@ -9,14 +9,19 @@ plan tests => 4; ok 1, 1, "Loaded"; +if ($^O eq 'VMS') { + # hack: + # Need to cause the %ENV to get populated or you only get the builtins at + # first, and then something else can cause the hash to get populated. + my %look_env = %ENV; +} my $num_keys = keys %ENV; File::Spec->tmpdir; ok scalar keys %ENV, $num_keys, "tmpdir() shouldn't change the contents of %ENV"; if ($^O eq 'VMS') { - skip('Can\'t make list assignment to \%ENV on this system', 1); -} -else { + skip("Can't make list assignment to %ENV on this system", 1); +} else { local %ENV; File::Spec::Win32->tmpdir; ok scalar keys %ENV, 0, "Win32->tmpdir() shouldn't change the contents of %ENV"; diff -up perl-5.10.0/lib/File/Spec.pm.aa perl-5.10.0/lib/File/Spec.pm --- perl-5.10.0/lib/File/Spec.pm.aa 2007-12-18 11:47:07.000000000 +0100 +++ perl-5.10.0/lib/File/Spec.pm 2009-05-10 10:58:10.000000000 +0200 @@ -3,7 +3,7 @@ package File::Spec; use strict; use vars qw(@ISA $VERSION); -$VERSION = '3.2501'; +$VERSION = '3.30'; $VERSION = eval $VERSION; my %module = (MacOS => 'Mac', diff -up perl-5.10.0/lib/File/Spec/Unix.pm.aa perl-5.10.0/lib/File/Spec/Unix.pm --- perl-5.10.0/lib/File/Spec/Unix.pm.aa 2007-12-18 11:47:07.000000000 +0100 +++ perl-5.10.0/lib/File/Spec/Unix.pm 2009-05-10 10:58:10.000000000 +0200 @@ -3,7 +3,8 @@ package File::Spec::Unix; use strict; use vars qw($VERSION); -$VERSION = '3.2501'; +$VERSION = '3.30'; +$VERSION = eval $VERSION; =head1 NAME @@ -41,6 +42,7 @@ actually traverse the filesystem cleanin sub canonpath { my ($self,$path) = @_; + return unless defined $path; # Handle POSIX-style node names beginning with double slash (qnx, nto) # (POSIX says: "a pathname that begins with two successive slashes @@ -48,7 +50,10 @@ sub canonpath { # more than two leading slashes shall be treated as a single slash.") my $node = ''; my $double_slashes_special = $^O eq 'qnx' || $^O eq 'nto'; - if ( $double_slashes_special && $path =~ s{^(//[^/]+)(?:/|\z)}{/}s ) { + + + if ( $double_slashes_special + && ( $path =~ s{^(//[^/]+)/?\z}{}s || $path =~ s{^(//[^/]+)/}{/}s ) ) { $node = $1; } # This used to be @@ -103,7 +108,7 @@ Returns a string representation of the c =cut -sub curdir () { '.' } +sub curdir { '.' } =item devnull @@ -111,7 +116,7 @@ Returns a string representation of the n =cut -sub devnull () { '/dev/null' } +sub devnull { '/dev/null' } =item rootdir @@ -119,7 +124,7 @@ Returns a string representation of the r =cut -sub rootdir () { '/' } +sub rootdir { '/' } =item tmpdir @@ -168,7 +173,7 @@ Returns a string representation of the p =cut -sub updir () { '..' } +sub updir { '..' } =item no_upwards @@ -189,7 +194,7 @@ is not or is significant when comparing =cut -sub case_tolerant () { 0 } +sub case_tolerant { 0 } =item file_name_is_absolute diff -up perl-5.10.0/lib/File/Spec/VMS.pm.aa perl-5.10.0/lib/File/Spec/VMS.pm --- perl-5.10.0/lib/File/Spec/VMS.pm.aa 2007-12-18 11:47:07.000000000 +0100 +++ perl-5.10.0/lib/File/Spec/VMS.pm 2009-05-10 10:58:10.000000000 +0200 @@ -4,7 +4,8 @@ use strict; use vars qw(@ISA $VERSION); require File::Spec::Unix; -$VERSION = '3.2501'; +$VERSION = '3.30'; +$VERSION = eval $VERSION; @ISA = qw(File::Spec::Unix); @@ -25,26 +26,105 @@ See File::Spec::Unix for a documentation there. This package overrides the implementation of these methods, not the semantics. +The mode of operation of these routines depend on the VMS features that +are controlled by the DECC features C and +C. + +Perl needs to be at least at 5.10 for these feature settings to work. +Use of them on older perl versions on VMS will result in unpredictable +operations. + +The default and traditional mode of these routines have been to expect VMS +syntax on input and to return VMS syntax on output, even when Unix syntax was +given on input. + +The default and traditional mode is also incompatible with the VMS +C, Extended File system character set, and with running Perl scripts +under , Gnu is not VMS, an optional Unix like runtime environment on VMS. + +If the C feature is enabled, These routines will now accept +either VMS or UNIX syntax. If the input parameters are clearly VMS syntax, +the return value will be in VMS syntax. If the input parameters are clearly +in Unix syntax, the output will be in Unix syntax. + +This corresponds to the way that the VMS C library routines have always +handled filenames, and what a programmer who has not specifically read this +pod before would also expect. + +If the C feature is enabled, then if the output +syntax can not be determined from the input syntax, the output syntax will be +UNIX. If the feature is not enabled, VMS output will be the default. + =over 4 +=cut + +# Need to look up the feature settings. The preferred way is to use the +# VMS::Feature module, but that may not be available to dual life modules. + +my $use_feature; +BEGIN { + if (eval { local $SIG{__DIE__}; require VMS::Feature; }) { + $use_feature = 1; + } +} + +# Need to look up the UNIX report mode. This may become a dynamic mode +# in the future. +sub _unix_rpt { + my $unix_rpt; + if ($use_feature) { + $unix_rpt = VMS::Feature::current("filename_unix_report"); + } else { + my $env_unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || ''; + $unix_rpt = $env_unix_rpt =~ /^[ET1]/i; + } + return $unix_rpt; +} + +# Need to look up the EFS character set mode. This may become a dynamic +# mode in the future. +sub _efs { + my $efs; + if ($use_feature) { + $efs = VMS::Feature::current("efs_charset"); + } else { + my $env_efs = $ENV{'DECC$EFS_CHARSET'} || ''; + $efs = $env_efs =~ /^[ET1]/i; + } + return $efs; +} + =item canonpath (override) -Removes redundant portions of file specifications according to VMS syntax. +Removes redundant portions of file specifications according to the syntax +detected. =cut + sub canonpath { my($self,$path) = @_; return undef unless defined $path; + my $efs = $self->_efs; + if ($path =~ m|/|) { # Fake Unix my $pathify = $path =~ m|/\Z(?!\n)|; $path = $self->SUPER::canonpath($path); + + # Do not convert to VMS when EFS character sets are in use + return $path if $efs; + if ($pathify) { return vmspath($path); } else { return vmsify($path); } } else { + +#FIXME - efs parsing has different rules. Characters in a VMS filespec +# are only delimiters if not preceded by '^'; + $path =~ tr/<>/[]/; # < and > ==> [ and ] $path =~ s/\]\[\./\.\]\[/g; # ][. ==> .][ $path =~ s/\[000000\.\]\[/\[/g; # [000000.][ ==> [ @@ -81,7 +161,7 @@ sub canonpath { =item catdir (override) Concatenates a list of file specifications, and returns the result as a -VMS-syntax directory specification. No check is made for "impossible" +directory specification. No check is made for "impossible" cases (e.g. elements other than the first being absolute filespecs). =cut @@ -89,87 +169,377 @@ cases (e.g. elements other than the firs sub catdir { my $self = shift; my $dir = pop; + + my $efs = $self->_efs; + my $unix_rpt = $self->_unix_rpt; + + my @dirs = grep {defined() && length()} @_; + if ($efs) { + # Legacy mode removes blank entries. + # But that breaks existing generic perl code that + # uses a blank path at the beginning of the array + # to indicate an absolute path. + # So put it back if found. + if (@_) { + if ($_[0] eq '') { + unshift @dirs, ''; + } + } + } my $rslt; if (@dirs) { my $path = (@dirs == 1 ? $dirs[0] : $self->catdir(@dirs)); my ($spath,$sdir) = ($path,$dir); - $spath =~ s/\.dir\Z(?!\n)//; $sdir =~ s/\.dir\Z(?!\n)//; - $sdir = $self->eliminate_macros($sdir) unless $sdir =~ /^[\w\-]+\Z(?!\n)/s; - $rslt = $self->fixpath($self->eliminate_macros($spath)."/$sdir",1); - - # Special case for VMS absolute directory specs: these will have had device - # prepended during trip through Unix syntax in eliminate_macros(), since - # Unix syntax has no way to express "absolute from the top of this device's - # directory tree". - if ($spath =~ /^[\[<][^.\-]/s) { $rslt =~ s/^[^\[<]+//s; } - } - else { + + if ($efs) { + # Extended character set in use, go into DWIM mode. + + # Now we need to identify what the directory is in + # of the specification in order to merge them. + my $path_unix = 0; + $path_unix = 1 if ($path =~ m#/#); + $path_unix = 1 if ($path =~ /^\.\.?$/); + my $path_vms = 0; + $path_vms = 1 if ($path =~ m#[\[<\]]#); + $path_vms = 1 if ($path =~ /^--?$/); + my $dir_unix = 0; + $dir_unix = 1 if ($dir =~ m#/#); + $dir_unix = 1 if ($dir =~ /^\.\.?$/); + my $dir_vms = 0; + $dir_vms = 1 if ($dir =~ m#[\[<\]]#); + $dir_vms = 1 if ($dir =~ /^--?$/); + + my $unix_mode = 0; + if (($path_unix != $dir_unix) && ($path_vms != $dir_vms)) { + # Ambiguous, so if in $unix_rpt mode then assume UNIX. + $unix_mode = 1 if $unix_rpt; + } else { + $unix_mode = 1 if (!$path_vms && !$dir_vms && $unix_rpt); + $unix_mode = 1 if ($path_unix || $dir_unix); + } + + if ($unix_mode) { + + # Fix up mixed syntax imput as good as possible - GIGO + $path = unixify($path) if $path_vms; + $dir = unixify($dir) if $dir_vms; + + $rslt = $path; + # Append a path delimiter + $rslt .= '/' unless ($rslt =~ m#/$#); + + $rslt .= $dir; + return $self->SUPER::canonpath($rslt); + } else { + + #with <> posible instead of [. + # Normalize the brackets + # Fixme - need to not switch when preceded by ^. + $path =~ s//\]/g; + $dir =~ s//\]/g; + + # Fix up mixed syntax imput as good as possible - GIGO + $path = vmsify($path) if $path_unix; + $dir = vmsify($dir) if $dir_unix; + + #Possible path values: foo: [.foo] [foo] foo, and $(foo) + #or starting with '-', or foo.dir + #If path is foo, it needs to be converted to [.foo] + + # Fix up a bare path name. + unless ($path_vms) { + $path =~ s/\.dir\Z(?!\n)//i; + if (($path ne '') && ($path !~ /^-/)) { + # Non blank and not prefixed with '-', add a dot + $path = '[.' . $path; + } else { + # Just start a directory. + $path = '[' . $path; + } + } else { + $path =~ s/\]$//; + } + + #Possible dir values: [.dir] dir and $(foo) + + # No punctuation may have a trailing .dir + unless ($dir_vms) { + $dir =~ s/\.dir\Z(?!\n)//i; + } else { + + #strip off the brackets + $dir =~ s/^\[//; + $dir =~ s/\]$//; + } + + #strip off the leading dot if present. + $dir =~ s/^\.//; + + # Now put the specifications together. + if ($dir ne '') { + # Add a separator unless this is an absolute path + $path .= '.' if ($path ne '['); + $rslt = $path . $dir . ']'; + } else { + $rslt = $path . ']'; + } + } + + } else { + # Traditional ODS-2 mode. + $spath =~ s/\.dir\Z(?!\n)//i; $sdir =~ s/\.dir\Z(?!\n)//i; + + $sdir = $self->eliminate_macros($sdir) + unless $sdir =~ /^[\w\-]+\Z(?!\n)/s; + $rslt = $self->fixpath($self->eliminate_macros($spath)."/$sdir",1); + + # Special case for VMS absolute directory specs: these will have + # had device prepended during trip through Unix syntax in + # eliminate_macros(), since Unix syntax has no way to express + # "absolute from the top of this device's directory tree". + if ($spath =~ /^[\[<][^.\-]/s) { $rslt =~ s/^[^\[<]+//s; } + } + } else { + # Single directory, just make sure it is in directory format + # Return an empty string on null input, and pass through macros. + if (not defined $dir or not length $dir) { $rslt = ''; } - elsif ($dir =~ /^\$\([^\)]+\)\Z(?!\n)/s) { $rslt = $dir; } - else { $rslt = vmspath($dir); } + elsif ($dir =~ /^\$\([^\)]+\)\Z(?!\n)/s) { + $rslt = $dir; + } else { + my $unix_mode = 0; + + if ($efs) { + my $dir_unix = 0; + $dir_unix = 1 if ($dir =~ m#/#); + $dir_unix = 1 if ($dir =~ /^\.\.?$/); + my $dir_vms = 0; + $dir_vms = 1 if ($dir =~ m#[\[<\]]#); + $dir_vms = 1 if ($dir =~ /^--?$/); + + if ($dir_vms == $dir_unix) { + # Ambiguous, so if in $unix_rpt mode then assume UNIX. + $unix_mode = 1 if $unix_rpt; + } else { + $unix_mode = 1 if $dir_unix; + } + } + + if ($unix_mode) { + return $dir; + } else { + # For VMS, force it to be in directory format + $rslt = vmspath($dir); + } + } } return $self->canonpath($rslt); } =item catfile (override) -Concatenates a list of file specifications, and returns the result as a -VMS-syntax file specification. +Concatenates a list of directory specifications with a filename specification +to build a path. =cut sub catfile { my $self = shift; - my $file = $self->canonpath(pop()); + my $tfile = pop(); + my $file = $self->canonpath($tfile); my @files = grep {defined() && length()} @_; + my $efs = $self->_efs; + my $unix_rpt = $self->_unix_rpt; + + # Assume VMS mode + my $unix_mode = 0; + my $file_unix = 0; + my $file_vms = 0; + if ($efs) { + + # Now we need to identify format the file is in + # of the specification in order to merge them. + $file_unix = 1 if ($tfile =~ m#/#); + $file_unix = 1 if ($tfile =~ /^\.\.?$/); + $file_vms = 1 if ($tfile =~ m#[\[<\]]#); + $file_vms = 1 if ($tfile =~ /^--?$/); + + # We may know for sure what the format is. + if (($file_unix != $file_vms)) { + $unix_mode = 1 if ($file_unix && $unix_rpt); + } + } + my $rslt; if (@files) { - my $path = (@files == 1 ? $files[0] : $self->catdir(@files)); + # concatenate the directories. + my $path; + if (@files == 1) { + $path = $files[0]; + } else { + if ($file_vms) { + # We need to make sure this is in VMS mode to avoid doing + # both a vmsify and unixfy on the same path, as that may + # lose significant data. + my $i = @files - 1; + my $tdir = $files[$i]; + my $tdir_vms = 0; + my $tdir_unix = 0; + $tdir_vms = 1 if ($tdir =~ m#[\[<\]]#); + $tdir_unix = 1 if ($tdir =~ m#/#); + $tdir_unix = 1 if ($tdir =~ /^\.\.?$/); + + if (!$tdir_vms) { + if ($tdir_unix) { + $tdir = vmspath($tdir); + } else { + $tdir =~ s/\.dir\Z(?!\n)//i; + $tdir = '[.' . $tdir . ']'; + } + $files[$i] = $tdir; + } + } + $path = $self->catdir(@files); + } my $spath = $path; - $spath =~ s/\.dir\Z(?!\n)//; + + # Some thing building a VMS path in pieces may try to pass a + # directory name in filename format, so normalize it. + $spath =~ s/\.dir\Z(?!\n)//i; + + # if the spath ends with a directory delimiter and the file is bare, + # then just concat them. + # FIX-ME: In VMS format "[]<>:" are not delimiters if preceded by '^' + # Quite a bit of Perl does not know that yet. if ($spath =~ /^[^\)\]\/:>]+\)\Z(?!\n)/s && basename($file) eq $file) { $rslt = "$spath$file"; - } - else { - $rslt = $self->eliminate_macros($spath); - $rslt = vmsify($rslt.((defined $rslt) && ($rslt ne '') ? '/' : '').unixify($file)); + } else { + if ($efs) { + + # Now we need to identify what the directory is in + # of the specification in order to merge them. + my $spath_unix = 0; + $spath_unix = 1 if ($spath =~ m#/#); + $spath_unix = 1 if ($spath =~ /^\.\.?$/); + my $spath_vms = 0; + $spath_vms = 1 if ($spath =~ m#[\[<\]]#); + $spath_vms = 1 if ($spath =~ /^--?$/); + + # Assume VMS mode + if (($spath_unix == $spath_vms) && + ($file_unix == $file_vms)) { + # Ambigous, so if in $unix_rpt mode then assume UNIX. + $unix_mode = 1 if $unix_rpt; + } else { + $unix_mode = 1 + if (($spath_unix || $file_unix) && $unix_rpt); + } + + if (!$unix_mode) { + if ($spath_vms) { + $spath = '[' . $spath . ']' if $spath =~ /^-/; + $rslt = vmspath($spath); + } else { + $rslt = '[.' . $spath . ']'; + } + $file = vmsify($file) if ($file_unix); + } else { + $spath = unixify($spath) if ($spath_vms); + $rslt = $spath; + $file = unixify($file) if ($file_vms); + + # Unix merge may need a directory delimitor. + # A null path indicates root on Unix. + $rslt .= '/' unless ($rslt =~ m#/$#); + } + + $rslt .= $file; + $rslt =~ s/\]\[//; + + } else { + # Traditional VMS Perl mode expects that this is done. + # Note for future maintainers: + # This is left here for compatibility with perl scripts + # that have come to expect this behavior, even though + # usually the Perl scripts ported to VMS have to be + # patched because of it changing Unix syntax file + # to VMS format. + + $rslt = $self->eliminate_macros($spath); + + + $rslt = vmsify($rslt.((defined $rslt) && + ($rslt ne '') ? '/' : '').unixify($file)); + } } } - else { $rslt = (defined($file) && length($file)) ? vmsify($file) : ''; } - return $self->canonpath($rslt); + else { + # Only passed a single file? + my $xfile = $file; + + # Traditional VMS perl expects this conversion. + $xfile = vmsify($file) unless ($efs); + + $rslt = (defined($file) && length($file)) ? $xfile : ''; + } + return $self->canonpath($rslt) unless $unix_rpt; + + # In Unix report mode, do not strip off redundent path information. + return $rslt; } =item curdir (override) -Returns a string representation of the current directory: '[]' +Returns a string representation of the current directory: '[]' or '.' =cut sub curdir { + my $self = shift @_; + return '.' if ($self->_unix_rpt); return '[]'; } =item devnull (override) -Returns a string representation of the null device: '_NLA0:' +Returns a string representation of the null device: '_NLA0:' or '/dev/null' =cut sub devnull { + my $self = shift @_; + return '/dev/null' if ($self->_unix_rpt); return "_NLA0:"; } =item rootdir (override) Returns a string representation of the root directory: 'SYS$DISK:[000000]' +or '/' =cut sub rootdir { + my $self = shift @_; + if ($self->_unix_rpt) { + # Root may exist, try it first. + my $try = '/'; + my ($dev1, $ino1) = stat('/'); + my ($dev2, $ino2) = stat('.'); + + # Perl falls back to '.' if it can not determine '/' + if (($dev1 != $dev2) || ($ino1 != $ino2)) { + return $try; + } + # Fall back to UNIX format sys$disk. + return '/sys$disk/'; + } return 'SYS$DISK:[000000]'; } @@ -178,6 +548,7 @@ sub rootdir { Returns a string representation of the first writable directory from the following list or '' if none are writable: + /tmp if C is enabled. sys$scratch: $ENV{TMPDIR} @@ -188,17 +559,25 @@ is tainted, it is not used. my $tmpdir; sub tmpdir { + my $self = shift @_; return $tmpdir if defined $tmpdir; - $tmpdir = $_[0]->_tmpdir( 'sys$scratch:', $ENV{TMPDIR} ); + if ($self->_unix_rpt) { + $tmpdir = $self->_tmpdir('/tmp', '/sys$scratch', $ENV{TMPDIR}); + return $tmpdir; + } + + $tmpdir = $self->_tmpdir( 'sys$scratch:', $ENV{TMPDIR} ); } =item updir (override) -Returns a string representation of the parent directory: '[-]' +Returns a string representation of the parent directory: '[-]' or '..' =cut sub updir { + my $self = shift @_; + return '..' if ($self->_unix_rpt); return '[-]'; } @@ -242,21 +621,50 @@ sub file_name_is_absolute { =item splitpath (override) -Splits using VMS syntax. + ($volume,$directories,$file) = File::Spec->splitpath( $path ); + ($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file ); + +Passing a true value for C<$no_file> indicates that the path being +split only contains directory components, even on systems where you +can usually (when not supporting a foreign syntax) tell the difference +between directories and files at a glance. =cut sub splitpath { - my($self,$path) = @_; - my($dev,$dir,$file) = ('','',''); + my($self,$path, $nofile) = @_; + my($dev,$dir,$file) = ('','',''); + my $efs = $self->_efs; + my $vmsify_path = vmsify($path); + if ($efs) { + my $path_vms = 0; + $path_vms = 1 if ($path =~ m#[\[<\]]#); + $path_vms = 1 if ($path =~ /^--?$/); + if (!$path_vms) { + return $self->SUPER::splitpath($path, $nofile); + } + $vmsify_path = $path; + } - vmsify($path) =~ /(.+:)?([\[<].*[\]>])?(.*)/s; - return ($1 || '',$2 || '',$3); + if ( $nofile ) { + #vmsify('d1/d2/d3') returns '[.d1.d2]d3' + #vmsify('/d1/d2/d3') returns 'd1:[d2]d3' + if( $vmsify_path =~ /(.*)\](.+)/ ){ + $vmsify_path = $1.'.'.$2.']'; + } + $vmsify_path =~ /(.+:)?(.*)/s; + $dir = defined $2 ? $2 : ''; # dir can be '0' + return ($1 || '',$dir,$file); + } + else { + $vmsify_path =~ /(.+:)?([\[<].*[\]>])?(.*)/s; + return ($1 || '',$2 || '',$3); + } } =item splitdir (override) -Split dirspec using VMS syntax. +Split a directory specification into the components. =cut @@ -264,6 +672,20 @@ sub splitdir { my($self,$dirspec) = @_; my @dirs = (); return @dirs if ( (!defined $dirspec) || ('' eq $dirspec) ); + + my $efs = $self->_efs; + + my $dir_unix = 0; + $dir_unix = 1 if ($dirspec =~ m#/#); + $dir_unix = 1 if ($dirspec =~ /^\.\.?$/); + + # Unix filespecs in EFS mode handled by Unix routines. + if ($efs && $dir_unix) { + return $self->SUPER::splitdir($dirspec); + } + + # FIX ME, only split for VMS delimiters not prefixed with '^'. + $dirspec =~ tr/<>/[]/; # < and > ==> [ and ] $dirspec =~ s/\]\[\./\.\]\[/g; # ][. ==> .][ $dirspec =~ s/\[000000\.\]\[/\[/g; # [000000.][ ==> [ @@ -287,40 +709,152 @@ sub splitdir { =item catpath (override) -Construct a complete filespec using VMS syntax +Construct a complete filespec. =cut sub catpath { my($self,$dev,$dir,$file) = @_; + my $efs = $self->_efs; + my $unix_rpt = $self->_unix_rpt; + + my $unix_mode = 0; + my $dir_unix = 0; + $dir_unix = 1 if ($dir =~ m#/#); + $dir_unix = 1 if ($dir =~ /^\.\.?$/); + my $dir_vms = 0; + $dir_vms = 1 if ($dir =~ m#[\[<\]]#); + $dir_vms = 1 if ($dir =~ /^--?$/); + + if ($efs && (length($dev) == 0)) { + if ($dir_unix == $dir_vms) { + $unix_mode = $unix_rpt; + } else { + $unix_mode = $dir_unix; + } + } + # We look for a volume in $dev, then in $dir, but not both - my ($dir_volume, $dir_dir, $dir_file) = $self->splitpath($dir); - $dev = $dir_volume unless length $dev; - $dir = length $dir_file ? $self->catfile($dir_dir, $dir_file) : $dir_dir; - + # but only if using VMS syntax. + if (!$unix_mode) { + $dir = vmspath($dir) if $dir_unix; + my ($dir_volume, $dir_dir, $dir_file) = $self->splitpath($dir); + $dev = $dir_volume unless length $dev; + $dir = length $dir_file ? $self->catfile($dir_dir, $dir_file) : + $dir_dir; + } if ($dev =~ m|^/+([^/]+)|) { $dev = "$1:"; } else { $dev .= ':' unless $dev eq '' or $dev =~ /:\Z(?!\n)/; } if (length($dev) or length($dir)) { - $dir = "[$dir]" unless $dir =~ /[\[<\/]/; - $dir = vmspath($dir); + if ($efs) { + if ($unix_mode) { + $dir .= '/' unless ($dir =~ m#/$#); + } else { + $dir = vmspath($dir) if (($dir =~ m#/#) || ($dir =~ /^\.\.?$/)); + $dir = "[$dir]" unless $dir =~ /^[\[<]/; + } + } else { + $dir = "[$dir]" unless $dir =~ /[\[<\/]/; + $dir = vmspath($dir); + } } "$dev$dir$file"; } =item abs2rel (override) -Use VMS syntax when converting filespecs. +Attempt to convert a file specification to a relative specification. +On a system with volumes, like VMS, this may not be possible. =cut sub abs2rel { my $self = shift; - return vmspath(File::Spec::Unix::abs2rel( $self, @_ )) - if grep m{/}, @_; - my($path,$base) = @_; - $base = $self->_cwd() unless defined $base and length $base; + + my $efs = $self->_efs; + my $unix_rpt = $self->_unix_rpt; + + if (!$efs) { + return vmspath(File::Spec::Unix::abs2rel( $self, @_ )) + if grep m{/}, @_; + } + + # We need to identify what the directory is in + # of the specification in order to process them + my $path_unix = 0; + $path_unix = 1 if ($path =~ m#/#); + $path_unix = 1 if ($path =~ /^\.\.?$/); + my $path_vms = 0; + $path_vms = 1 if ($path =~ m#[\[<\]]#); + $path_vms = 1 if ($path =~ /^--?$/); + + my $unix_mode = 0; + if ($path_vms == $path_unix) { + $unix_mode = $unix_rpt; + } else { + $unix_mode = $path_unix; + } + + my $base_unix = 0; + my $base_vms = 0; + + if (defined $base) { + $base_unix = 1 if ($base =~ m#/#); + $base_unix = 1 if ($base =~ /^\.\.?$/); + $base_vms = 1 if ($base =~ m#[\[<\]]#); + $base_vms = 1 if ($base =~ /^--?$/); + + if ($path_vms == $path_unix) { + if ($base_vms == $base_unix) { + $unix_mode = $unix_rpt; + } else { + $unix_mode = $base_unix; + } + } else { + $unix_mode = 0 if $base_vms; + } + } + + if ($efs) { + if ($unix_mode) { + # We are UNIX mode. + $base = unixpath($base) if $base_vms; + $base = unixify($path) if $path_vms; + + # Here VMS is different, and in order to do this right + # we have to take the realpath for both the path and the base + # so that we can remove the common components. + + if ($path =~ m#^/#) { + if (defined $base) { + + # For the shorterm, if the starting directories are + # common, remove them. + my $bq = qq($base); + $bq =~ s/\$/\\\$/; + $path =~ s/^$bq//i; + } + return $path; + } + + return File::Spec::Unix::abs2rel( $self, $path, $base ); + + } else { + $base = vmspath($base) if $base_unix; + $path = vmsify($path) if $path_unix; + } + } + + unless (defined $base and length $base) { + $base = $self->_cwd(); + if ($efs) { + $base_unix = 1 if ($base =~ m#/#); + $base_unix = 1 if ($base =~ /^\.\.?$/); + $base = vmspath($base) if $base_unix; + } + } for ($path, $base) { $_ = $self->canonpath($_) } @@ -371,7 +905,7 @@ sub abs2rel { =item rel2abs (override) -Use VMS syntax when converting filespecs. +Return an absolute file specification from a relative one. =cut @@ -379,12 +913,58 @@ sub rel2abs { my $self = shift ; my ($path,$base ) = @_; return undef unless defined $path; - if ($path =~ m/\//) { - $path = ( -d $path || $path =~ m/\/\z/ # educated guessing about - ? vmspath($path) # whether it's a directory - : vmsify($path) ); + + my $efs = $self->_efs; + my $unix_rpt = $self->_unix_rpt; + + # We need to identify what the directory is in + # of the specification in order to process them + my $path_unix = 0; + $path_unix = 1 if ($path =~ m#/#); + $path_unix = 1 if ($path =~ /^\.\.?$/); + my $path_vms = 0; + $path_vms = 1 if ($path =~ m#[\[<\]]#); + $path_vms = 1 if ($path =~ /^--?$/); + + my $unix_mode = 0; + if ($path_vms == $path_unix) { + $unix_mode = $unix_rpt; + } else { + $unix_mode = $path_unix; + } + + my $base_unix = 0; + my $base_vms = 0; + + if (defined $base) { + $base_unix = 1 if ($base =~ m#/#); + $base_unix = 1 if ($base =~ /^\.\.?$/); + $base_vms = 1 if ($base =~ m#[\[<\]]#); + $base_vms = 1 if ($base =~ /^--?$/); + + # If we could not determine the path mode, see if we can find out + # from the base. + if ($path_vms == $path_unix) { + if ($base_vms != $base_unix) { + $unix_mode = $base_unix; + } + } } - $base = vmspath($base) if defined $base && $base =~ m/\//; + + if (!$efs) { + # Legacy behavior, convert to VMS syntax. + $unix_mode = 0; + if (defined $base) { + $base = vmspath($base) if $base =~ m/\//; + } + + if ($path =~ m/\//) { + $path = ( -d $path || $path =~ m/\/\z/ # educated guessing about + ? vmspath($path) # whether it's a directory + : vmsify($path) ); + } + } + # Clean up and split up $path if ( ! $self->file_name_is_absolute( $path ) ) { # Figure out the effective $base and clean it up. @@ -398,6 +978,20 @@ sub rel2abs { $base = $self->canonpath( $base ) ; } + if ($efs) { + # base may have changed, so need to look up format again. + if ($unix_mode) { + $base_vms = 1 if ($base =~ m#[\[<\]]#); + $base_vms = 1 if ($base =~ /^--?$/); + $base = unixpath($base) if $base_vms; + $base .= '/' unless ($base =~ m#/$#); + } else { + $base_unix = 1 if ($base =~ m#/#); + $base_unix = 1 if ($base =~ /^\.\.?$/); + $base = vmspath($base) if $base_unix; + } + } + # Split up paths my ( $path_directories, $path_file ) = ($self->splitpath( $path ))[1,2] ; @@ -408,12 +1002,23 @@ sub rel2abs { $path_directories = '' if $path_directories eq '[]' || $path_directories eq '<>'; my $sep = '' ; - $sep = '.' - if ( $base_directories =~ m{[^.\]>]\Z(?!\n)} && - $path_directories =~ m{^[^.\[<]}s - ) ; - $base_directories = "$base_directories$sep$path_directories"; - $base_directories =~ s{\.?[\]>][\[<]\.?}{.}; + + if ($efs) { + # Merge the paths assuming that the base is absolute. + $base_directories = $self->catdir('', + $base_directories, + $path_directories); + } else { + # Legacy behavior assumes VMS only paths + $sep = '.' + if ( $base_directories =~ m{[^.\]>]\Z(?!\n)} && + $path_directories =~ m{^[^.\[<]}s + ) ; + $base_directories = "$base_directories$sep$path_directories"; + $base_directories =~ s{\.?[\]>][\[<]\.?}{.}; + } + + $path_file = '' if ($path_file eq '.') && $unix_mode; $path = $self->catpath( $base_volume, $base_directories, $path_file ); } @@ -430,6 +1035,14 @@ sub rel2abs { # # Please consider these two methods deprecated. Do not patch them, # patch the ones in ExtUtils::MM_VMS instead. +# +# Update: MakeMaker 6.48 is still using these routines on VMS. +# so they need to be kept up to date with ExtUtils::MM_VMS. +# +# The traditional VMS mode using ODS-2 disks depends on these routines +# being here. These routines should not be called in when the +# C or C modes are enabled. + sub eliminate_macros { my($self,$path) = @_; return '' unless (defined $path) && ($path ne ''); @@ -439,13 +1052,16 @@ sub eliminate_macros { return join ' ', map { $self->eliminate_macros($_) } split /\s+/, $path; } - my($npath) = unixify($path); + my $npath = unixify($path); + # sometimes unixify will return a string with an off-by-one trailing null + $npath =~ s{\0$}{}; + my($complex) = 0; my($head,$macro,$tail); # perform m##g in scalar context so it acts as an iterator while ($npath =~ m#(.*?)\$\((\S+?)\)(.*)#gs) { - if ($self->{$2}) { + if (defined $self->{$2}) { ($head,$macro,$tail) = ($1,$2,$3); if (ref $self->{$macro}) { if (ref $self->{$macro} eq 'ARRAY') { @@ -467,10 +1083,23 @@ sub eliminate_macros { } # Deprecated. See the note above for eliminate_macros(). + +# Catchall routine to clean up problem MM[SK]/Make macros. Expands macros +# in any directory specification, in order to avoid juxtaposing two +# VMS-syntax directories when MM[SK] is run. Also expands expressions which +# are all macro, so that we can tell how long the expansion is, and avoid +# overrunning DCL's command buffer when MM[KS] is running. + +# fixpath() checks to see whether the result matches the name of a +# directory in the current default directory and returns a directory or +# file specification accordingly. C<$is_dir> can be set to true to +# force fixpath() to consider the path to be a directory or false to force +# it to be a file. + sub fixpath { my($self,$path,$force_path) = @_; return '' unless $path; - $self = bless {} unless ref $self; + $self = bless {}, $self unless ref $self; my($fixedpath,$prefix,$name); if ($path =~ /\s/) { diff -up perl-5.10.0/lib/File/Spec/Win32.pm.aa perl-5.10.0/lib/File/Spec/Win32.pm --- perl-5.10.0/lib/File/Spec/Win32.pm.aa 2007-12-18 11:47:07.000000000 +0100 +++ perl-5.10.0/lib/File/Spec/Win32.pm 2009-05-10 10:58:10.000000000 +0200 @@ -5,7 +5,8 @@ use strict; use vars qw(@ISA $VERSION); require File::Spec::Unix; -$VERSION = '3.2501'; +$VERSION = '3.30'; +$VERSION = eval $VERSION; @ISA = qw(File::Spec::Unix); @@ -41,7 +42,7 @@ sub devnull { return "nul"; } -sub rootdir () { '\\' } +sub rootdir { '\\' } =item tmpdir @@ -87,7 +88,7 @@ Default: 1 =cut -sub case_tolerant () { +sub case_tolerant { eval { require Win32API::File; } or return 1; my $drive = shift || "C:"; my $osFsType = "\0"x256; @@ -126,23 +127,37 @@ complete path ending with a filename =cut sub catfile { - my $self = shift; - my $file = $self->canonpath(pop @_); - return $file unless @_; - my $dir = $self->catdir(@_); - $dir .= "\\" unless substr($dir,-1) eq "\\"; - return $dir.$file; + shift; + + # Legacy / compatibility support + # + shift, return _canon_cat( "/", @_ ) + if $_[0] eq ""; + + # Compatibility with File::Spec <= 3.26: + # catfile('A:', 'foo') should return 'A:\foo'. + return _canon_cat( ($_[0].'\\'), @_[1..$#_] ) + if $_[0] =~ m{^$DRIVE_RX\z}o; + + return _canon_cat( @_ ); } sub catdir { - my $self = shift; - my @args = @_; - foreach (@args) { - tr[/][\\]; - # append a backslash to each argument unless it has one there - $_ .= "\\" unless m{\\$}; - } - return $self->canonpath(join('', @args)); + shift; + + # Legacy / compatibility support + # + return "" + unless @_; + shift, return _canon_cat( "/", @_ ) + if $_[0] eq ""; + + # Compatibility with File::Spec <= 3.26: + # catdir('A:', 'foo') should return 'A:\foo'. + return _canon_cat( ($_[0].'\\'), @_[1..$#_] ) + if $_[0] =~ m{^$DRIVE_RX\z}o; + + return _canon_cat( @_ ); } sub path { @@ -165,25 +180,10 @@ On Win32 makes =cut sub canonpath { - my ($self,$path) = @_; - - $path =~ s/^([a-z]:)/\u$1/s; - $path =~ s|/|\\|g; - $path =~ s|([^\\])\\+|$1\\|g; # xx\\\\xx -> xx\xx - $path =~ s|(\\\.)+\\|\\|g; # xx\.\.\xx -> xx\xx - $path =~ s|^(\.\\)+||s unless $path eq ".\\"; # .\xx -> xx - $path =~ s|\\\Z(?!\n)|| - unless $path =~ m{^([A-Z]:)?\\\Z(?!\n)}s; # xx\ -> xx - # xx1/xx2/xx3/../../xx -> xx1/xx - $path =~ s|\\\.\.\.\\|\\\.\.\\\.\.\\|g; # \...\ is 2 levels up - $path =~ s|^\.\.\.\\|\.\.\\\.\.\\|g; # ...\ is 2 levels up - return $path if $path =~ m|^\.\.|; # skip relative paths - return $path unless $path =~ /\.\./; # too few .'s to cleanup - return $path if $path =~ /\.\.\.\./; # too many .'s to cleanup - $path =~ s{^\\\.\.$}{\\}; # \.. -> \ - 1 while $path =~ s{^\\\.\.}{}; # \..\xx -> \xx - - return $self->_collapse($path); + # Legacy / compatibility support + # + return $_[1] if !defined($_[1]) or $_[1] eq ''; + return _canon_cat( $_[1] ); } =item splitpath @@ -375,4 +375,70 @@ implementation of these methods, not the =cut + +sub _canon_cat # @path -> path +{ + my ($first, @rest) = @_; + + my $volume = $first =~ s{ \A ([A-Za-z]:) ([\\/]?) }{}x # drive letter + ? ucfirst( $1 ).( $2 ? "\\" : "" ) + : $first =~ s{ \A (?:\\\\|//) ([^\\/]+) + (?: [\\/] ([^\\/]+) )? + [\\/]? }{}xs # UNC volume + ? "\\\\$1".( defined $2 ? "\\$2" : "" )."\\" + : $first =~ s{ \A [\\/] }{}x # root dir + ? "\\" + : ""; + my $path = join "\\", $first, @rest; + + $path =~ tr#\\/#\\\\#s; # xx/yy --> xx\yy & xx\\yy --> xx\yy + + # xx/././yy --> xx/yy + $path =~ s{(?: + (?:\A|\\) # at begin or after a slash + \. + (?:\\\.)* # and more + (?:\\|\z) # at end or followed by slash + )+ # performance boost -- I do not know why + }{\\}gx; + + # XXX I do not know whether more dots are supported by the OS supporting + # this ... annotation (NetWare or symbian but not MSWin32). + # Then .... could easily become ../../.. etc: + # Replace \.\.\. by (\.\.\.+) and substitute with + # { $1 . ".." . "\\.." x (length($2)-2) }gex + # ... --> ../.. + $path =~ s{ (\A|\\) # at begin or after a slash + \.\.\. + (?=\\|\z) # at end or followed by slash + }{$1..\\..}gx; + # xx\yy\..\zz --> xx\zz + while ( $path =~ s{(?: + (?:\A|\\) # at begin or after a slash + [^\\]+ # rip this 'yy' off + \\\.\. + (? xx NOTE: this is *not* root + $path =~ s#\\\z##; # xx\ --> xx + + if ( $volume =~ m#\\\z# ) + { # \.. --> \ + $path =~ s{ \A # at begin + \.\. + (?:\\\.\.)* # and more + (?:\\|\z) # at end or followed by slash + }{}x; + + return $1 # \\HOST\SHARE\ --> \\HOST\SHARE + if $path eq "" + and $volume =~ m#\A(\\\\.*)\\\z#s; + } + return $path ne "" || $volume ? $volume.$path : "."; +} + 1;