xref: /openbsd-src/gnu/usr.bin/perl/dist/PathTools/lib/File/Spec/Unix.pm (revision 3d61058aa5c692477b6d18acfbbdb653a9930ff9)
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