"Fossies" - the Fresh Open Source Software Archive

Member "install-tl-20200916/tlpkg/tlperl/lib/File/Spec/Unix.pm" (7 Mar 2020, 15889 Bytes) of package /windows/misc/install-tl.zip:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file.

    1 package File::Spec::Unix;
    2 
    3 use strict;
    4 use Cwd ();
    5 
    6 our $VERSION = '3.78';
    7 $VERSION =~ tr/_//d;
    8 
    9 =head1 NAME
   10 
   11 File::Spec::Unix - File::Spec for Unix, base for other File::Spec modules
   12 
   13 =head1 SYNOPSIS
   14 
   15  require File::Spec::Unix; # Done automatically by File::Spec
   16 
   17 =head1 DESCRIPTION
   18 
   19 Methods for manipulating file specifications.  Other File::Spec
   20 modules, such as File::Spec::Mac, inherit from File::Spec::Unix and
   21 override specific methods.
   22 
   23 =head1 METHODS
   24 
   25 =over 2
   26 
   27 =item canonpath()
   28 
   29 No physical check on the filesystem, but a logical cleanup of a
   30 path. On UNIX eliminates successive slashes and successive "/.".
   31 
   32     $cpath = File::Spec->canonpath( $path ) ;
   33 
   34 Note that this does *not* collapse F<x/../y> sections into F<y>.  This
   35 is by design.  If F</foo> on your system is a symlink to F</bar/baz>,
   36 then F</foo/../quux> is actually F</bar/quux>, not F</quux> as a naive
   37 F<../>-removal would give you.  If you want to do this kind of
   38 processing, you probably want C<Cwd>'s C<realpath()> function to
   39 actually traverse the filesystem cleaning up paths like this.
   40 
   41 =cut
   42 
   43 sub _pp_canonpath {
   44     my ($self,$path) = @_;
   45     return unless defined $path;
   46     
   47     # Handle POSIX-style node names beginning with double slash (qnx, nto)
   48     # (POSIX says: "a pathname that begins with two successive slashes
   49     # may be interpreted in an implementation-defined manner, although
   50     # more than two leading slashes shall be treated as a single slash.")
   51     my $node = '';
   52     my $double_slashes_special = $^O eq 'qnx' || $^O eq 'nto';
   53 
   54 
   55     if ( $double_slashes_special
   56          && ( $path =~ s{^(//[^/]+)/?\z}{}s || $path =~ s{^(//[^/]+)/}{/}s ) ) {
   57       $node = $1;
   58     }
   59     # This used to be
   60     # $path =~ s|/+|/|g unless ($^O eq 'cygwin');
   61     # but that made tests 29, 30, 35, 46, and 213 (as of #13272) to fail
   62     # (Mainly because trailing "" directories didn't get stripped).
   63     # Why would cygwin avoid collapsing multiple slashes into one? --jhi
   64     $path =~ s|/{2,}|/|g;                            # xx////xx  -> xx/xx
   65     $path =~ s{(?:/\.)+(?:/|\z)}{/}g;                # xx/././xx -> xx/xx
   66     $path =~ s|^(?:\./)+||s unless $path eq "./";    # ./xx      -> xx
   67     $path =~ s|^/(?:\.\./)+|/|;                      # /../../xx -> xx
   68     $path =~ s|^/\.\.$|/|;                         # /..       -> /
   69     $path =~ s|/\z|| unless $path eq "/";          # xx/       -> xx
   70     return "$node$path";
   71 }
   72 *canonpath = \&_pp_canonpath unless defined &canonpath;
   73 
   74 =item catdir()
   75 
   76 Concatenate two or more directory names to form a complete path ending
   77 with a directory. But remove the trailing slash from the resulting
   78 string, because it doesn't look good, isn't necessary and confuses
   79 OS2. Of course, if this is the root directory, don't cut off the
   80 trailing slash :-)
   81 
   82 =cut
   83 
   84 sub _pp_catdir {
   85     my $self = shift;
   86 
   87     $self->canonpath(join('/', @_, '')); # '' because need a trailing '/'
   88 }
   89 *catdir = \&_pp_catdir unless defined &catdir;
   90 
   91 =item catfile
   92 
   93 Concatenate one or more directory names and a filename to form a
   94 complete path ending with a filename
   95 
   96 =cut
   97 
   98 sub _pp_catfile {
   99     my $self = shift;
  100     my $file = $self->canonpath(pop @_);
  101     return $file unless @_;
  102     my $dir = $self->catdir(@_);
  103     $dir .= "/" unless substr($dir,-1) eq "/";
  104     return $dir.$file;
  105 }
  106 *catfile = \&_pp_catfile unless defined &catfile;
  107 
  108 =item curdir
  109 
  110 Returns a string representation of the current directory.  "." on UNIX.
  111 
  112 =cut
  113 
  114 sub curdir { '.' }
  115 use constant _fn_curdir => ".";
  116 
  117 =item devnull
  118 
  119 Returns a string representation of the null device. "/dev/null" on UNIX.
  120 
  121 =cut
  122 
  123 sub devnull { '/dev/null' }
  124 use constant _fn_devnull => "/dev/null";
  125 
  126 =item rootdir
  127 
  128 Returns a string representation of the root directory.  "/" on UNIX.
  129 
  130 =cut
  131 
  132 sub rootdir { '/' }
  133 use constant _fn_rootdir => "/";
  134 
  135 =item tmpdir
  136 
  137 Returns a string representation of the first writable directory from
  138 the following list or the current directory if none from the list are
  139 writable:
  140 
  141     $ENV{TMPDIR}
  142     /tmp
  143 
  144 If running under taint mode, and if $ENV{TMPDIR}
  145 is tainted, it is not used.
  146 
  147 =cut
  148 
  149 my ($tmpdir, %tmpenv);
  150 # Cache and return the calculated tmpdir, recording which env vars
  151 # determined it.
  152 sub _cache_tmpdir {
  153     @tmpenv{@_[2..$#_]} = @ENV{@_[2..$#_]};
  154     return $tmpdir = $_[1];
  155 }
  156 # Retrieve the cached tmpdir, checking first whether relevant env vars have
  157 # changed and invalidated the cache.
  158 sub _cached_tmpdir {
  159     shift;
  160     local $^W;
  161     return if grep $ENV{$_} ne $tmpenv{$_}, @_;
  162     return $tmpdir;
  163 }
  164 sub _tmpdir {
  165     my $self = shift;
  166     my @dirlist = @_;
  167     my $taint = do { no strict 'refs'; ${"\cTAINT"} };
  168     if ($taint) { # Check for taint mode on perl >= 5.8.0
  169     require Scalar::Util;
  170     @dirlist = grep { ! Scalar::Util::tainted($_) } @dirlist;
  171     }
  172     elsif ($] < 5.007) { # No ${^TAINT} before 5.8
  173     @dirlist = grep { !defined($_) || eval { eval('1'.substr $_,0,0) } }
  174             @dirlist;
  175     }
  176     
  177     foreach (@dirlist) {
  178     next unless defined && -d && -w _;
  179     $tmpdir = $_;
  180     last;
  181     }
  182     $tmpdir = $self->curdir unless defined $tmpdir;
  183     $tmpdir = defined $tmpdir && $self->canonpath($tmpdir);
  184     if ( !$self->file_name_is_absolute($tmpdir) ) {
  185         # See [perl #120593] for the full details
  186         # If possible, return a full path, rather than '.' or 'lib', but
  187         # jump through some hoops to avoid returning a tainted value.
  188         ($tmpdir) = grep {
  189             $taint     ? ! Scalar::Util::tainted($_) :
  190             $] < 5.007 ? eval { eval('1'.substr $_,0,0) } : 1
  191         } $self->rel2abs($tmpdir), $tmpdir;
  192     }
  193     return $tmpdir;
  194 }
  195 
  196 sub tmpdir {
  197     my $cached = $_[0]->_cached_tmpdir('TMPDIR');
  198     return $cached if defined $cached;
  199     $_[0]->_cache_tmpdir($_[0]->_tmpdir( $ENV{TMPDIR}, "/tmp" ), 'TMPDIR');
  200 }
  201 
  202 =item updir
  203 
  204 Returns a string representation of the parent directory.  ".." on UNIX.
  205 
  206 =cut
  207 
  208 sub updir { '..' }
  209 use constant _fn_updir => "..";
  210 
  211 =item no_upwards
  212 
  213 Given a list of file names, strip out those that refer to a parent
  214 directory. (Does not strip symlinks, only '.', '..', and equivalents.)
  215 
  216 =cut
  217 
  218 sub no_upwards {
  219     my $self = shift;
  220     return grep(!/^\.{1,2}\z/s, @_);
  221 }
  222 
  223 =item case_tolerant
  224 
  225 Returns a true or false value indicating, respectively, that alphabetic
  226 is not or is significant when comparing file specifications.
  227 
  228 =cut
  229 
  230 sub case_tolerant { 0 }
  231 use constant _fn_case_tolerant => 0;
  232 
  233 =item file_name_is_absolute
  234 
  235 Takes as argument a path and returns true if it is an absolute path.
  236 
  237 This does not consult the local filesystem on Unix, Win32, OS/2 or Mac 
  238 OS (Classic).  It does consult the working environment for VMS (see
  239 L<File::Spec::VMS/file_name_is_absolute>).
  240 
  241 =cut
  242 
  243 sub file_name_is_absolute {
  244     my ($self,$file) = @_;
  245     return scalar($file =~ m:^/:s);
  246 }
  247 
  248 =item path
  249 
  250 Takes no argument, returns the environment variable PATH as an array.
  251 
  252 =cut
  253 
  254 sub path {
  255     return () unless exists $ENV{PATH};
  256     my @path = split(':', $ENV{PATH});
  257     foreach (@path) { $_ = '.' if $_ eq '' }
  258     return @path;
  259 }
  260 
  261 =item join
  262 
  263 join is the same as catfile.
  264 
  265 =cut
  266 
  267 sub join {
  268     my $self = shift;
  269     return $self->catfile(@_);
  270 }
  271 
  272 =item splitpath
  273 
  274     ($volume,$directories,$file) = File::Spec->splitpath( $path );
  275     ($volume,$directories,$file) = File::Spec->splitpath( $path,
  276                                                           $no_file );
  277 
  278 Splits a path into volume, directory, and filename portions. On systems
  279 with no concept of volume, returns '' for volume. 
  280 
  281 For systems with no syntax differentiating filenames from directories, 
  282 assumes that the last file is a path unless $no_file is true or a 
  283 trailing separator or /. or /.. is present. On Unix this means that $no_file
  284 true makes this return ( '', $path, '' ).
  285 
  286 The directory portion may or may not be returned with a trailing '/'.
  287 
  288 The results can be passed to L</catpath()> to get back a path equivalent to
  289 (usually identical to) the original path.
  290 
  291 =cut
  292 
  293 sub splitpath {
  294     my ($self,$path, $nofile) = @_;
  295 
  296     my ($volume,$directory,$file) = ('','','');
  297 
  298     if ( $nofile ) {
  299         $directory = $path;
  300     }
  301     else {
  302         $path =~ m|^ ( (?: .* / (?: \.\.?\z )? )? ) ([^/]*) |xs;
  303         $directory = $1;
  304         $file      = $2;
  305     }
  306 
  307     return ($volume,$directory,$file);
  308 }
  309 
  310 
  311 =item splitdir
  312 
  313 The opposite of L</catdir()>.
  314 
  315     @dirs = File::Spec->splitdir( $directories );
  316 
  317 $directories must be only the directory portion of the path on systems 
  318 that have the concept of a volume or that have path syntax that differentiates
  319 files from directories.
  320 
  321 Unlike just splitting the directories on the separator, empty
  322 directory names (C<''>) can be returned, because these are significant
  323 on some OSs.
  324 
  325 On Unix,
  326 
  327     File::Spec->splitdir( "/a/b//c/" );
  328 
  329 Yields:
  330 
  331     ( '', 'a', 'b', '', 'c', '' )
  332 
  333 =cut
  334 
  335 sub splitdir {
  336     return split m|/|, $_[1], -1;  # Preserve trailing fields
  337 }
  338 
  339 
  340 =item catpath()
  341 
  342 Takes volume, directory and file portions and returns an entire path. Under
  343 Unix, $volume is ignored, and directory and file are concatenated.  A '/' is
  344 inserted if needed (though if the directory portion doesn't start with
  345 '/' it is not added).  On other OSs, $volume is significant.
  346 
  347 =cut
  348 
  349 sub catpath {
  350     my ($self,$volume,$directory,$file) = @_;
  351 
  352     if ( $directory ne ''                && 
  353          $file ne ''                     && 
  354          substr( $directory, -1 ) ne '/' && 
  355          substr( $file, 0, 1 ) ne '/' 
  356     ) {
  357         $directory .= "/$file" ;
  358     }
  359     else {
  360         $directory .= $file ;
  361     }
  362 
  363     return $directory ;
  364 }
  365 
  366 =item abs2rel
  367 
  368 Takes a destination path and an optional base path returns a relative path
  369 from the base path to the destination path:
  370 
  371     $rel_path = File::Spec->abs2rel( $path ) ;
  372     $rel_path = File::Spec->abs2rel( $path, $base ) ;
  373 
  374 If $base is not present or '', then L<cwd()|Cwd> is used. If $base is
  375 relative, then it is converted to absolute form using
  376 L</rel2abs()>. This means that it is taken to be relative to
  377 L<cwd()|Cwd>.
  378 
  379 On systems that have a grammar that indicates filenames, this ignores the 
  380 $base filename. Otherwise all path components are assumed to be
  381 directories.
  382 
  383 If $path is relative, it is converted to absolute form using L</rel2abs()>.
  384 This means that it is taken to be relative to L<cwd()|Cwd>.
  385 
  386 No checks against the filesystem are made, so the result may not be correct if
  387 C<$base> contains symbolic links.  (Apply
  388 L<Cwd::abs_path()|Cwd/abs_path> beforehand if that
  389 is a concern.)  On VMS, there is interaction with the working environment, as
  390 logicals and macros are expanded.
  391 
  392 Based on code written by Shigio Yamaguchi.
  393 
  394 =cut
  395 
  396 sub abs2rel {
  397     my($self,$path,$base) = @_;
  398     $base = Cwd::getcwd() unless defined $base and length $base;
  399 
  400     ($path, $base) = map $self->canonpath($_), $path, $base;
  401 
  402     my $path_directories;
  403     my $base_directories;
  404 
  405     if (grep $self->file_name_is_absolute($_), $path, $base) {
  406     ($path, $base) = map $self->rel2abs($_), $path, $base;
  407 
  408     my ($path_volume) = $self->splitpath($path, 1);
  409     my ($base_volume) = $self->splitpath($base, 1);
  410 
  411     # Can't relativize across volumes
  412     return $path unless $path_volume eq $base_volume;
  413 
  414     $path_directories = ($self->splitpath($path, 1))[1];
  415     $base_directories = ($self->splitpath($base, 1))[1];
  416 
  417     # For UNC paths, the user might give a volume like //foo/bar that
  418     # strictly speaking has no directory portion.  Treat it as if it
  419     # had the root directory for that volume.
  420     if (!length($base_directories) and $self->file_name_is_absolute($base)) {
  421         $base_directories = $self->rootdir;
  422     }
  423     }
  424     else {
  425     my $wd= ($self->splitpath(Cwd::getcwd(), 1))[1];
  426     $path_directories = $self->catdir($wd, $path);
  427     $base_directories = $self->catdir($wd, $base);
  428     }
  429 
  430     # Now, remove all leading components that are the same
  431     my @pathchunks = $self->splitdir( $path_directories );
  432     my @basechunks = $self->splitdir( $base_directories );
  433 
  434     if ($base_directories eq $self->rootdir) {
  435       return $self->curdir if $path_directories eq $self->rootdir;
  436       shift @pathchunks;
  437       return $self->canonpath( $self->catpath('', $self->catdir( @pathchunks ), '') );
  438     }
  439 
  440     my @common;
  441     while (@pathchunks && @basechunks && $self->_same($pathchunks[0], $basechunks[0])) {
  442         push @common, shift @pathchunks ;
  443         shift @basechunks ;
  444     }
  445     return $self->curdir unless @pathchunks || @basechunks;
  446 
  447     # @basechunks now contains the directories the resulting relative path 
  448     # must ascend out of before it can descend to $path_directory.  If there
  449     # are updir components, we must descend into the corresponding directories
  450     # (this only works if they are no symlinks).
  451     my @reverse_base;
  452     while( defined(my $dir= shift @basechunks) ) {
  453     if( $dir ne $self->updir ) {
  454         unshift @reverse_base, $self->updir;
  455         push @common, $dir;
  456     }
  457     elsif( @common ) {
  458         if( @reverse_base && $reverse_base[0] eq $self->updir ) {
  459         shift @reverse_base;
  460         pop @common;
  461         }
  462         else {
  463         unshift @reverse_base, pop @common;
  464         }
  465     }
  466     }
  467     my $result_dirs = $self->catdir( @reverse_base, @pathchunks );
  468     return $self->canonpath( $self->catpath('', $result_dirs, '') );
  469 }
  470 
  471 sub _same {
  472   $_[1] eq $_[2];
  473 }
  474 
  475 =item rel2abs()
  476 
  477 Converts a relative path to an absolute path. 
  478 
  479     $abs_path = File::Spec->rel2abs( $path ) ;
  480     $abs_path = File::Spec->rel2abs( $path, $base ) ;
  481 
  482 If $base is not present or '', then L<cwd()|Cwd> is used. If $base is
  483 relative, then it is converted to absolute form using
  484 L</rel2abs()>. This means that it is taken to be relative to
  485 L<cwd()|Cwd>.
  486 
  487 On systems that have a grammar that indicates filenames, this ignores
  488 the $base filename. Otherwise all path components are assumed to be
  489 directories.
  490 
  491 If $path is absolute, it is cleaned up and returned using L</canonpath()>.
  492 
  493 No checks against the filesystem are made.  On VMS, there is
  494 interaction with the working environment, as logicals and
  495 macros are expanded.
  496 
  497 Based on code written by Shigio Yamaguchi.
  498 
  499 =cut
  500 
  501 sub rel2abs {
  502     my ($self,$path,$base ) = @_;
  503 
  504     # Clean up $path
  505     if ( ! $self->file_name_is_absolute( $path ) ) {
  506         # Figure out the effective $base and clean it up.
  507         if ( !defined( $base ) || $base eq '' ) {
  508         $base = Cwd::getcwd();
  509         }
  510         elsif ( ! $self->file_name_is_absolute( $base ) ) {
  511             $base = $self->rel2abs( $base ) ;
  512         }
  513         else {
  514             $base = $self->canonpath( $base ) ;
  515         }
  516 
  517         # Glom them together
  518         $path = $self->catdir( $base, $path ) ;
  519     }
  520 
  521     return $self->canonpath( $path ) ;
  522 }
  523 
  524 =back
  525 
  526 =head1 COPYRIGHT
  527 
  528 Copyright (c) 2004 by the Perl 5 Porters.  All rights reserved.
  529 
  530 This program is free software; you can redistribute it and/or modify
  531 it under the same terms as Perl itself.
  532 
  533 Please submit bug reports and patches to perlbug@perl.org.
  534 
  535 =head1 SEE ALSO
  536 
  537 L<File::Spec>
  538 
  539 =cut
  540 
  541 # Internal method to reduce xx\..\yy -> yy
  542 sub _collapse {
  543     my($fs, $path) = @_;
  544 
  545     my $updir  = $fs->updir;
  546     my $curdir = $fs->curdir;
  547 
  548     my($vol, $dirs, $file) = $fs->splitpath($path);
  549     my @dirs = $fs->splitdir($dirs);
  550     pop @dirs if @dirs && $dirs[-1] eq '';
  551 
  552     my @collapsed;
  553     foreach my $dir (@dirs) {
  554         if( $dir eq $updir              and   # if we have an updir
  555             @collapsed                  and   # and something to collapse
  556             length $collapsed[-1]       and   # and its not the rootdir
  557             $collapsed[-1] ne $updir    and   # nor another updir
  558             $collapsed[-1] ne $curdir         # nor the curdir
  559           ) 
  560         {                                     # then
  561             pop @collapsed;                   # collapse
  562         }
  563         else {                                # else
  564             push @collapsed, $dir;            # just hang onto it
  565         }
  566     }
  567 
  568     return $fs->catpath($vol,
  569                         $fs->catdir(@collapsed),
  570                         $file
  571                        );
  572 }
  573 
  574 
  575 1;