16fb12b70Safresh1package File::Spec::Unix; 26fb12b70Safresh1 36fb12b70Safresh1use strict; 49f11ffb7Safresh1use Cwd (); 56fb12b70Safresh1 6*3d61058aSafresh1our $VERSION = '3.91'; 7b8851fccSafresh1$VERSION =~ tr/_//d; 86fb12b70Safresh1 96fb12b70Safresh1=head1 NAME 106fb12b70Safresh1 116fb12b70Safresh1File::Spec::Unix - File::Spec for Unix, base for other File::Spec modules 126fb12b70Safresh1 136fb12b70Safresh1=head1 SYNOPSIS 146fb12b70Safresh1 156fb12b70Safresh1 require File::Spec::Unix; # Done automatically by File::Spec 166fb12b70Safresh1 176fb12b70Safresh1=head1 DESCRIPTION 186fb12b70Safresh1 196fb12b70Safresh1Methods for manipulating file specifications. Other File::Spec 206fb12b70Safresh1modules, such as File::Spec::Mac, inherit from File::Spec::Unix and 216fb12b70Safresh1override specific methods. 226fb12b70Safresh1 236fb12b70Safresh1=head1 METHODS 246fb12b70Safresh1 256fb12b70Safresh1=over 2 266fb12b70Safresh1 276fb12b70Safresh1=item canonpath() 286fb12b70Safresh1 296fb12b70Safresh1No physical check on the filesystem, but a logical cleanup of a 306fb12b70Safresh1path. On UNIX eliminates successive slashes and successive "/.". 316fb12b70Safresh1 326fb12b70Safresh1 $cpath = File::Spec->canonpath( $path ) ; 336fb12b70Safresh1 346fb12b70Safresh1Note that this does *not* collapse F<x/../y> sections into F<y>. This 356fb12b70Safresh1is by design. If F</foo> on your system is a symlink to F</bar/baz>, 366fb12b70Safresh1then F</foo/../quux> is actually F</bar/quux>, not F</quux> as a naive 376fb12b70Safresh1F<../>-removal would give you. If you want to do this kind of 386fb12b70Safresh1processing, you probably want C<Cwd>'s C<realpath()> function to 396fb12b70Safresh1actually traverse the filesystem cleaning up paths like this. 406fb12b70Safresh1 416fb12b70Safresh1=cut 426fb12b70Safresh1 436fb12b70Safresh1sub _pp_canonpath { 446fb12b70Safresh1 my ($self,$path) = @_; 456fb12b70Safresh1 return unless defined $path; 466fb12b70Safresh1 476fb12b70Safresh1 # Handle POSIX-style node names beginning with double slash (qnx, nto) 486fb12b70Safresh1 # (POSIX says: "a pathname that begins with two successive slashes 496fb12b70Safresh1 # may be interpreted in an implementation-defined manner, although 506fb12b70Safresh1 # more than two leading slashes shall be treated as a single slash.") 516fb12b70Safresh1 my $node = ''; 526fb12b70Safresh1 my $double_slashes_special = $^O eq 'qnx' || $^O eq 'nto'; 536fb12b70Safresh1 546fb12b70Safresh1 556fb12b70Safresh1 if ( $double_slashes_special 566fb12b70Safresh1 && ( $path =~ s{^(//[^/]+)/?\z}{}s || $path =~ s{^(//[^/]+)/}{/}s ) ) { 576fb12b70Safresh1 $node = $1; 586fb12b70Safresh1 } 596fb12b70Safresh1 # This used to be 606fb12b70Safresh1 # $path =~ s|/+|/|g unless ($^O eq 'cygwin'); 616fb12b70Safresh1 # but that made tests 29, 30, 35, 46, and 213 (as of #13272) to fail 626fb12b70Safresh1 # (Mainly because trailing "" directories didn't get stripped). 636fb12b70Safresh1 # Why would cygwin avoid collapsing multiple slashes into one? --jhi 646fb12b70Safresh1 $path =~ s|/{2,}|/|g; # xx////xx -> xx/xx 656fb12b70Safresh1 $path =~ s{(?:/\.)+(?:/|\z)}{/}g; # xx/././xx -> xx/xx 666fb12b70Safresh1 $path =~ s|^(?:\./)+||s unless $path eq "./"; # ./xx -> xx 676fb12b70Safresh1 $path =~ s|^/(?:\.\./)+|/|; # /../../xx -> xx 686fb12b70Safresh1 $path =~ s|^/\.\.$|/|; # /.. -> / 696fb12b70Safresh1 $path =~ s|/\z|| unless $path eq "/"; # xx/ -> xx 706fb12b70Safresh1 return "$node$path"; 716fb12b70Safresh1} 726fb12b70Safresh1*canonpath = \&_pp_canonpath unless defined &canonpath; 736fb12b70Safresh1 746fb12b70Safresh1=item catdir() 756fb12b70Safresh1 766fb12b70Safresh1Concatenate two or more directory names to form a complete path ending 776fb12b70Safresh1with a directory. But remove the trailing slash from the resulting 786fb12b70Safresh1string, because it doesn't look good, isn't necessary and confuses 796fb12b70Safresh1OS2. Of course, if this is the root directory, don't cut off the 806fb12b70Safresh1trailing slash :-) 816fb12b70Safresh1 826fb12b70Safresh1=cut 836fb12b70Safresh1 846fb12b70Safresh1sub _pp_catdir { 856fb12b70Safresh1 my $self = shift; 866fb12b70Safresh1 876fb12b70Safresh1 $self->canonpath(join('/', @_, '')); # '' because need a trailing '/' 886fb12b70Safresh1} 896fb12b70Safresh1*catdir = \&_pp_catdir unless defined &catdir; 906fb12b70Safresh1 916fb12b70Safresh1=item catfile 926fb12b70Safresh1 936fb12b70Safresh1Concatenate one or more directory names and a filename to form a 946fb12b70Safresh1complete path ending with a filename 956fb12b70Safresh1 966fb12b70Safresh1=cut 976fb12b70Safresh1 986fb12b70Safresh1sub _pp_catfile { 996fb12b70Safresh1 my $self = shift; 1006fb12b70Safresh1 my $file = $self->canonpath(pop @_); 1016fb12b70Safresh1 return $file unless @_; 1026fb12b70Safresh1 my $dir = $self->catdir(@_); 1036fb12b70Safresh1 $dir .= "/" unless substr($dir,-1) eq "/"; 1046fb12b70Safresh1 return $dir.$file; 1056fb12b70Safresh1} 1066fb12b70Safresh1*catfile = \&_pp_catfile unless defined &catfile; 1076fb12b70Safresh1 1086fb12b70Safresh1=item curdir 1096fb12b70Safresh1 1106fb12b70Safresh1Returns a string representation of the current directory. "." on UNIX. 1116fb12b70Safresh1 1126fb12b70Safresh1=cut 1136fb12b70Safresh1 1146fb12b70Safresh1sub curdir { '.' } 1156fb12b70Safresh1use constant _fn_curdir => "."; 1166fb12b70Safresh1 1176fb12b70Safresh1=item devnull 1186fb12b70Safresh1 1196fb12b70Safresh1Returns a string representation of the null device. "/dev/null" on UNIX. 1206fb12b70Safresh1 1216fb12b70Safresh1=cut 1226fb12b70Safresh1 1236fb12b70Safresh1sub devnull { '/dev/null' } 1246fb12b70Safresh1use constant _fn_devnull => "/dev/null"; 1256fb12b70Safresh1 1266fb12b70Safresh1=item rootdir 1276fb12b70Safresh1 1286fb12b70Safresh1Returns a string representation of the root directory. "/" on UNIX. 1296fb12b70Safresh1 1306fb12b70Safresh1=cut 1316fb12b70Safresh1 1326fb12b70Safresh1sub rootdir { '/' } 1336fb12b70Safresh1use constant _fn_rootdir => "/"; 1346fb12b70Safresh1 1356fb12b70Safresh1=item tmpdir 1366fb12b70Safresh1 1376fb12b70Safresh1Returns a string representation of the first writable directory from 1386fb12b70Safresh1the following list or the current directory if none from the list are 1396fb12b70Safresh1writable: 1406fb12b70Safresh1 1416fb12b70Safresh1 $ENV{TMPDIR} 1426fb12b70Safresh1 /tmp 1436fb12b70Safresh1 1446fb12b70Safresh1If running under taint mode, and if $ENV{TMPDIR} 1456fb12b70Safresh1is tainted, it is not used. 1466fb12b70Safresh1 1476fb12b70Safresh1=cut 1486fb12b70Safresh1 1496fb12b70Safresh1my ($tmpdir, %tmpenv); 1506fb12b70Safresh1# Cache and return the calculated tmpdir, recording which env vars 1516fb12b70Safresh1# determined it. 1526fb12b70Safresh1sub _cache_tmpdir { 1536fb12b70Safresh1 @tmpenv{@_[2..$#_]} = @ENV{@_[2..$#_]}; 1546fb12b70Safresh1 return $tmpdir = $_[1]; 1556fb12b70Safresh1} 1566fb12b70Safresh1# Retrieve the cached tmpdir, checking first whether relevant env vars have 1576fb12b70Safresh1# changed and invalidated the cache. 1586fb12b70Safresh1sub _cached_tmpdir { 1596fb12b70Safresh1 shift; 1606fb12b70Safresh1 local $^W; 1616fb12b70Safresh1 return if grep $ENV{$_} ne $tmpenv{$_}, @_; 1626fb12b70Safresh1 return $tmpdir; 1636fb12b70Safresh1} 1646fb12b70Safresh1sub _tmpdir { 1656fb12b70Safresh1 my $self = shift; 1666fb12b70Safresh1 my @dirlist = @_; 1676fb12b70Safresh1 my $taint = do { no strict 'refs'; ${"\cTAINT"} }; 1686fb12b70Safresh1 if ($taint) { # Check for taint mode on perl >= 5.8.0 1696fb12b70Safresh1 require Scalar::Util; 1706fb12b70Safresh1 @dirlist = grep { ! Scalar::Util::tainted($_) } @dirlist; 1716fb12b70Safresh1 } 1726fb12b70Safresh1 elsif ($] < 5.007) { # No ${^TAINT} before 5.8 1739f11ffb7Safresh1 @dirlist = grep { !defined($_) || eval { eval('1'.substr $_,0,0) } } 1749f11ffb7Safresh1 @dirlist; 1756fb12b70Safresh1 } 1766fb12b70Safresh1 1776fb12b70Safresh1 foreach (@dirlist) { 1786fb12b70Safresh1 next unless defined && -d && -w _; 1796fb12b70Safresh1 $tmpdir = $_; 1806fb12b70Safresh1 last; 1816fb12b70Safresh1 } 1826fb12b70Safresh1 $tmpdir = $self->curdir unless defined $tmpdir; 1836fb12b70Safresh1 $tmpdir = defined $tmpdir && $self->canonpath($tmpdir); 1846fb12b70Safresh1 if ( !$self->file_name_is_absolute($tmpdir) ) { 1856fb12b70Safresh1 # See [perl #120593] for the full details 1866fb12b70Safresh1 # If possible, return a full path, rather than '.' or 'lib', but 1876fb12b70Safresh1 # jump through some hoops to avoid returning a tainted value. 1886fb12b70Safresh1 ($tmpdir) = grep { 1896fb12b70Safresh1 $taint ? ! Scalar::Util::tainted($_) : 1906fb12b70Safresh1 $] < 5.007 ? eval { eval('1'.substr $_,0,0) } : 1 1916fb12b70Safresh1 } $self->rel2abs($tmpdir), $tmpdir; 1926fb12b70Safresh1 } 1936fb12b70Safresh1 return $tmpdir; 1946fb12b70Safresh1} 1956fb12b70Safresh1 1966fb12b70Safresh1sub tmpdir { 1976fb12b70Safresh1 my $cached = $_[0]->_cached_tmpdir('TMPDIR'); 1986fb12b70Safresh1 return $cached if defined $cached; 1996fb12b70Safresh1 $_[0]->_cache_tmpdir($_[0]->_tmpdir( $ENV{TMPDIR}, "/tmp" ), 'TMPDIR'); 2006fb12b70Safresh1} 2016fb12b70Safresh1 2026fb12b70Safresh1=item updir 2036fb12b70Safresh1 2046fb12b70Safresh1Returns a string representation of the parent directory. ".." on UNIX. 2056fb12b70Safresh1 2066fb12b70Safresh1=cut 2076fb12b70Safresh1 2086fb12b70Safresh1sub updir { '..' } 2096fb12b70Safresh1use constant _fn_updir => ".."; 2106fb12b70Safresh1 2116fb12b70Safresh1=item no_upwards 2126fb12b70Safresh1 2136fb12b70Safresh1Given a list of file names, strip out those that refer to a parent 2146fb12b70Safresh1directory. (Does not strip symlinks, only '.', '..', and equivalents.) 2156fb12b70Safresh1 2166fb12b70Safresh1=cut 2176fb12b70Safresh1 2186fb12b70Safresh1sub no_upwards { 2196fb12b70Safresh1 my $self = shift; 2206fb12b70Safresh1 return grep(!/^\.{1,2}\z/s, @_); 2216fb12b70Safresh1} 2226fb12b70Safresh1 2236fb12b70Safresh1=item case_tolerant 2246fb12b70Safresh1 2256fb12b70Safresh1Returns a true or false value indicating, respectively, that alphabetic 2266fb12b70Safresh1is not or is significant when comparing file specifications. 2276fb12b70Safresh1 2286fb12b70Safresh1=cut 2296fb12b70Safresh1 2306fb12b70Safresh1sub case_tolerant { 0 } 2316fb12b70Safresh1use constant _fn_case_tolerant => 0; 2326fb12b70Safresh1 2336fb12b70Safresh1=item file_name_is_absolute 2346fb12b70Safresh1 2356fb12b70Safresh1Takes as argument a path and returns true if it is an absolute path. 2366fb12b70Safresh1 2376fb12b70Safresh1This does not consult the local filesystem on Unix, Win32, OS/2 or Mac 2386fb12b70Safresh1OS (Classic). It does consult the working environment for VMS (see 2396fb12b70Safresh1L<File::Spec::VMS/file_name_is_absolute>). 2406fb12b70Safresh1 2416fb12b70Safresh1=cut 2426fb12b70Safresh1 2436fb12b70Safresh1sub file_name_is_absolute { 2446fb12b70Safresh1 my ($self,$file) = @_; 2456fb12b70Safresh1 return scalar($file =~ m:^/:s); 2466fb12b70Safresh1} 2476fb12b70Safresh1 2486fb12b70Safresh1=item path 2496fb12b70Safresh1 2506fb12b70Safresh1Takes no argument, returns the environment variable PATH as an array. 2516fb12b70Safresh1 2526fb12b70Safresh1=cut 2536fb12b70Safresh1 2546fb12b70Safresh1sub path { 2556fb12b70Safresh1 return () unless exists $ENV{PATH}; 2566fb12b70Safresh1 my @path = split(':', $ENV{PATH}); 2576fb12b70Safresh1 foreach (@path) { $_ = '.' if $_ eq '' } 2586fb12b70Safresh1 return @path; 2596fb12b70Safresh1} 2606fb12b70Safresh1 2616fb12b70Safresh1=item join 2626fb12b70Safresh1 2636fb12b70Safresh1join is the same as catfile. 2646fb12b70Safresh1 2656fb12b70Safresh1=cut 2666fb12b70Safresh1 2676fb12b70Safresh1sub join { 2686fb12b70Safresh1 my $self = shift; 2696fb12b70Safresh1 return $self->catfile(@_); 2706fb12b70Safresh1} 2716fb12b70Safresh1 2726fb12b70Safresh1=item splitpath 2736fb12b70Safresh1 2746fb12b70Safresh1 ($volume,$directories,$file) = File::Spec->splitpath( $path ); 2756fb12b70Safresh1 ($volume,$directories,$file) = File::Spec->splitpath( $path, 2766fb12b70Safresh1 $no_file ); 2776fb12b70Safresh1 2786fb12b70Safresh1Splits a path into volume, directory, and filename portions. On systems 2796fb12b70Safresh1with no concept of volume, returns '' for volume. 2806fb12b70Safresh1 2816fb12b70Safresh1For systems with no syntax differentiating filenames from directories, 2826fb12b70Safresh1assumes that the last file is a path unless $no_file is true or a 2836fb12b70Safresh1trailing separator or /. or /.. is present. On Unix this means that $no_file 2846fb12b70Safresh1true makes this return ( '', $path, '' ). 2856fb12b70Safresh1 2866fb12b70Safresh1The directory portion may or may not be returned with a trailing '/'. 2876fb12b70Safresh1 2886fb12b70Safresh1The results can be passed to L</catpath()> to get back a path equivalent to 2896fb12b70Safresh1(usually identical to) the original path. 2906fb12b70Safresh1 2916fb12b70Safresh1=cut 2926fb12b70Safresh1 2936fb12b70Safresh1sub splitpath { 2946fb12b70Safresh1 my ($self,$path, $nofile) = @_; 2956fb12b70Safresh1 2966fb12b70Safresh1 my ($volume,$directory,$file) = ('','',''); 2976fb12b70Safresh1 2986fb12b70Safresh1 if ( $nofile ) { 2996fb12b70Safresh1 $directory = $path; 3006fb12b70Safresh1 } 3016fb12b70Safresh1 else { 3026fb12b70Safresh1 $path =~ m|^ ( (?: .* / (?: \.\.?\z )? )? ) ([^/]*) |xs; 3036fb12b70Safresh1 $directory = $1; 3046fb12b70Safresh1 $file = $2; 3056fb12b70Safresh1 } 3066fb12b70Safresh1 3076fb12b70Safresh1 return ($volume,$directory,$file); 3086fb12b70Safresh1} 3096fb12b70Safresh1 3106fb12b70Safresh1 3116fb12b70Safresh1=item splitdir 3126fb12b70Safresh1 3136fb12b70Safresh1The opposite of L</catdir()>. 3146fb12b70Safresh1 3156fb12b70Safresh1 @dirs = File::Spec->splitdir( $directories ); 3166fb12b70Safresh1 3176fb12b70Safresh1$directories must be only the directory portion of the path on systems 3186fb12b70Safresh1that have the concept of a volume or that have path syntax that differentiates 3196fb12b70Safresh1files from directories. 3206fb12b70Safresh1 3216fb12b70Safresh1Unlike just splitting the directories on the separator, empty 3226fb12b70Safresh1directory names (C<''>) can be returned, because these are significant 3236fb12b70Safresh1on some OSs. 3246fb12b70Safresh1 3256fb12b70Safresh1On Unix, 3266fb12b70Safresh1 3276fb12b70Safresh1 File::Spec->splitdir( "/a/b//c/" ); 3286fb12b70Safresh1 3296fb12b70Safresh1Yields: 3306fb12b70Safresh1 3316fb12b70Safresh1 ( '', 'a', 'b', '', 'c', '' ) 3326fb12b70Safresh1 3336fb12b70Safresh1=cut 3346fb12b70Safresh1 3356fb12b70Safresh1sub splitdir { 3366fb12b70Safresh1 return split m|/|, $_[1], -1; # Preserve trailing fields 3376fb12b70Safresh1} 3386fb12b70Safresh1 3396fb12b70Safresh1 3406fb12b70Safresh1=item catpath() 3416fb12b70Safresh1 3426fb12b70Safresh1Takes volume, directory and file portions and returns an entire path. Under 3436fb12b70Safresh1Unix, $volume is ignored, and directory and file are concatenated. A '/' is 3446fb12b70Safresh1inserted if needed (though if the directory portion doesn't start with 3456fb12b70Safresh1'/' it is not added). On other OSs, $volume is significant. 3466fb12b70Safresh1 3476fb12b70Safresh1=cut 3486fb12b70Safresh1 3496fb12b70Safresh1sub catpath { 3506fb12b70Safresh1 my ($self,$volume,$directory,$file) = @_; 3516fb12b70Safresh1 3526fb12b70Safresh1 if ( $directory ne '' && 3536fb12b70Safresh1 $file ne '' && 3546fb12b70Safresh1 substr( $directory, -1 ) ne '/' && 3556fb12b70Safresh1 substr( $file, 0, 1 ) ne '/' 3566fb12b70Safresh1 ) { 3576fb12b70Safresh1 $directory .= "/$file" ; 3586fb12b70Safresh1 } 3596fb12b70Safresh1 else { 3606fb12b70Safresh1 $directory .= $file ; 3616fb12b70Safresh1 } 3626fb12b70Safresh1 3636fb12b70Safresh1 return $directory ; 3646fb12b70Safresh1} 3656fb12b70Safresh1 3666fb12b70Safresh1=item abs2rel 3676fb12b70Safresh1 3686fb12b70Safresh1Takes a destination path and an optional base path returns a relative path 3696fb12b70Safresh1from the base path to the destination path: 3706fb12b70Safresh1 3716fb12b70Safresh1 $rel_path = File::Spec->abs2rel( $path ) ; 3726fb12b70Safresh1 $rel_path = File::Spec->abs2rel( $path, $base ) ; 3736fb12b70Safresh1 3746fb12b70Safresh1If $base is not present or '', then L<cwd()|Cwd> is used. If $base is 3756fb12b70Safresh1relative, then it is converted to absolute form using 3766fb12b70Safresh1L</rel2abs()>. This means that it is taken to be relative to 3776fb12b70Safresh1L<cwd()|Cwd>. 3786fb12b70Safresh1 3796fb12b70Safresh1On systems that have a grammar that indicates filenames, this ignores the 3806fb12b70Safresh1$base filename. Otherwise all path components are assumed to be 3816fb12b70Safresh1directories. 3826fb12b70Safresh1 3836fb12b70Safresh1If $path is relative, it is converted to absolute form using L</rel2abs()>. 3846fb12b70Safresh1This means that it is taken to be relative to L<cwd()|Cwd>. 3856fb12b70Safresh1 3866fb12b70Safresh1No checks against the filesystem are made, so the result may not be correct if 3876fb12b70Safresh1C<$base> contains symbolic links. (Apply 3886fb12b70Safresh1L<Cwd::abs_path()|Cwd/abs_path> beforehand if that 3896fb12b70Safresh1is a concern.) On VMS, there is interaction with the working environment, as 3906fb12b70Safresh1logicals and macros are expanded. 3916fb12b70Safresh1 3926fb12b70Safresh1Based on code written by Shigio Yamaguchi. 3936fb12b70Safresh1 3946fb12b70Safresh1=cut 3956fb12b70Safresh1 3966fb12b70Safresh1sub abs2rel { 3976fb12b70Safresh1 my($self,$path,$base) = @_; 3989f11ffb7Safresh1 $base = Cwd::getcwd() unless defined $base and length $base; 3996fb12b70Safresh1 4006fb12b70Safresh1 ($path, $base) = map $self->canonpath($_), $path, $base; 4016fb12b70Safresh1 4026fb12b70Safresh1 my $path_directories; 4036fb12b70Safresh1 my $base_directories; 4046fb12b70Safresh1 4056fb12b70Safresh1 if (grep $self->file_name_is_absolute($_), $path, $base) { 4066fb12b70Safresh1 ($path, $base) = map $self->rel2abs($_), $path, $base; 4076fb12b70Safresh1 4086fb12b70Safresh1 my ($path_volume) = $self->splitpath($path, 1); 4096fb12b70Safresh1 my ($base_volume) = $self->splitpath($base, 1); 4106fb12b70Safresh1 4116fb12b70Safresh1 # Can't relativize across volumes 4126fb12b70Safresh1 return $path unless $path_volume eq $base_volume; 4136fb12b70Safresh1 4146fb12b70Safresh1 $path_directories = ($self->splitpath($path, 1))[1]; 4156fb12b70Safresh1 $base_directories = ($self->splitpath($base, 1))[1]; 4166fb12b70Safresh1 4176fb12b70Safresh1 # For UNC paths, the user might give a volume like //foo/bar that 4186fb12b70Safresh1 # strictly speaking has no directory portion. Treat it as if it 4196fb12b70Safresh1 # had the root directory for that volume. 4206fb12b70Safresh1 if (!length($base_directories) and $self->file_name_is_absolute($base)) { 4216fb12b70Safresh1 $base_directories = $self->rootdir; 4226fb12b70Safresh1 } 4236fb12b70Safresh1 } 4246fb12b70Safresh1 else { 4259f11ffb7Safresh1 my $wd= ($self->splitpath(Cwd::getcwd(), 1))[1]; 4266fb12b70Safresh1 $path_directories = $self->catdir($wd, $path); 4276fb12b70Safresh1 $base_directories = $self->catdir($wd, $base); 4286fb12b70Safresh1 } 4296fb12b70Safresh1 4306fb12b70Safresh1 # Now, remove all leading components that are the same 4316fb12b70Safresh1 my @pathchunks = $self->splitdir( $path_directories ); 4326fb12b70Safresh1 my @basechunks = $self->splitdir( $base_directories ); 4336fb12b70Safresh1 4346fb12b70Safresh1 if ($base_directories eq $self->rootdir) { 4356fb12b70Safresh1 return $self->curdir if $path_directories eq $self->rootdir; 4366fb12b70Safresh1 shift @pathchunks; 4376fb12b70Safresh1 return $self->canonpath( $self->catpath('', $self->catdir( @pathchunks ), '') ); 4386fb12b70Safresh1 } 4396fb12b70Safresh1 4406fb12b70Safresh1 my @common; 4416fb12b70Safresh1 while (@pathchunks && @basechunks && $self->_same($pathchunks[0], $basechunks[0])) { 4426fb12b70Safresh1 push @common, shift @pathchunks ; 4436fb12b70Safresh1 shift @basechunks ; 4446fb12b70Safresh1 } 4456fb12b70Safresh1 return $self->curdir unless @pathchunks || @basechunks; 4466fb12b70Safresh1 4476fb12b70Safresh1 # @basechunks now contains the directories the resulting relative path 4486fb12b70Safresh1 # must ascend out of before it can descend to $path_directory. If there 4496fb12b70Safresh1 # are updir components, we must descend into the corresponding directories 4506fb12b70Safresh1 # (this only works if they are no symlinks). 4516fb12b70Safresh1 my @reverse_base; 4526fb12b70Safresh1 while( defined(my $dir= shift @basechunks) ) { 4536fb12b70Safresh1 if( $dir ne $self->updir ) { 4546fb12b70Safresh1 unshift @reverse_base, $self->updir; 4556fb12b70Safresh1 push @common, $dir; 4566fb12b70Safresh1 } 4576fb12b70Safresh1 elsif( @common ) { 4586fb12b70Safresh1 if( @reverse_base && $reverse_base[0] eq $self->updir ) { 4596fb12b70Safresh1 shift @reverse_base; 4606fb12b70Safresh1 pop @common; 4616fb12b70Safresh1 } 4626fb12b70Safresh1 else { 4636fb12b70Safresh1 unshift @reverse_base, pop @common; 4646fb12b70Safresh1 } 4656fb12b70Safresh1 } 4666fb12b70Safresh1 } 4676fb12b70Safresh1 my $result_dirs = $self->catdir( @reverse_base, @pathchunks ); 4686fb12b70Safresh1 return $self->canonpath( $self->catpath('', $result_dirs, '') ); 4696fb12b70Safresh1} 4706fb12b70Safresh1 4716fb12b70Safresh1sub _same { 4726fb12b70Safresh1 $_[1] eq $_[2]; 4736fb12b70Safresh1} 4746fb12b70Safresh1 4756fb12b70Safresh1=item rel2abs() 4766fb12b70Safresh1 4776fb12b70Safresh1Converts a relative path to an absolute path. 4786fb12b70Safresh1 4796fb12b70Safresh1 $abs_path = File::Spec->rel2abs( $path ) ; 4806fb12b70Safresh1 $abs_path = File::Spec->rel2abs( $path, $base ) ; 4816fb12b70Safresh1 4826fb12b70Safresh1If $base is not present or '', then L<cwd()|Cwd> is used. If $base is 4836fb12b70Safresh1relative, then it is converted to absolute form using 4846fb12b70Safresh1L</rel2abs()>. This means that it is taken to be relative to 4856fb12b70Safresh1L<cwd()|Cwd>. 4866fb12b70Safresh1 4876fb12b70Safresh1On systems that have a grammar that indicates filenames, this ignores 4886fb12b70Safresh1the $base filename. Otherwise all path components are assumed to be 4896fb12b70Safresh1directories. 4906fb12b70Safresh1 4916fb12b70Safresh1If $path is absolute, it is cleaned up and returned using L</canonpath()>. 4926fb12b70Safresh1 4936fb12b70Safresh1No checks against the filesystem are made. On VMS, there is 4946fb12b70Safresh1interaction with the working environment, as logicals and 4956fb12b70Safresh1macros are expanded. 4966fb12b70Safresh1 4976fb12b70Safresh1Based on code written by Shigio Yamaguchi. 4986fb12b70Safresh1 4996fb12b70Safresh1=cut 5006fb12b70Safresh1 5016fb12b70Safresh1sub rel2abs { 5026fb12b70Safresh1 my ($self,$path,$base ) = @_; 5036fb12b70Safresh1 5046fb12b70Safresh1 # Clean up $path 5056fb12b70Safresh1 if ( ! $self->file_name_is_absolute( $path ) ) { 5066fb12b70Safresh1 # Figure out the effective $base and clean it up. 5076fb12b70Safresh1 if ( !defined( $base ) || $base eq '' ) { 5089f11ffb7Safresh1 $base = Cwd::getcwd(); 5096fb12b70Safresh1 } 5106fb12b70Safresh1 elsif ( ! $self->file_name_is_absolute( $base ) ) { 5116fb12b70Safresh1 $base = $self->rel2abs( $base ) ; 5126fb12b70Safresh1 } 5136fb12b70Safresh1 else { 5146fb12b70Safresh1 $base = $self->canonpath( $base ) ; 5156fb12b70Safresh1 } 5166fb12b70Safresh1 5176fb12b70Safresh1 # Glom them together 5186fb12b70Safresh1 $path = $self->catdir( $base, $path ) ; 5196fb12b70Safresh1 } 5206fb12b70Safresh1 5216fb12b70Safresh1 return $self->canonpath( $path ) ; 5226fb12b70Safresh1} 5236fb12b70Safresh1 5246fb12b70Safresh1=back 5256fb12b70Safresh1 5266fb12b70Safresh1=head1 COPYRIGHT 5276fb12b70Safresh1 5286fb12b70Safresh1Copyright (c) 2004 by the Perl 5 Porters. All rights reserved. 5296fb12b70Safresh1 5306fb12b70Safresh1This program is free software; you can redistribute it and/or modify 5316fb12b70Safresh1it under the same terms as Perl itself. 5326fb12b70Safresh1 533eac174f2Safresh1Please submit bug reports at L<https://github.com/Perl/perl5/issues>. 5346fb12b70Safresh1 5356fb12b70Safresh1=head1 SEE ALSO 5366fb12b70Safresh1 5376fb12b70Safresh1L<File::Spec> 5386fb12b70Safresh1 5396fb12b70Safresh1=cut 5406fb12b70Safresh1 5416fb12b70Safresh1# Internal method to reduce xx\..\yy -> yy 5426fb12b70Safresh1sub _collapse { 5436fb12b70Safresh1 my($fs, $path) = @_; 5446fb12b70Safresh1 5456fb12b70Safresh1 my $updir = $fs->updir; 5466fb12b70Safresh1 my $curdir = $fs->curdir; 5476fb12b70Safresh1 5486fb12b70Safresh1 my($vol, $dirs, $file) = $fs->splitpath($path); 5496fb12b70Safresh1 my @dirs = $fs->splitdir($dirs); 5506fb12b70Safresh1 pop @dirs if @dirs && $dirs[-1] eq ''; 5516fb12b70Safresh1 5526fb12b70Safresh1 my @collapsed; 5536fb12b70Safresh1 foreach my $dir (@dirs) { 5546fb12b70Safresh1 if( $dir eq $updir and # if we have an updir 5556fb12b70Safresh1 @collapsed and # and something to collapse 5566fb12b70Safresh1 length $collapsed[-1] and # and its not the rootdir 5576fb12b70Safresh1 $collapsed[-1] ne $updir and # nor another updir 5586fb12b70Safresh1 $collapsed[-1] ne $curdir # nor the curdir 5596fb12b70Safresh1 ) 5606fb12b70Safresh1 { # then 5616fb12b70Safresh1 pop @collapsed; # collapse 5626fb12b70Safresh1 } 5636fb12b70Safresh1 else { # else 5646fb12b70Safresh1 push @collapsed, $dir; # just hang onto it 5656fb12b70Safresh1 } 5666fb12b70Safresh1 } 5676fb12b70Safresh1 5686fb12b70Safresh1 return $fs->catpath($vol, 5696fb12b70Safresh1 $fs->catdir(@collapsed), 5706fb12b70Safresh1 $file 5716fb12b70Safresh1 ); 5726fb12b70Safresh1} 5736fb12b70Safresh1 5746fb12b70Safresh1 5756fb12b70Safresh11; 576