lib/File/Spec/Mac.pm portable operations on Mac file names
lib/File/Spec/OS2.pm portable operations on OS2 file names
lib/File/Spec.pm portable operations on file names
+lib/File/Spec/t/crossplatform.t See if File::Spec works crossplatform
lib/File/Spec/t/Functions.t See if File::Spec::Functions works
lib/File/Spec/t/rel2abs2rel.t See if File::Spec->rel2abs/abs2rel works
lib/File/Spec/t/Spec.t See if File::Spec works
use strict;
use vars qw(@ISA $VERSION);
-$VERSION = '0.86';
+$VERSION = '0.85_03';
my %module = (MacOS => 'Mac',
MSWin32 => 'Win32',
=item path
-Takes no argument, returns the environment variable PATH as an array.
+Takes no argument, returns the environment variable PATH (or the local
+platform's equivalent) as a list.
@PATH = File::Spec->path();
L</rel2abs()>. This means that it is taken to be relative to
L<cwd()|Cwd>.
-On systems with the concept of a volume, this assumes that both paths
-are on the $destination volume, and ignores the $base volume. If this
-assumption may be wrong (like in VMS), trying to "unify" the paths
-abs2rel() results in nonsense.
+On systems with the concept of volume, if $path and $base appear to be
+on two different volumes, we will not attempt to resolve the two
+paths, and we will instead simply return $path. Note that previous
+versions of this module ignored the volume of $base, which resulted in
+garbage results part of the time.
On systems that have a grammar that indicates filenames, this ignores the
$base filename as well. Otherwise all path components are assumed to be
then it is converted to absolute form using L</rel2abs()>. This means that it
is taken to be relative to L<cwd()|Cwd>.
-On systems with the concept of a volume, this assumes that both paths
-are on the $base volume, and ignores the $path volume.
+On systems with the concept of volume, if $path and $base appear to be
+on two different volumes, we will not attempt to resolve the two
+paths, and we will instead simply return $path. Note that previous
+versions of this module ignored the volume of $base, which resulted in
+garbage results part of the time.
On systems that have a grammar that indicates filenames, this ignores the
$base filename as well. Otherwise all path components are assumed to be
return $file ;
}
+ # We look for a volume in $volume, then in $directory, but not both
+
+ my ($dir_volume, $dir_dirs) = $self->splitpath($directory, 1);
+
+ $volume = $dir_volume unless length $volume;
my $path = $volume; # may be ''
$path .= ':' unless (substr($path, -1) eq ':'); # ensure trailing ':'
if ($directory) {
+ $directory = $dir_dirs if $volume;
$directory =~ s/^://; # remove leading ':' if any
$path .= $directory;
$path .= ':' unless (substr($path, -1) eq ':'); # ensure trailing ':'
If $base is relative, then it is converted to absolute form using C<rel2abs()>.
This means that it is taken to be relative to the current working directory.
-Since Mac OS has the concept of volumes, this assumes that both paths
-are on the $destination volume, and ignores the $base volume (!).
+If $path and $base appear to be on two different volumes, we will not
+attempt to resolve the two paths, and we will instead simply return
+$path. Note that previous versions of this module ignored the volume
+of $base, which resulted in garbage results part of the time.
If $base doesn't have a trailing colon, the last element of $base is
-assumed to be a filename. This filename is ignored (!). Otherwise all path
+assumed to be a filename. This filename is ignored. Otherwise all path
components are assumed to be directories.
If $path is relative, it is converted to absolute form using C<rel2abs()>.
$base = _resolve_updirs( $base );
}
- # Split up paths
- my ( $path_dirs, $path_file ) = ($self->splitpath( $path ))[1,2] ;
+ # Split up paths - ignore $base's file
+ my ( $path_vol, $path_dirs, $path_file ) = $self->splitpath( $path );
+ my ( $base_vol, $base_dirs ) = $self->splitpath( $base );
- # ignore $base's volume and file
- my $base_dirs = ($self->splitpath( $base ))[1] ;
+ return $path unless lc( $path_vol ) eq lc( $base_vol );
# Now, remove all leading components that are the same
my @pathchunks = $self->splitdir( $path_dirs );
current working directory.
If $base doesn't have a trailing colon, the last element of $base is
-assumed to be a filename. This filename is ignored (!). Otherwise all path
+assumed to be a filename. This filename is ignored. Otherwise all path
components are assumed to be directories.
If $path is already absolute, it is returned and $base is ignored.
my ( $path_dirs, $path_file ) = ($self->splitpath($path))[1,2] ;
# ignore $base's file part
- my ( $base_vol, $base_dirs, undef ) = $self->splitpath($base) ;
+ my ( $base_vol, $base_dirs ) = $self->splitpath($base) ;
# Glom them together
$path_dirs = ':' if ($path_dirs eq '');
'/' );
}
+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));
+}
+
sub canonpath {
my ($self,$path) = @_;
$path =~ s/^([a-z]:)/\l$1/s;
$path =~ s|^(\./)+(?=[^/])||s; # ./xx -> xx
$path =~ s|/\Z(?!\n)||
unless $path =~ m#^([a-z]:)?/\Z(?!\n)#si;# xx/ -> xx
+ $path =~ s{^/\.\.$}{/}; # /.. -> /
+ 1 while $path =~ s{^/\.\.}{}; # /../xx -> /xx
return $path;
}
}
# Split up paths
- my ( undef, $path_directories, $path_file ) =
- $self->splitpath( $path, 1 ) ;
-
- my $base_directories = ($self->splitpath( $base, 1 ))[1] ;
+ my ( $path_volume, $path_directories, $path_file ) = $self->splitpath( $path, 1 ) ;
+ my ( $base_volume, $base_directories ) = $self->splitpath( $base, 1 ) ;
+ return $path unless $path_volume eq $base_volume;
# Now, remove all leading components that are the same
my @pathchunks = $self->splitdir( $path_directories );
sub catdir {
my $self = shift;
- my @args = @_;
- foreach (@args) {
- # append a slash to each argument unless it has one there
- $_ .= "/" if $_ eq '' || substr($_,-1) ne "/";
- }
- return $self->canonpath(join('', @args));
+
+ $self->canonpath(join('/', @_, '')); # '' because need a trailing '/'
}
=item catfile
=cut
-sub curdir {
- return ".";
-}
+sub curdir () { '.' }
=item devnull
=cut
-sub devnull {
- return "/dev/null";
-}
+sub devnull () { '/dev/null' }
=item rootdir
=cut
-sub rootdir {
- return "/";
-}
+sub rootdir () { '/' }
=item tmpdir
=cut
-sub updir {
- return "..";
-}
+sub updir () { '..' }
=item no_upwards
=cut
-sub case_tolerant {
- return 0;
-}
+sub case_tolerant () { 0 }
=item file_name_is_absolute
L</rel2abs()>. This means that it is taken to be relative to
L<cwd()|Cwd>.
-On systems with the concept of a volume, this assumes that both paths
-are on the $destination volume, and ignores the $base volume. If this
-assumption may be wrong (like in VMS), trying to "unify" the paths with
-abs2rel() results in nonsense.
-
On systems that have a grammar that indicates filenames, this ignores the
-$base filename as well. Otherwise all path components are assumed to be
+$base filename. Otherwise all path components are assumed to be
directories.
If $path is relative, it is converted to absolute form using L</rel2abs()>.
L</rel2abs()>. This means that it is taken to be relative to
L<cwd()|Cwd>.
-On systems with the concept of a volume, this assumes that both paths
-are on the $base volume, and ignores the $path volume.
-
-On systems that have a grammar that indicates filenames, this ignores the
-$base filename as well. Otherwise all path components are assumed to be
+On systems that have a grammar that indicates filenames, this ignores
+the $base filename. Otherwise all path components are assumed to be
directories.
If $path is absolute, it is cleaned up and returned using L</canonpath()>.
sub catpath {
my($self,$dev,$dir,$file) = @_;
+
+ # 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;
+
if ($dev =~ m|^/+([^/]+)|) { $dev = "$1:"; }
else { $dev .= ':' unless $dev eq '' or $dev =~ /:\Z(?!\n)/; }
if (length($dev) or length($dir)) {
sub abs2rel {
my $self = shift;
-
return vmspath(File::Spec::Unix::abs2rel( $self, @_ ))
- if ( join( '', @_ ) =~ m{/} ) ;
+ if grep m{/}, @_;
my($path,$base) = @_;
+ $base = $self->_cwd() unless defined $base and length $base;
- # Note: we use '/' to glue things together here, then let canonpath()
- # clean them up at the end.
-
- # Clean up $path
- if ( ! $self->file_name_is_absolute( $path ) ) {
- $path = $self->rel2abs( $path ) ;
- }
- else {
- $path = $self->canonpath( $path ) ;
- }
-
- # Figure out the effective $base and clean it up.
- if ( !defined( $base ) || $base eq '' ) {
- $base = $self->canonpath( $self->_cwd ) ;
- }
- elsif ( ! $self->file_name_is_absolute( $base ) ) {
- $base = $self->rel2abs( $base ) ;
- }
- else {
- $base = $self->canonpath( $base ) ;
- }
+ for ($path, $base) { $_ = $self->canonpath($_) }
# Are we even starting $path on the same (node::)device as $base? Note that
# logical paths or nodename differences may be on the "same device"
# if there is a case blind device (or node) difference of any sort
# and we do not even try to call $parse() or consult %ENV for $trnlnm()
# (this module needs to run on non VMS platforms after all).
- my $path_device = ($self->splitpath( $path, 1 ))[0];
- my $base_device = ($self->splitpath( $base, 1 ))[0];
- if ( lc( $path_device ) ne lc( $base_device ) ) {
- return ( $path ) ;
- }
+
+ my ($path_volume, $path_directories, $path_file) = $self->splitpath($path);
+ my ($base_volume, $base_directories, $base_file) = $self->splitpath($base);
+ return $path unless lc($path_volume) eq lc($base_volume);
- # Split up paths
- my ( $path_directories, $path_file ) =
- ($self->splitpath( $path, 1 ))[1,2] ;
-
- $path_directories = $1
- if $path_directories =~ /^\[(.*)\]\Z(?!\n)/s ;
-
- my $base_directories = ($self->splitpath( $base, 1 ))[1] ;
-
- $base_directories = $1
- if $base_directories =~ /^\[(.*)\]\Z(?!\n)/s ;
+ for ($path, $base) { $_ = $self->rel2abs($_) }
# Now, remove all leading components that are the same
my @pathchunks = $self->splitdir( $path_directories );
# @basechunks now contains the directories to climb out of,
# @pathchunks now has the directories to descend in to.
- $path_directories = '-.' x @basechunks . join( '.', @pathchunks ) ;
- $path_directories =~ s{\.\Z(?!\n)}{} ;
+ $path_directories = join '.', ('-' x @basechunks, @pathchunks) ;
return $self->canonpath( $self->catpath( '', $path_directories, $path_file ) ) ;
}
See L<File::Spec> and L<File::Spec::Unix>. This package overrides the
implementation of these methods, not the semantics.
+An explanation of VMS file specs can be found at
+L<"http://h71000.www7.hp.com/doc/731FINAL/4506/4506pro_014.html#apps_locating_naming_files">.
+
=cut
1;
return $dir.$file;
}
+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));
+}
+
sub path {
my $path = $ENV{'PATH'} || $ENV{'Path'} || $ENV{'path'};
my @path = split(';',$path);
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
- return $path if $orig_path =~ m|^\Q/../\E|
- and $orig_path =~ m|\/$|; # don't do /../dirs/ when called
- # from rel2abs() for ../dirs/
+ $path =~ s{^\\\.\.$}{\\}; # \.. -> \
1 while $path =~ s{^\\\.\.}{}; # \..\xx -> \xx
my ($vol,$dirs,$file) = $self->splitpath($path);
my($self,$path,$base) = @_;
$base = $self->_cwd() unless defined $base and length $base;
- for ($path, $base) {
- $_ = $self->canonpath($self->rel2abs($_));
- }
- my ($path_volume, $path_directories) = $self->splitpath($path, 1) ;
- my ($base_volume, $base_directories) = $self->splitpath($base, 1);
+ for ($path, $base) { $_ = $self->canonpath($_) }
- if ($path_volume and not $base_volume) {
- ($base_volume) = $self->splitpath($self->_cwd);
- }
+ my ($path_volume) = $self->splitpath($path, 1);
+ my ($base_volume) = $self->splitpath($base, 1);
# Can't relativize across volumes
return $path unless $path_volume eq $base_volume;
+ for ($path, $base) { $_ = $self->rel2abs($_) }
+
+ my $path_directories = ($self->splitpath($path, 1))[1];
+ my $base_directories = ($self->splitpath($base, 1))[1];
+
# Now, remove all leading components that are the same
my @pathchunks = $self->splitdir( $path_directories );
my @basechunks = $self->splitdir( $base_directories );
[ "Win32->catdir()", '' ],
[ "Win32->catdir('')", '\\' ],
[ "Win32->catdir('/')", '\\' ],
+[ "Win32->catdir('/', '../')", '\\' ],
+[ "Win32->catdir('/', '..\\')", '\\' ],
+[ "Win32->catdir('\\', '../')", '\\' ],
+[ "Win32->catdir('\\', '..\\')", '\\' ],
[ "Win32->catdir('//d1','d2')", '\\\\d1\\d2' ],
[ "Win32->catdir('\\d1\\','d2')", '\\d1\\d2' ],
[ "Win32->catdir('\\d1','d2')", '\\d1\\d2' ],
#[ "Win32->catdir('A:/d1','B:/d2','d3','')", 'A:\\d1\\d2\\d3' ],
[ "Win32->catdir('A:/d1','B:/d2','d3','')", 'A:\\d1\\B:\\d2\\d3' ],
[ "Win32->catdir('A:/')", 'A:\\' ],
+[ "Win32->catdir('\\', 'foo')", '\\foo' ],
[ "Win32->catfile('a','b','c')", 'a\\b\\c' ],
[ "Win32->catfile('a','b','.\\c')", 'a\\b\\c' ],
[ "Win32->canonpath('')", '' ],
[ "Win32->canonpath('a:')", 'A:' ],
[ "Win32->canonpath('A:f')", 'A:f' ],
+[ "Win32->canonpath('A:/')", 'A:\\' ],
[ "Win32->canonpath('//a\\b//c')", '\\\\a\\b\\c' ],
[ "Win32->canonpath('/a/..../c')", '\\a\\....\\c' ],
[ "Win32->canonpath('//a/b\\c')", '\\\\a\\b\\c' ],
[ "Win32->canonpath('/a/b/c/../../d')", '\\a\\d' ],
[ "Win32->canonpath('/a/b/c/.../d')", '\\a\\d' ],
[ "Win32->canonpath('\\../temp\\')", '\\temp' ],
+[ "Win32->canonpath('\\../')", '\\' ],
+[ "Win32->canonpath('\\..\\')", '\\' ],
+[ "Win32->canonpath('/../')", '\\' ],
+[ "Win32->canonpath('/..\\')", '\\' ],
[ "Win32->can('_cwd')", qr/CODE/ ],
# FakeWin32 subclass (see below) just sets CWD to C:\one\two
[ "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('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' ],
[ "VMS->catpath('node\"access_spec\"::volume:','[d1.d2.d3]','')", 'node"access_spec"::volume:[d1.d2.d3]' ],
[ "VMS->abs2rel('node::volume:[t1.t2.t4]','[t1.t2.t3]')", 'node::volume:[t1.t2.t4]' ],
[ "VMS->abs2rel('[t1.t2.t3]','[t1.t2.t3]')", '' ],
[ "VMS->abs2rel('[t1.t2.t3]file','[t1.t2.t3]')", 'file' ],
+[ "VMS->abs2rel('[t1.t2.t3]file','[t1.t2]')", '[.t3]file' ],
+[ "VMS->abs2rel('v:[t1.t2.t3]file','v:[t1.t2]')", '[.t3]file' ],
[ "VMS->abs2rel('[t1.t2.t4]','[t1.t2.t3]')", '[-.t4]' ],
[ "VMS->abs2rel('[t1.t2]file','[t1.t2.t3]')", '[-]file' ],
-[ "VMS->abs2rel('[t1.t2.t3.t4]','[t1.t2.t3]')", '[t4]' ],
+[ "VMS->abs2rel('[t1.t2.t3.t4]','[t1.t2.t3]')", '[.t4]' ],
[ "VMS->abs2rel('[t4.t5.t6]','[t1.t2.t3]')", '[---.t4.t5.t6]' ],
[ "VMS->abs2rel('[000000]','[t1.t2.t3]')", '[---]' ],
[ "VMS->abs2rel('a:[t1.t2.t4]','a:[t1.t2.t3]')", '[-.t4]' ],
[ "OS2->catfile('c')", 'c' ],
[ "OS2->catfile('./c')", 'c' ],
+[ "OS2->catdir('/', '../')", '/' ],
+[ "OS2->catdir('/', '..\\')", '/' ],
+[ "OS2->catdir('\\', '../')", '/' ],
+[ "OS2->catdir('\\', '..\\')", '/' ],
+
[ "Mac->case_tolerant()", '1' ],
[ "Mac->catpath('','','')", '' ],
[ "Mac->catpath('hd:','d1','file')", 'hd:d1:file' ],
[ "Mac->catpath('hd:',':d1:',':file')", 'hd:d1:file' ],
+[ "Mac->catpath('hd:','hd:d1','')", 'hd:d1:' ],
[ "Mac->catpath('','d1','')", ':d1:' ],
[ "Mac->catpath('',':d1','')", ':d1:' ],
[ "Mac->abs2rel('hd:d3:','hd:d1:d2:')", ':::d3:' ], # same as above
[ "Mac->abs2rel('hd:d1:d2:d3:','hd:d1:d2:')", ':d3:' ],
[ "Mac->abs2rel('hd:d1:d2:d3::','hd:d1:d2:')", ':d3::' ],
-[ "Mac->abs2rel('hd1:d3:d4:d5:','hd2:d1:d2:')", ':::d3:d4:d5:' ], # ignore base's volume
+[ "Mac->abs2rel('hd1:d3:d4:d5:','hd2:d1:d2:')", 'hd1:d3:d4:d5:'], # volume mismatch
[ "Mac->abs2rel('hd:','hd:d1:d2:')", ':::' ],
[ "Mac->rel2abs(':d3:','hd:d1:d2:')", 'hd:d1:d2:d3:' ],
--- /dev/null
+#!/usr/bin/perl -w
+
+use strict;
+use Test::More;
+use File::Spec;
+local $|=1;
+
+my @platforms = qw(Cygwin Epoc Mac OS2 Unix VMS Win32);
+my $tests_per_platform = 7;
+
+plan tests => 1 + @platforms * $tests_per_platform;
+
+my %volumes = (
+ Mac => 'Macintosh HD',
+ OS2 => 'A:',
+ Win32 => 'A:',
+ VMS => 'v',
+ );
+my %other_vols = (
+ Mac => 'Mounted Volume',
+ OS2 => 'B:',
+ Win32 => 'B:',
+ VMS => 'w',
+ );
+
+ok 1, "Loaded";
+
+foreach my $platform (@platforms) {
+ my $module = "File::Spec::$platform";
+
+ SKIP:
+ {
+ eval "require $module; 1";
+
+ skip "Can't load $module", $tests_per_platform
+ if $@;
+
+ my $v = $volumes{$platform} || '';
+ my $other_v = $other_vols{$platform} || '';
+
+ # Fake out the rootdir on MacOS
+ no strict 'refs';
+ my $save_w = $^W;
+ $^W = 0;
+ local *{"File::Spec::Mac::rootdir"} = sub { "Macintosh HD:" };
+ $^W = $save_w;
+ use strict 'refs';
+
+ my ($file, $base, $result);
+
+ $base = $module->catpath($v, $module->catdir('', 'foo'), '');
+ $base = $module->catdir($module->rootdir, 'foo');
+
+ is $module->file_name_is_absolute($base), 1, "$base is absolute on $platform";
+
+
+ # 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');
+ 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', '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) ? $file : $module->catfile('bar', 'file');
+ 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) ? $file : $module->catfile('bar', 'file');
+ 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)";
+ }
+}
+
+sub volumes_differ {
+ my ($module, $one, $two) = @_;
+ my ($one_v) = $module->splitpath( $module->rel2abs($one) );
+ my ($two_v) = $module->splitpath( $module->rel2abs($two) );
+ return $one_v ne $two_v;
+}
projects / p5sagit/p5-mst-13.2.git / commitdiff