diff options
Diffstat (limited to 'contrib/perl5/lib/File')
| -rw-r--r-- | contrib/perl5/lib/File/Basename.pm | 58 | ||||
| -rw-r--r-- | contrib/perl5/lib/File/CheckTree.pm | 2 | ||||
| -rw-r--r-- | contrib/perl5/lib/File/Compare.pm | 95 | ||||
| -rw-r--r-- | contrib/perl5/lib/File/Copy.pm | 43 | ||||
| -rw-r--r-- | contrib/perl5/lib/File/DosGlob.pm | 23 | ||||
| -rw-r--r-- | contrib/perl5/lib/File/Find.pm | 767 | ||||
| -rw-r--r-- | contrib/perl5/lib/File/Path.pm | 67 | ||||
| -rw-r--r-- | contrib/perl5/lib/File/Spec.pm | 86 | ||||
| -rw-r--r-- | contrib/perl5/lib/File/Spec/Functions.pm | 95 | ||||
| -rw-r--r-- | contrib/perl5/lib/File/Spec/Mac.pm | 285 | ||||
| -rw-r--r-- | contrib/perl5/lib/File/Spec/OS2.pm | 50 | ||||
| -rw-r--r-- | contrib/perl5/lib/File/Spec/Unix.pm | 363 | ||||
| -rw-r--r-- | contrib/perl5/lib/File/Spec/VMS.pm | 450 | ||||
| -rw-r--r-- | contrib/perl5/lib/File/Spec/Win32.pm | 385 | ||||
| -rw-r--r-- | contrib/perl5/lib/File/stat.pm | 6 |
15 files changed, 2245 insertions, 530 deletions
diff --git a/contrib/perl5/lib/File/Basename.pm b/contrib/perl5/lib/File/Basename.pm index 69bb1fa..4581e7e 100644 --- a/contrib/perl5/lib/File/Basename.pm +++ b/contrib/perl5/lib/File/Basename.pm @@ -37,10 +37,10 @@ If the argument passed to it contains one of the substrings "VMS", "MSDOS", "MacOS", "AmigaOS" or "MSWin32", the file specification syntax of that operating system is used in future calls to fileparse(), basename(), and dirname(). If it contains none of -these substrings, UNIX syntax is used. This pattern matching is +these substrings, Unix syntax is used. This pattern matching is case-insensitive. If you've selected VMS syntax, and the file specification you pass to one of these routines contains a "/", -they assume you are using UNIX emulation and apply the UNIX syntax +they assume you are using Unix emulation and apply the Unix syntax rules instead, for that function call only. If the argument passed to it contains one of the substrings "VMS", @@ -73,7 +73,7 @@ file as the input file specification. =head1 EXAMPLES -Using UNIX file syntax: +Using Unix file syntax: ($base,$path,$type) = fileparse('/virgil/aeneid/draft.book7', '\.book\d+'); @@ -102,7 +102,7 @@ would yield The basename() routine returns the first element of the list produced by calling fileparse() with the same arguments, except that it always quotes metacharacters in the given suffixes. It is provided for -programmer compatibility with the UNIX shell command basename(1). +programmer compatibility with the Unix shell command basename(1). =item C<dirname> @@ -111,8 +111,8 @@ specification. When using VMS or MacOS syntax, this is identical to the second element of the list produced by calling fileparse() with the same input file specification. (Under VMS, if there is no directory information in the input file specification, then the current default device and -directory are returned.) When using UNIX or MSDOS syntax, the return -value conforms to the behavior of the UNIX shell command dirname(1). This +directory are returned.) When using Unix or MSDOS syntax, the return +value conforms to the behavior of the Unix shell command dirname(1). This is usually the same as the behavior of fileparse(), but differs in some cases. For example, for the input file specification F<lib/>, fileparse() considers the directory name to be F<lib/>, while dirname() considers the @@ -124,12 +124,22 @@ directory name to be F<.>). ## use strict; -use re 'taint'; +# A bit of juggling to insure that C<use re 'taint';> always works, since +# File::Basename is used during the Perl build, when the re extension may +# not be available. +BEGIN { + unless (eval { require re; }) + { eval ' sub re::import { $^H |= 0x00100000; } ' } + import re 'taint'; +} + + +use 5.005_64; +our(@ISA, @EXPORT, $VERSION, $Fileparse_fstype, $Fileparse_igncase); require Exporter; @ISA = qw(Exporter); @EXPORT = qw(fileparse fileparse_set_fstype basename dirname); -use vars qw($VERSION $Fileparse_fstype $Fileparse_igncase); $VERSION = "2.6"; @@ -162,23 +172,23 @@ sub fileparse { if ($fstype =~ /^VMS/i) { if ($fullname =~ m#/#) { $fstype = '' } # We're doing Unix emulation else { - ($dirpath,$basename) = ($fullname =~ /^(.*[:>\]])?(.*)/); + ($dirpath,$basename) = ($fullname =~ /^(.*[:>\]])?(.*)/s); $dirpath ||= ''; # should always be defined } } if ($fstype =~ /^MS(DOS|Win32)/i) { - ($dirpath,$basename) = ($fullname =~ /^((?:.*[:\\\/])?)(.*)/); - $dirpath .= '.\\' unless $dirpath =~ /[\\\/]$/; + ($dirpath,$basename) = ($fullname =~ /^((?:.*[:\\\/])?)(.*)/s); + $dirpath .= '.\\' unless $dirpath =~ /[\\\/]\z/; } - elsif ($fstype =~ /^MacOS/i) { - ($dirpath,$basename) = ($fullname =~ /^(.*:)?(.*)/); + elsif ($fstype =~ /^MacOS/si) { + ($dirpath,$basename) = ($fullname =~ /^(.*:)?(.*)/s); } elsif ($fstype =~ /^AmigaOS/i) { - ($dirpath,$basename) = ($fullname =~ /(.*[:\/])?(.*)/); + ($dirpath,$basename) = ($fullname =~ /(.*[:\/])?(.*)/s); $dirpath = './' unless $dirpath; } elsif ($fstype !~ /^VMS/i) { # default to Unix - ($dirpath,$basename) = ($fullname =~ m#^(.*/)?(.*)#); + ($dirpath,$basename) = ($fullname =~ m#^(.*/)?(.*)#s); if ($^O eq 'VMS' and $fullname =~ m:/[^/]+/000000/?:) { # dev:[000000] is top of VMS tree, similar to Unix '/' ($basename,$dirpath) = ('',$fullname); @@ -190,7 +200,7 @@ sub fileparse { $tail = ''; foreach $suffix (@suffices) { my $pat = ($igncase ? '(?i)' : '') . "($suffix)\$"; - if ($basename =~ s/$pat//) { + if ($basename =~ s/$pat//s) { $taint .= substr($suffix,0,0); $tail = $1 . $tail; } @@ -228,30 +238,30 @@ sub dirname { } if ($fstype =~ /MacOS/i) { return $dirname } elsif ($fstype =~ /MSDOS/i) { - $dirname =~ s/([^:])[\\\/]*$/$1/; + $dirname =~ s/([^:])[\\\/]*\z/$1/; unless( length($basename) ) { ($basename,$dirname) = fileparse $dirname; - $dirname =~ s/([^:])[\\\/]*$/$1/; + $dirname =~ s/([^:])[\\\/]*\z/$1/; } } elsif ($fstype =~ /MSWin32/i) { - $dirname =~ s/([^:])[\\\/]*$/$1/; + $dirname =~ s/([^:])[\\\/]*\z/$1/; unless( length($basename) ) { ($basename,$dirname) = fileparse $dirname; - $dirname =~ s/([^:])[\\\/]*$/$1/; + $dirname =~ s/([^:])[\\\/]*\z/$1/; } } elsif ($fstype =~ /AmigaOS/i) { - if ( $dirname =~ /:$/) { return $dirname } + if ( $dirname =~ /:\z/) { return $dirname } chop $dirname; - $dirname =~ s#[^:/]+$## unless length($basename); + $dirname =~ s#[^:/]+\z## unless length($basename); } else { - $dirname =~ s:(.)/*$:$1:; + $dirname =~ s:(.)/*\z:$1:s; unless( length($basename) ) { local($File::Basename::Fileparse_fstype) = $fstype; ($basename,$dirname) = fileparse $dirname; - $dirname =~ s:(.)/*$:$1:; + $dirname =~ s:(.)/*\z:$1:s; } } diff --git a/contrib/perl5/lib/File/CheckTree.pm b/contrib/perl5/lib/File/CheckTree.pm index dca7f6a..ae18777 100644 --- a/contrib/perl5/lib/File/CheckTree.pm +++ b/contrib/perl5/lib/File/CheckTree.pm @@ -105,7 +105,7 @@ sub validate { sub valmess { local($disposition,$this) = @_; - $file = $cwd . '/' . $file unless $file =~ m|^/|; + $file = $cwd . '/' . $file unless $file =~ m|^/|s; if ($this =~ /^(!?)-(\w)\s+\$file\s*$/) { $neg = $1; $tmp = $2; diff --git a/contrib/perl5/lib/File/Compare.pm b/contrib/perl5/lib/File/Compare.pm index 2f9c45c..667e7cb 100644 --- a/contrib/perl5/lib/File/Compare.pm +++ b/contrib/perl5/lib/File/Compare.pm @@ -1,15 +1,16 @@ package File::Compare; +use 5.005_64; use strict; -use vars qw($VERSION @ISA @EXPORT @EXPORT_OK $Too_Big *FROM *TO); +our($VERSION, @ISA, @EXPORT, @EXPORT_OK, $Too_Big); require Exporter; use Carp; -$VERSION = '1.1001'; +$VERSION = '1.1002'; @ISA = qw(Exporter); @EXPORT = qw(compare); -@EXPORT_OK = qw(cmp); +@EXPORT_OK = qw(cmp compare_text); $Too_Big = 1024 * 1024 * 2; @@ -22,13 +23,11 @@ sub compare { croak("Usage: compare( file1, file2 [, buffersize]) ") unless(@_ == 2 || @_ == 3); - my $from = shift; - my $to = shift; - my $closefrom=0; - my $closeto=0; - my ($size, $fromsize, $status, $fr, $tr, $fbuf, $tbuf); - local(*FROM, *TO); - local($\) = ''; + my ($from,$to,$size) = @_; + my $text_mode = defined($size) && (ref($size) eq 'CODE' || $size < 0); + + my ($fromsize,$closefrom,$closeto); + local (*FROM, *TO); croak("from undefined") unless (defined $from); croak("to undefined") unless (defined $to); @@ -40,9 +39,11 @@ sub compare { *FROM = $from; } else { open(FROM,"<$from") or goto fail_open1; - binmode FROM; + unless ($text_mode) { + binmode FROM; + $fromsize = -s FROM; + } $closefrom = 1; - $fromsize = -s FROM; } if (ref($to) && @@ -52,32 +53,45 @@ sub compare { *TO = $to; } else { open(TO,"<$to") or goto fail_open2; - binmode TO; + binmode TO unless $text_mode; $closeto = 1; } - if ($closefrom && $closeto) { + if (!$text_mode && $closefrom && $closeto) { # If both are opened files we know they differ if their size differ goto fail_inner if $fromsize != -s TO; } - if (@_) { - $size = shift(@_) + 0; - croak("Bad buffer size for compare: $size\n") unless ($size > 0); - } else { - $size = $fromsize; - $size = 1024 if ($size < 512); - $size = $Too_Big if ($size > $Too_Big); + if ($text_mode) { + local $/ = "\n"; + my ($fline,$tline); + while (defined($fline = <FROM>)) { + goto fail_inner unless defined($tline = <TO>); + if (ref $size) { + # $size contains ref to comparison function + goto fail_inner if &$size($fline, $tline); + } else { + goto fail_inner if $fline ne $tline; + } + } + goto fail_inner if defined($tline = <TO>); } + else { + unless (defined($size) && $size > 0) { + $size = $fromsize || -s TO || 0; + $size = 1024 if $size < 512; + $size = $Too_Big if $size > $Too_Big; + } - $fbuf = ''; - $tbuf = ''; - while(defined($fr = read(FROM,$fbuf,$size)) && $fr > 0) { - unless (defined($tr = read(TO,$tbuf,$fr)) and $tbuf eq $fbuf) { - goto fail_inner; + my ($fr,$tr,$fbuf,$tbuf); + $fbuf = $tbuf = ''; + while(defined($fr = read(FROM,$fbuf,$size)) && $fr > 0) { + unless (defined($tr = read(TO,$tbuf,$fr)) && $tbuf eq $fbuf) { + goto fail_inner; + } } + goto fail_inner if defined($tr = read(TO,$tbuf,$size)) && $tr > 0; } - goto fail_inner if (defined($tr = read(TO,$tbuf,$size)) && $tr > 0); close(TO) || goto fail_open2 if $closeto; close(FROM) || goto fail_open1 if $closefrom; @@ -93,7 +107,7 @@ sub compare { fail_open2: if ($closefrom) { - $status = $!; + my $status = $!; $! = 0; close FROM; $! = $status unless $!; @@ -102,8 +116,21 @@ sub compare { return -1; } +sub cmp; *cmp = \&compare; +sub compare_text { + my ($from,$to,$cmp) = @_; + croak("Usage: compare_text( file1, file2 [, cmp-function])") + unless @_ == 2 || @_ == 3; + croak("Third arg to compare_text() function must be a code reference") + if @_ == 3 && ref($cmp) ne 'CODE'; + + # Using a negative buffer size puts compare into text_mode too + $cmp = -1 unless defined $cmp; + compare($from, $to, $cmp); +} + 1; __END__ @@ -129,6 +156,18 @@ from File::Compare by default. File::Compare::cmp is a synonym for File::Compare::compare. It is exported from File::Compare only by request. +File::Compare::compare_text does a line by line comparison of the two +files. It stops as soon as a difference is detected. compare_text() +accepts an optional third argument: This must be a CODE reference to +a line comparison function, which returns 0 when both lines are considered +equal. For example: + + compare_text($file1, $file2) + +is basically equivalent to + + compare_text($file1, $file2, sub {$_[0] ne $_[1]} ) + =head1 RETURN File::Compare::compare return 0 if the files are equal, 1 if the diff --git a/contrib/perl5/lib/File/Copy.pm b/contrib/perl5/lib/File/Copy.pm index e1da6b6..e6cf786 100644 --- a/contrib/perl5/lib/File/Copy.pm +++ b/contrib/perl5/lib/File/Copy.pm @@ -7,17 +7,21 @@ package File::Copy; +use 5.005_64; use strict; use Carp; -use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION $Too_Big - © &syscopy &cp &mv); +our(@ISA, @EXPORT, @EXPORT_OK, $VERSION, $Too_Big, $Syscopy_is_copy); +sub copy; +sub syscopy; +sub cp; +sub mv; # Note that this module implements only *part* of the API defined by # the File/Copy.pm module of the File-Tools-2.0 package. However, that # package has not yet been updated to work with Perl 5.004, and so it # would be a Bad Thing for the CPAN module to grab it and replace this # module. Therefore, we set this module's version higher than 2.0. -$VERSION = '2.02'; +$VERSION = '2.03'; require Exporter; @ISA = qw(Exporter); @@ -60,11 +64,12 @@ sub copy { $to = _catname($from, $to); } - if (defined &syscopy && \&syscopy != \© + if (defined &syscopy && !$Syscopy_is_copy && !$to_a_handle && !($from_a_handle && $^O eq 'os2' ) # OS/2 cannot handle handles && !($from_a_handle && $^O eq 'mpeix') # and neither can MPE/iX. - ) + && !($from_a_handle && $^O eq 'MSWin32') + ) { return syscopy($from, $to); } @@ -78,20 +83,20 @@ sub copy { if ($from_a_handle) { *FROM = *$from{FILEHANDLE}; } else { - $from = "./$from" if $from =~ /^\s/; + $from = "./$from" if $from =~ /^\s/s; open(FROM, "< $from\0") or goto fail_open1; binmode FROM or die "($!,$^E)"; $closefrom = 1; - } - + } + if ($to_a_handle) { *TO = *$to{FILEHANDLE}; - } else { - $to = "./$to" if $to =~ /^\s/; + } else { + $to = "./$to" if $to =~ /^\s/s; open(TO,"> $to\0") or goto fail_open2; binmode TO or die "($!,$^E)"; $closeto = 1; - } + } if (@_) { $size = shift(@_) + 0; @@ -119,7 +124,7 @@ sub copy { # Use this idiom to avoid uninitialized value warning. return 1; - + # All of these contortions try to preserve error messages... fail_inner: if ($closeto) { @@ -162,10 +167,10 @@ sub move { (($tosz2,$tomt2) = (stat($to))[7,9]) && # $to's there ($tosz1 != $tosz2 or $tomt1 != $tomt2) && # and changed $tosz2 == $fromsz; # it's all there - + ($tosz1,$tomt1) = (stat($to))[7,9]; # just in case rename did something return 1 if ($copied = copy($from,$to)) && unlink($from); - + ($tosz2,$tomt2) = ((stat($to))[7,9],0,0) if defined $tomt1; unlink($to) if !defined($tomt1) or $tomt1 != $tomt2 or $tosz1 != $tosz2; ($!,$^E) = ($sts,$ossts); @@ -186,7 +191,13 @@ unless (defined &syscopy) { # preserve MPE file attributes. return system('/bin/cp', '-f', $_[0], $_[1]) == 0; }; + } elsif ($^O eq 'MSWin32') { + *syscopy = sub { + return 0 unless @_ == 2; + return Win32::CopyFile(@_, 1); + }; } else { + $Syscopy_is_copy = 1; *syscopy = \© } } @@ -272,9 +283,9 @@ second parameter, preserving OS-specific attributes and file structure. For Unix systems, this is equivalent to the simple C<copy> routine. For VMS systems, this calls the C<rmscopy> routine (see below). For OS/2 systems, this calls the C<syscopy> -XSUB directly. +XSUB directly. For Win32 systems, this calls C<Win32::CopyFile>. -=head2 Special behaviour if C<syscopy> is defined (VMS and OS/2) +=head2 Special behaviour if C<syscopy> is defined (OS/2, VMS and Win32) If both arguments to C<copy> are not file handles, then C<copy> will perform a "system copy" of diff --git a/contrib/perl5/lib/File/DosGlob.pm b/contrib/perl5/lib/File/DosGlob.pm index 594ee2e..d7dea7b 100644 --- a/contrib/perl5/lib/File/DosGlob.pm +++ b/contrib/perl5/lib/File/DosGlob.pm @@ -19,13 +19,18 @@ sub doglob { my $sepchr = '/'; next OUTER unless defined $_ and $_ ne ''; # if arg is within quotes strip em and do no globbing - if (/^"(.*)"$/) { + if (/^"(.*)"\z/s) { $_ = $1; if ($cond eq 'd') { push(@retval, $_) if -d $_ } else { push(@retval, $_) if -e $_ } next OUTER; } - if (m|^(.*)([\\/])([^\\/]*)$|) { + # wildcards with a drive prefix such as h:*.pm must be changed + # to h:./*.pm to expand correctly + if (m|^([A-Za-z]:)[^/\\]|s) { + substr($_,0,2) = $1 . "./"; + } + if (m|^(.*)([\\/])([^\\/]*)\z|s) { my $tail; ($head, $sepchr, $tail) = ($1,$2,$3); #print "div: |$head|$sepchr|$tail|\n"; @@ -35,7 +40,7 @@ sub doglob { push(@retval, doglob($cond, map {"$_$sepchr$tail"} @globdirs)), next OUTER if @globdirs; } - $head .= $sepchr if $head eq '' or $head =~ /^[A-Za-z]:$/; + $head .= $sepchr if $head eq '' or $head =~ /^[A-Za-z]:\z/s; $_ = $tail; } # @@ -61,7 +66,7 @@ sub doglob { s/\?/.?/g; #print "regex: '$_', head: '$head'\n"; - my $matchsub = eval 'sub { $_[0] =~ m|^' . $_ . '$|io }'; + my $matchsub = eval 'sub { $_[0] =~ m|^' . $_ . '\\z|ios }'; warn($@), next OUTER if $@; INNER: for my $e (@leaves) { @@ -142,7 +147,7 @@ sub import { my $pkg = shift; return unless @_; my $sym = shift; - my $callpkg = ($sym =~ s/^GLOBAL_// ? 'CORE::GLOBAL' : caller(0)); + my $callpkg = ($sym =~ s/^GLOBAL_//s ? 'CORE::GLOBAL' : caller(0)); *{$callpkg.'::'.$sym} = \&{$pkg.'::'.$sym} if $sym eq 'glob'; } @@ -157,16 +162,16 @@ File::DosGlob - DOS like globbing and then some =head1 SYNOPSIS require 5.004; - + # override CORE::glob in current package use File::DosGlob 'glob'; - + # override CORE::glob in ALL packages (use with extreme caution!) use File::DosGlob 'GLOBAL_glob'; @perlfiles = glob "..\\pe?l/*.p?"; print <..\\pe?l/*.p?>; - + # from the command line (overrides only in main::) > perl -MFile::DosGlob=glob -e "print <../pe*/*p?>" @@ -206,7 +211,7 @@ pandering to DOS habits. Needs a dose of optimizium too. =head1 AUTHOR -Gurusamy Sarathy <gsar@umich.edu> +Gurusamy Sarathy <gsar@activestate.com> =head1 HISTORY diff --git a/contrib/perl5/lib/File/Find.pm b/contrib/perl5/lib/File/Find.pm index 7e67003..ac73f1b 100644 --- a/contrib/perl5/lib/File/Find.pm +++ b/contrib/perl5/lib/File/Find.pm @@ -1,5 +1,5 @@ package File::Find; -require 5.000; +use 5.005_64; require Exporter; require Cwd; @@ -12,70 +12,163 @@ finddepth - traverse a directory structure depth-first =head1 SYNOPSIS use File::Find; - find(\&wanted, '/foo','/bar'); + find(\&wanted, '/foo', '/bar'); sub wanted { ... } use File::Find; - finddepth(\&wanted, '/foo','/bar'); + finddepth(\&wanted, '/foo', '/bar'); sub wanted { ... } + use File::Find; + find({ wanted => \&process, follow => 1 }, '.'); + =head1 DESCRIPTION The first argument to find() is either a hash reference describing the -operations to be performed for each file, a code reference, or a string -that contains a subroutine name. If it is a hash reference, then the -value for the key C<wanted> should be a code reference. This code -reference is called I<the wanted() function> below. +operations to be performed for each file, or a code reference. -Currently the only other supported key for the above hash is -C<bydepth>, in presense of which the walk over directories is -performed depth-first. Entry point finddepth() is a shortcut for -specifying C<{ bydepth => 1}> in the first argument of find(). +Here are the possible keys for the hash: -The wanted() function does whatever verifications you want. -$File::Find::dir contains the current directory name, and $_ the -current filename within that directory. $File::Find::name contains -C<"$File::Find::dir/$_">. You are chdir()'d to $File::Find::dir when -the function is called. The function may set $File::Find::prune to -prune the tree. +=over 3 + +=item C<wanted> + +The value should be a code reference. This code reference is called +I<the wanted() function> below. + +=item C<bydepth> + +Reports the name of a directory only AFTER all its entries +have been reported. Entry point finddepth() is a shortcut for +specifying C<{ bydepth => 1 }> in the first argument of find(). + +=item C<follow> + +Causes symbolic links to be followed. Since directory trees with symbolic +links (followed) may contain files more than once and may even have +cycles, a hash has to be built up with an entry for each file. +This might be expensive both in space and time for a large +directory tree. See I<follow_fast> and I<follow_skip> below. +If either I<follow> or I<follow_fast> is in effect: + +=over 6 + +=item * + +It is guarantueed that an I<lstat> has been called before the user's +I<wanted()> function is called. This enables fast file checks involving S< _>. + +=item * + +There is a variable C<$File::Find::fullname> which holds the absolute +pathname of the file with all symbolic links resolved + +=back + +=item C<follow_fast> + +This is similar to I<follow> except that it may report some files +more than once. It does detect cycles however. +Since only symbolic links have to be hashed, this is +much cheaper both in space and time. +If processing a file more than once (by the user's I<wanted()> function) +is worse than just taking time, the option I<follow> should be used. + +=item C<follow_skip> + +C<follow_skip==1>, which is the default, causes all files which are +neither directories nor symbolic links to be ignored if they are about +to be processed a second time. If a directory or a symbolic link +are about to be processed a second time, File::Find dies. +C<follow_skip==0> causes File::Find to die if any file is about to be +processed a second time. +C<follow_skip==2> causes File::Find to ignore any duplicate files and +dirctories but to proceed normally otherwise. -File::Find assumes that you don't alter the $_ variable. If you do then -make sure you return it to its original value before exiting your function. + +=item C<no_chdir> + +Does not C<chdir()> to each directory as it recurses. The wanted() +function will need to be aware of this, of course. In this case, +C<$_> will be the same as C<$File::Find::name>. + +=item C<untaint> + +If find is used in taint-mode (-T command line switch or if EUID != UID +or if EGID != GID) then internally directory names have to be untainted +before they can be cd'ed to. Therefore they are checked against a regular +expression I<untaint_pattern>. Note, that all names passed to the +user's I<wanted()> function are still tainted. + +=item C<untaint_pattern> + +See above. This should be set using the C<qr> quoting operator. +The default is set to C<qr|^([-+@\w./]+)$|>. +Note that the paranthesis which are vital. + +=item C<untaint_skip> + +If set, directories (subtrees) which fail the I<untaint_pattern> +are skipped. The default is to 'die' in such a case. + +=back + +The wanted() function does whatever verifications you want. +C<$File::Find::dir> contains the current directory name, and C<$_> the +current filename within that directory. C<$File::Find::name> contains +the complete pathname to the file. You are chdir()'d to C<$File::Find::dir> when +the function is called, unless C<no_chdir> was specified. +When <follow> or <follow_fast> are in effect there is also a +C<$File::Find::fullname>. +The function may set C<$File::Find::prune> to prune the tree +unless C<bydepth> was specified. +Unless C<follow> or C<follow_fast> is specified, for compatibility +reasons (find.pl, find2perl) there are in addition the following globals +available: C<$File::Find::topdir>, C<$File::Find::topdev>, C<$File::Find::topino>, +C<$File::Find::topmode> and C<$File::Find::topnlink>. This library is useful for the C<find2perl> tool, which when fed, find2perl / -name .nfs\* -mtime +7 \ - -exec rm -f {} \; -o -fstype nfs -prune + -exec rm -f {} \; -o -fstype nfs -prune produces something like: sub wanted { - /^\.nfs.*$/ && - (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_)) && + /^\.nfs.*\z/s && + (($dev, $ino, $mode, $nlink, $uid, $gid) = lstat($_)) && int(-M _) > 7 && unlink($_) || - ($nlink || (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_))) && + ($nlink || (($dev, $ino, $mode, $nlink, $uid, $gid) = lstat($_))) && $dev < 0 && ($File::Find::prune = 1); } -Set the variable $File::Find::dont_use_nlink if you're using AFS, +Set the variable C<$File::Find::dont_use_nlink> if you're using AFS, since AFS cheats. -C<finddepth> is just like C<find>, except that it does a depth-first -search. Here's another interesting wanted function. It will find all symlinks that don't resolve: sub wanted { - -l && !-e && print "bogus link: $File::Find::name\n"; + -l && !-e && print "bogus link: $File::Find::name\n"; } -=head1 BUGS +See also the script C<pfind> on CPAN for a nice application of this +module. + +=head1 CAVEAT + +Be aware that the option to follow symblic links can be dangerous. +Depending on the structure of the directory tree (including symbolic +links to directories) you might traverse a given (physical) directory +more than once (only if C<follow_fast> is in effect). +Furthermore, deleting or changing files in a symbolically linked directory +might cause very unpleasant surprises, since you delete or change files +in an unknown directory. -There is no way to make find or finddepth follow symlinks. =cut @@ -83,150 +176,560 @@ There is no way to make find or finddepth follow symlinks. @EXPORT = qw(find finddepth); -sub find_opt { +use strict; +my $Is_VMS; + +require File::Basename; + +my %SLnkSeen; +my ($wanted_callback, $avoid_nlink, $bydepth, $no_chdir, $follow, + $follow_skip, $full_check, $untaint, $untaint_skip, $untaint_pat); + +sub contract_name { + my ($cdir,$fn) = @_; + + return substr($cdir,0,rindex($cdir,'/')) if $fn eq '.'; + + $cdir = substr($cdir,0,rindex($cdir,'/')+1); + + $fn =~ s|^\./||; + + my $abs_name= $cdir . $fn; + + if (substr($fn,0,3) eq '../') { + do 1 while ($abs_name=~ s|/(?>[^/]+)/\.\./|/|); + } + + return $abs_name; +} + + +sub PathCombine($$) { + my ($Base,$Name) = @_; + my $AbsName; + + if (substr($Name,0,1) eq '/') { + $AbsName= $Name; + } + else { + $AbsName= contract_name($Base,$Name); + } + + # (simple) check for recursion + my $newlen= length($AbsName); + if ($newlen <= length($Base)) { + if (($newlen == length($Base) || substr($Base,$newlen,1) eq '/') + && $AbsName eq substr($Base,0,$newlen)) + { + return undef; + } + } + return $AbsName; +} + +sub Follow_SymLink($) { + my ($AbsName) = @_; + + my ($NewName,$DEV, $INO); + ($DEV, $INO)= lstat $AbsName; + + while (-l _) { + if ($SLnkSeen{$DEV, $INO}++) { + if ($follow_skip < 2) { + die "$AbsName is encountered a second time"; + } + else { + return undef; + } + } + $NewName= PathCombine($AbsName, readlink($AbsName)); + unless(defined $NewName) { + if ($follow_skip < 2) { + die "$AbsName is a recursive symbolic link"; + } + else { + return undef; + } + } + else { + $AbsName= $NewName; + } + ($DEV, $INO) = lstat($AbsName); + return undef unless defined $DEV; # dangling symbolic link + } + + if ($full_check && $SLnkSeen{$DEV, $INO}++) { + if ($follow_skip < 1) { + die "$AbsName encountered a second time"; + } + else { + return undef; + } + } + + return $AbsName; +} + +our($dir, $name, $fullname, $prune); +sub _find_dir_symlnk($$$); +sub _find_dir($$$); + +sub _find_opt { my $wanted = shift; - my $bydepth = $wanted->{bydepth}; - my $cwd = $bydepth ? Cwd::fastcwd() : Cwd::cwd(); - # Localize these rather than lexicalizing them for backwards - # compatibility. - local($topdir,$topdev,$topino,$topmode,$topnlink); - foreach $topdir (@_) { - (($topdev,$topino,$topmode,$topnlink) = - ($Is_VMS ? stat($topdir) : lstat($topdir))) - || (warn("Can't stat $topdir: $!\n"), next); - if (-d _) { - if (chdir($topdir)) { - $prune = 0; - unless ($bydepth) { - ($dir,$_) = ($topdir,'.'); - $name = $topdir; - $wanted->{wanted}->(); + die "invalid top directory" unless defined $_[0]; + + my $cwd = $wanted->{bydepth} ? Cwd::fastcwd() : Cwd::cwd(); + my $cwd_untainted = $cwd; + $wanted_callback = $wanted->{wanted}; + $bydepth = $wanted->{bydepth}; + $no_chdir = $wanted->{no_chdir}; + $full_check = $wanted->{follow}; + $follow = $full_check || $wanted->{follow_fast}; + $follow_skip = $wanted->{follow_skip}; + $untaint = $wanted->{untaint}; + $untaint_pat = $wanted->{untaint_pattern}; + $untaint_skip = $wanted->{untaint_skip}; + + # for compatability reasons (find.pl, find2perl) + our ($topdir, $topdev, $topino, $topmode, $topnlink); + + # a symbolic link to a directory doesn't increase the link count + $avoid_nlink = $follow || $File::Find::dont_use_nlink; + + if ( $untaint ) { + $cwd_untainted= $1 if $cwd_untainted =~ m|$untaint_pat|; + die "insecure cwd in find(depth)" unless defined($cwd_untainted); + } + + my ($abs_dir, $Is_Dir); + + Proc_Top_Item: + foreach my $TOP (@_) { + my $top_item = $TOP; + $top_item =~ s|/\z|| unless $top_item eq '/'; + $Is_Dir= 0; + + ($topdev,$topino,$topmode,$topnlink) = stat $top_item; + + if ($follow) { + if (substr($top_item,0,1) eq '/') { + $abs_dir = $top_item; + } + elsif ($top_item eq '.') { + $abs_dir = $cwd; + } + else { # care about any ../ + $abs_dir = contract_name("$cwd/",$top_item); + } + $abs_dir= Follow_SymLink($abs_dir); + unless (defined $abs_dir) { + warn "$top_item is a dangling symbolic link\n"; + next Proc_Top_Item; + } + if (-d _) { + _find_dir_symlnk($wanted, $abs_dir, $top_item); + $Is_Dir= 1; + } + } + else { # no follow + $topdir = $top_item; + unless (defined $topnlink) { + warn "Can't stat $top_item: $!\n"; + next Proc_Top_Item; + } + if (-d _) { + $top_item =~ s/\.dir\z// if $Is_VMS; + _find_dir($wanted, $top_item, $topnlink); + $Is_Dir= 1; + } + else { + $abs_dir= $top_item; + } + } + + unless ($Is_Dir) { + unless (($_,$dir) = File::Basename::fileparse($abs_dir)) { + ($dir,$_) = ('./', $top_item); + } + + $abs_dir = $dir; + if ($untaint) { + my $abs_dir_save = $abs_dir; + $abs_dir = $1 if $abs_dir =~ m|$untaint_pat|; + unless (defined $abs_dir) { + if ($untaint_skip == 0) { + die "directory $abs_dir_save is still tainted"; + } + else { + next Proc_Top_Item; + } } - next if $prune; - my $fixtopdir = $topdir; - $fixtopdir =~ s,/$,, ; - $fixtopdir =~ s/\.dir$// if $Is_VMS; - &finddir($wanted,$fixtopdir,$topnlink, $bydepth); - if ($bydepth) { - ($dir,$_) = ($fixtopdir,'.'); - $name = $fixtopdir; - $wanted->{wanted}->(); + } + + unless ($no_chdir or chdir $abs_dir) { + warn "Couldn't chdir $abs_dir: $!\n"; + next Proc_Top_Item; + } + + $name = $abs_dir . $_; + + &$wanted_callback; + + } + + $no_chdir or chdir $cwd_untainted; + } +} + +# API: +# $wanted +# $p_dir : "parent directory" +# $nlink : what came back from the stat +# preconditions: +# chdir (if not no_chdir) to dir + +sub _find_dir($$$) { + my ($wanted, $p_dir, $nlink) = @_; + my ($CdLvl,$Level) = (0,0); + my @Stack; + my @filenames; + my ($subcount,$sub_nlink); + my $SE= []; + my $dir_name= $p_dir; + my $dir_pref= ( $p_dir eq '/' ? '/' : "$p_dir/" ); + my $dir_rel= '.'; # directory name relative to current directory + + local ($dir, $name, $prune, *DIR); + + unless ($no_chdir or $p_dir eq '.') { + my $udir = $p_dir; + if ($untaint) { + $udir = $1 if $p_dir =~ m|$untaint_pat|; + unless (defined $udir) { + if ($untaint_skip == 0) { + die "directory $p_dir is still tainted"; + } + else { + return; } } - else { - warn "Can't cd to $topdir: $!\n"; + } + unless (chdir $udir) { + warn "Can't cd to $udir: $!\n"; + return; + } + } + + push @Stack,[$CdLvl,$p_dir,$dir_rel,-1] if $bydepth; + + while (defined $SE) { + unless ($bydepth) { + $dir= $p_dir; + $name= $dir_name; + $_= ($no_chdir ? $dir_name : $dir_rel ); + # prune may happen here + $prune= 0; + &$wanted_callback; + next if $prune; + } + + # change to that directory + unless ($no_chdir or $dir_rel eq '.') { + my $udir= $dir_rel; + if ($untaint) { + $udir = $1 if $dir_rel =~ m|$untaint_pat|; + unless (defined $udir) { + if ($untaint_skip == 0) { + die "directory (" + . ($p_dir ne '/' ? $p_dir : '') + . "/) $dir_rel is still tainted"; + } + } + } + unless (chdir $udir) { + warn "Can't cd to (" + . ($p_dir ne '/' ? $p_dir : '') + . "/) $udir : $!\n"; + next; } + $CdLvl++; } - else { - require File::Basename; - unless (($_,$dir) = File::Basename::fileparse($topdir)) { - ($dir,$_) = ('.', $topdir); + + $dir= $dir_name; + + # Get the list of files in the current directory. + unless (opendir DIR, ($no_chdir ? $dir_name : '.')) { + warn "Can't opendir($dir_name): $!\n"; + next; + } + @filenames = readdir DIR; + closedir(DIR); + + if ($nlink == 2 && !$avoid_nlink) { + # This dir has no subdirectories. + for my $FN (@filenames) { + next if $FN =~ /^\.{1,2}\z/; + + $name = $dir_pref . $FN; + $_ = ($no_chdir ? $name : $FN); + &$wanted_callback; } - if (chdir($dir)) { - $name = $topdir; - $wanted->{wanted}->(); + + } + else { + # This dir has subdirectories. + $subcount = $nlink - 2; + + for my $FN (@filenames) { + next if $FN =~ /^\.{1,2}\z/; + if ($subcount > 0 || $avoid_nlink) { + # Seen all the subdirs? + # check for directoriness. + # stat is faster for a file in the current directory + $sub_nlink = (lstat ($no_chdir ? $dir_pref . $FN : $FN))[3]; + + if (-d _) { + --$subcount; + $FN =~ s/\.dir\z// if $Is_VMS; + push @Stack,[$CdLvl,$dir_name,$FN,$sub_nlink]; + } + else { + $name = $dir_pref . $FN; + $_= ($no_chdir ? $name : $FN); + &$wanted_callback; + } + } + else { + $name = $dir_pref . $FN; + $_= ($no_chdir ? $name : $FN); + &$wanted_callback; + } } - else { - warn "Can't cd to $dir: $!\n"; + } + } + continue { + while ( defined ($SE = pop @Stack) ) { + ($Level, $p_dir, $dir_rel, $nlink) = @$SE; + if ($CdLvl > $Level && !$no_chdir) { + my $tmp = join('/',('..') x ($CdLvl-$Level)); + die "Can't cd to $dir_name" . $tmp + unless chdir ($tmp); + $CdLvl = $Level; } + $dir_name = ($p_dir eq '/' ? "/$dir_rel" : "$p_dir/$dir_rel"); + $dir_pref = "$dir_name/"; + if ( $nlink < 0 ) { # must be finddepth, report dirname now + $name = $dir_name; + if ( substr($name,-2) eq '/.' ) { + $name =~ s|/\.$||; + } + $dir = $p_dir; + $_ = ($no_chdir ? $dir_name : $dir_rel ); + if ( substr($_,-2) eq '/.' ) { + s|/\.$||; + } + &$wanted_callback; + } else { + push @Stack,[$CdLvl,$p_dir,$dir_rel,-1] if $bydepth; + last; + } } - chdir $cwd; } } -sub finddir { - my($wanted, $nlink, $bydepth); - local($dir, $name); - ($wanted, $dir, $nlink, $bydepth) = @_; - - my($dev, $ino, $mode, $subcount); - - # Get the list of files in the current directory. - opendir(DIR,'.') || (warn("Can't open $dir: $!\n"), $bydepth || return); - my(@filenames) = readdir(DIR); - closedir(DIR); - - if ($nlink == 2 && !$dont_use_nlink) { # This dir has no subdirectories. - for (@filenames) { - next if $_ eq '.'; - next if $_ eq '..'; - $name = "$dir/$_"; - $nlink = 0; - $wanted->{wanted}->(); - } - } - else { # This dir has subdirectories. - $subcount = $nlink - 2; - for (@filenames) { - next if $_ eq '.'; - next if $_ eq '..'; - $nlink = 0; - $prune = 0 unless $bydepth; - $name = "$dir/$_"; - $wanted->{wanted}->() unless $bydepth; - if ($subcount > 0 || $dont_use_nlink) { # Seen all the subdirs? - - # Get link count and check for directoriness. - - ($dev,$ino,$mode,$nlink) = ($Is_VMS ? stat($_) : lstat($_)); - # unless ($nlink || $dont_use_nlink); - - if (-d _) { - - # It really is a directory, so do it recursively. - - --$subcount; - next if $prune; - # Untaint $_, so that we can do a chdir - $_ = $1 if /^(.*)/; - if (chdir $_) { - $name =~ s/\.dir$// if $Is_VMS; - &finddir($wanted,$name,$nlink, $bydepth); - chdir '..'; + +# API: +# $wanted +# $dir_loc : absolute location of a dir +# $p_dir : "parent directory" +# preconditions: +# chdir (if not no_chdir) to dir + +sub _find_dir_symlnk($$$) { + my ($wanted, $dir_loc, $p_dir) = @_; + my @Stack; + my @filenames; + my $new_loc; + my $pdir_loc = $dir_loc; + my $SE = []; + my $dir_name = $p_dir; + my $dir_pref = ( $p_dir eq '/' ? '/' : "$p_dir/" ); + my $loc_pref = ( $dir_loc eq '/' ? '/' : "$dir_loc/" ); + my $dir_rel = '.'; # directory name relative to current directory + my $byd_flag; # flag for pending stack entry if $bydepth + + local ($dir, $name, $fullname, $prune, *DIR); + + unless ($no_chdir or $p_dir eq '.') { + my $udir = $dir_loc; + if ($untaint) { + $udir = $1 if $dir_loc =~ m|$untaint_pat|; + unless (defined $udir) { + if ($untaint_skip == 0) { + die "directory $dir_loc is still tainted"; + } + else { + return; + } + } + } + unless (chdir $udir) { + warn "Can't cd to $udir: $!\n"; + return; + } + } + + push @Stack,[$dir_loc,$pdir_loc,$p_dir,$dir_rel,-1] if $bydepth; + + while (defined $SE) { + + unless ($bydepth) { + $dir= $p_dir; + $name= $dir_name; + $_= ($no_chdir ? $dir_name : $dir_rel ); + $fullname= $dir_loc; + # prune may happen here + $prune= 0; + &$wanted_callback; + next if $prune; + } + + # change to that directory + unless ($no_chdir or $dir_rel eq '.') { + my $udir = $dir_loc; + if ($untaint) { + $udir = $1 if $dir_loc =~ m|$untaint_pat|; + unless (defined $udir ) { + if ($untaint_skip == 0) { + die "directory $dir_loc is still tainted"; } else { - warn "Can't cd to $_: $!\n"; + next; } } } - $wanted->{wanted}->() if $bydepth; + unless (chdir $udir) { + warn "Can't cd to $udir: $!\n"; + next; + } + } + + $dir = $dir_name; + + # Get the list of files in the current directory. + unless (opendir DIR, ($no_chdir ? $dir_loc : '.')) { + warn "Can't opendir($dir_loc): $!\n"; + next; + } + @filenames = readdir DIR; + closedir(DIR); + + for my $FN (@filenames) { + next if $FN =~ /^\.{1,2}\z/; + + # follow symbolic links / do an lstat + $new_loc = Follow_SymLink($loc_pref.$FN); + + # ignore if invalid symlink + next unless defined $new_loc; + + if (-d _) { + push @Stack,[$new_loc,$dir_loc,$dir_name,$FN,1]; + } + else { + $fullname = $new_loc; + $name = $dir_pref . $FN; + $_ = ($no_chdir ? $name : $FN); + &$wanted_callback; + } + } + + } + continue { + while (defined($SE = pop @Stack)) { + ($dir_loc, $pdir_loc, $p_dir, $dir_rel, $byd_flag) = @$SE; + $dir_name = ($p_dir eq '/' ? "/$dir_rel" : "$p_dir/$dir_rel"); + $dir_pref = "$dir_name/"; + $loc_pref = "$dir_loc/"; + if ( $byd_flag < 0 ) { # must be finddepth, report dirname now + unless ($no_chdir or $dir_rel eq '.') { + my $udir = $pdir_loc; + if ($untaint) { + $udir = $1 if $dir_loc =~ m|$untaint_pat|; + } + unless (chdir $udir) { + warn "Can't cd to $udir: $!\n"; + next; + } + } + $fullname = $dir_loc; + $name = $dir_name; + if ( substr($name,-2) eq '/.' ) { + $name =~ s|/\.$||; + } + $dir = $p_dir; + $_ = ($no_chdir ? $dir_name : $dir_rel); + if ( substr($_,-2) eq '/.' ) { + s|/\.$||; + } + + &$wanted_callback; + } else { + push @Stack,[$dir_loc, $pdir_loc, $p_dir, $dir_rel,-1] if $bydepth; + last; + } } } } + sub wrap_wanted { - my $wanted = shift; - ref($wanted) eq 'HASH' ? $wanted : { wanted => $wanted }; + my $wanted = shift; + if ( ref($wanted) eq 'HASH' ) { + if ( $wanted->{follow} || $wanted->{follow_fast}) { + $wanted->{follow_skip} = 1 unless defined $wanted->{follow_skip}; + } + if ( $wanted->{untaint} ) { + $wanted->{untaint_pattern} = qr|^([-+@\w./]+)$| + unless defined $wanted->{untaint_pattern}; + $wanted->{untaint_skip} = 0 unless defined $wanted->{untaint_skip}; + } + return $wanted; + } + else { + return { wanted => $wanted }; + } } sub find { - my $wanted = shift; - find_opt(wrap_wanted($wanted), @_); + my $wanted = shift; + _find_opt(wrap_wanted($wanted), @_); + %SLnkSeen= (); # free memory } sub finddepth { - my $wanted = wrap_wanted(shift); - $wanted->{bydepth} = 1; - find_opt($wanted, @_); + my $wanted = wrap_wanted(shift); + $wanted->{bydepth} = 1; + _find_opt($wanted, @_); + %SLnkSeen= (); # free memory } # These are hard-coded for now, but may move to hint files. if ($^O eq 'VMS') { - $Is_VMS = 1; - $dont_use_nlink = 1; + $Is_VMS = 1; + $File::Find::dont_use_nlink = 1; } -$dont_use_nlink = 1 +$File::Find::dont_use_nlink = 1 if $^O eq 'os2' || $^O eq 'dos' || $^O eq 'amigaos' || $^O eq 'MSWin32'; # Set dont_use_nlink in your hint file if your system's stat doesn't # report the number of links in a directory as an indication # of the number of files. # See, e.g. hints/machten.sh for MachTen 2.2. -unless ($dont_use_nlink) { - require Config; - $dont_use_nlink = 1 if ($Config::Config{'dont_use_nlink'}); +unless ($File::Find::dont_use_nlink) { + require Config; + $File::Find::dont_use_nlink = 1 if ($Config::Config{'dont_use_nlink'}); } 1; - diff --git a/contrib/perl5/lib/File/Path.pm b/contrib/perl5/lib/File/Path.pm index 225ecab..46f360a 100644 --- a/contrib/perl5/lib/File/Path.pm +++ b/contrib/perl5/lib/File/Path.pm @@ -2,15 +2,14 @@ package File::Path; =head1 NAME -File::Path - create or remove a series of directories +File::Path - create or remove directory trees =head1 SYNOPSIS -C<use File::Path> + use File::Path; -C<mkpath(['/foo/bar/baz', 'blurfl/quux'], 1, 0711);> - -C<rmtree(['foo/bar/baz', 'blurfl/quux'], 1, 1);> + mkpath(['/foo/bar/baz', 'blurfl/quux'], 1, 0711); + rmtree(['foo/bar/baz', 'blurfl/quux'], 1, 1); =head1 DESCRIPTION @@ -74,7 +73,7 @@ than VMS is settled. (defaults to FALSE) =back It returns the number of files successfully deleted. Symlinks are -treated as ordinary files. +simply deleted and not followed. B<NOTE:> If the third parameter is not TRUE, C<rmtree> is B<unsecure> in the face of failure or interruption. Files and directories which @@ -90,22 +89,17 @@ in situations where security is an issue. Tim Bunce <F<Tim.Bunce@ig.co.uk>> and Charles Bailey <F<bailey@newman.upenn.edu>> -=head1 REVISION - -Current $VERSION is 1.0401. - =cut +use 5.005_64; use Carp; use File::Basename (); -use DirHandle (); use Exporter (); use strict; -use vars qw( $VERSION @ISA @EXPORT ); -$VERSION = "1.0401"; -@ISA = qw( Exporter ); -@EXPORT = qw( mkpath rmtree ); +our $VERSION = "1.0403"; +our @ISA = qw( Exporter ); +our @EXPORT = qw( mkpath rmtree ); my $Is_VMS = $^O eq 'VMS'; @@ -124,20 +118,22 @@ sub mkpath { $paths = [$paths] unless ref $paths; my(@created,$path); foreach $path (@$paths) { - $path .= '/' if $^O eq 'os2' and $path =~ /^\w:$/; # feature of CRT + $path .= '/' if $^O eq 'os2' and $path =~ /^\w:\z/s; # feature of CRT next if -d $path; # Logic wants Unix paths, so go with the flow. $path = VMS::Filespec::unixify($path) if $Is_VMS; my $parent = File::Basename::dirname($path); # Allow for creation of new logical filesystems under VMS if (not $Is_VMS or $parent !~ m:/[^/]+/000000/?:) { - push(@created,mkpath($parent, $verbose, $mode)) unless (-d $parent); + unless (-d $parent or $path eq $parent) { + push(@created,mkpath($parent, $verbose, $mode)); + } } print "mkdir $path\n" if $verbose; unless (mkdir($path,$mode)) { - my $e = $!; - # allow for another process to have created it meanwhile - croak "mkdir $path: $e" unless -d $path; + my $e = $!; + # allow for another process to have created it meanwhile + croak "mkdir $path: $e" unless -d $path; } push(@created, $path); } @@ -148,13 +144,20 @@ sub rmtree { my($roots, $verbose, $safe) = @_; my(@files); my($count) = 0; - $roots = [$roots] unless ref $roots; $verbose ||= 0; $safe ||= 0; + if ( defined($roots) && length($roots) ) { + $roots = [$roots] unless ref $roots; + } + else { + carp "No root path(s) specified\n"; + return 0; + } + my($root); foreach $root (@{$roots}) { - $root =~ s#/$##; + $root =~ s#/\z##; (undef, undef, my $rp) = lstat $root or next; $rp &= 07777; # don't forget setuid, setgid, sticky bits if ( -d _ ) { @@ -166,16 +169,20 @@ sub rmtree { or carp "Can't make directory $root read+writeable: $!" unless $safe; - my $d = DirHandle->new($root) - or carp "Can't read $root: $!"; - @files = $d->read; - $d->close; + if (opendir my $d, $root) { + @files = readdir $d; + closedir $d; + } + else { + carp "Can't read $root: $!"; + @files = (); + } # Deleting large numbers of files from VMS Files-11 filesystems # is faster if done in reverse ASCIIbetical order @files = reverse @files if $Is_VMS; - ($root = VMS::Filespec::unixify($root)) =~ s#\.dir$## if $Is_VMS; - @files = map("$root/$_", grep $_!~/^\.{1,2}$/,@files); + ($root = VMS::Filespec::unixify($root)) =~ s#\.dir\z## if $Is_VMS; + @files = map("$root/$_", grep $_!~/^\.{1,2}\z/s,@files); $count += rmtree(\@files,$verbose,$safe); if ($safe && ($Is_VMS ? !&VMS::Filespec::candelete($root) : !-w $root)) { @@ -198,7 +205,9 @@ sub rmtree { } else { if ($safe && - ($Is_VMS ? !&VMS::Filespec::candelete($root) : !-w $root)) { + ($Is_VMS ? !&VMS::Filespec::candelete($root) + : !(-l $root || -w $root))) + { print "skipped $root\n" if $verbose; next; } diff --git a/contrib/perl5/lib/File/Spec.pm b/contrib/perl5/lib/File/Spec.pm index 616dcbc..40f5345 100644 --- a/contrib/perl5/lib/File/Spec.pm +++ b/contrib/perl5/lib/File/Spec.pm @@ -1,47 +1,18 @@ package File::Spec; -require Exporter; - -@ISA = qw(Exporter); -# Items to export into callers namespace by default. Note: do not export -# names by default without a very good reason. Use EXPORT_OK instead. -# Do not simply export all your public functions/methods/constants. -@EXPORT = qw( - -); -@EXPORT_OK = qw($Verbose); - use strict; -use vars qw(@ISA $VERSION $Verbose); - -$VERSION = '0.6'; - -$Verbose = 0; +use vars qw(@ISA $VERSION); -require File::Spec::Unix; +$VERSION = '0.8'; +my %module = (MacOS => 'Mac', + MSWin32 => 'Win32', + os2 => 'OS2', + VMS => 'VMS'); -sub load { - my($class,$OS) = @_; - if ($OS eq 'VMS') { - require File::Spec::VMS; - require VMS::Filespec; - 'File::Spec::VMS' - } elsif ($OS eq 'os2') { - require File::Spec::OS2; - 'File::Spec::OS2' - } elsif ($OS eq 'MacOS') { - require File::Spec::Mac; - 'File::Spec::Mac' - } elsif ($OS eq 'MSWin32') { - require File::Spec::Win32; - 'File::Spec::Win32' - } else { - 'File::Spec::Unix' - } -} - -@ISA = load('File::Spec', $^O); +my $module = $module{$^O} || 'Unix'; +require "File/Spec/$module.pm"; +@ISA = ("File::Spec::$module"); 1; __END__ @@ -52,11 +23,15 @@ File::Spec - portably perform operations on file names =head1 SYNOPSIS -C<use File::Spec;> + use File::Spec; + + $x=File::Spec->catfile('a', 'b', 'c'); + +which returns 'a/b/c' under Unix. Or: -C<$x=File::Spec-E<gt>catfile('a','b','c');> + use File::Spec::Functions; -which returns 'a/b/c' under Unix. + $x = catfile('a', 'b', 'c'); =head1 DESCRIPTION @@ -78,28 +53,31 @@ OS specific routines is available in a separate module, including: File::Spec::VMS The module appropriate for the current OS is automatically loaded by -File::Spec. Since some modules (like VMS) make use of OS specific -facilities, it may not be possible to load all modules under all operating -systems. +File::Spec. Since some modules (like VMS) make use of facilities available +only under that OS, it may not be possible to load all modules under all +operating systems. Since File::Spec is object oriented, subroutines should not called directly, as in: File::Spec::catfile('a','b'); - + but rather as class methods: File::Spec->catfile('a','b'); -For a reference of available functions, please consult L<File::Spec::Unix>, -which contains the entire set, and inherited by the modules for other -platforms. For further information, please see L<File::Spec::Mac>, +For simple uses, L<File::Spec::Functions> provides convenient functional +forms of these methods. + +For a list of available methods, please consult L<File::Spec::Unix>, +which contains the entire set, and which is inherited by the modules for +other platforms. For further information, please see L<File::Spec::Mac>, L<File::Spec::OS2>, L<File::Spec::Win32>, or L<File::Spec::VMS>. =head1 SEE ALSO File::Spec::Unix, File::Spec::Mac, File::Spec::OS2, File::Spec::Win32, -File::Spec::VMS, ExtUtils::MakeMaker +File::Spec::VMS, File::Spec::Functions, ExtUtils::MakeMaker =head1 AUTHORS @@ -108,9 +86,7 @@ Kenneth Albanowski <F<kjahds@kjahds.com>>, Andy Dougherty <F<A.Koenig@franz.ww.TU-Berlin.DE>>, Tim Bunce <F<Tim.Bunce@ig.co.uk>>. VMS support by Charles Bailey <F<bailey@newman.upenn.edu>>. OS/2 support by Ilya Zakharevich <F<ilya@math.ohio-state.edu>>. Mac support by Paul Schinder -<F<schinder@pobox.com>>. - -=cut - - -1; +<F<schinder@pobox.com>>. abs2rel() and rel2abs() written by +Shigio Yamaguchi <F<shigio@tamacom.com>>, modified by Barrie Slaymaker +<F<barries@slaysys.com>>. splitpath(), splitdir(), catpath() and catdir() +by Barrie Slaymaker. diff --git a/contrib/perl5/lib/File/Spec/Functions.pm b/contrib/perl5/lib/File/Spec/Functions.pm new file mode 100644 index 0000000..140738f --- /dev/null +++ b/contrib/perl5/lib/File/Spec/Functions.pm @@ -0,0 +1,95 @@ +package File::Spec::Functions; + +use File::Spec; +use strict; + +use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); + +require Exporter; + +@ISA = qw(Exporter); + +@EXPORT = qw( + canonpath + catdir + catfile + curdir + rootdir + updir + no_upwards + file_name_is_absolute + path +); + +@EXPORT_OK = qw( + devnull + tmpdir + splitpath + splitdir + catpath + abs2rel + rel2abs +); + +%EXPORT_TAGS = ( ALL => [ @EXPORT_OK, @EXPORT ] ); + +foreach my $meth (@EXPORT, @EXPORT_OK) { + my $sub = File::Spec->can($meth); + no strict 'refs'; + *{$meth} = sub {&$sub('File::Spec', @_)}; +} + + +1; +__END__ + +=head1 NAME + +File::Spec::Functions - portably perform operations on file names + +=head1 SYNOPSIS + + use File::Spec::Functions; + $x = catfile('a','b'); + +=head1 DESCRIPTION + +This module exports convenience functions for all of the class methods +provided by File::Spec. + +For a reference of available functions, please consult L<File::Spec::Unix>, +which contains the entire set, and which is inherited by the modules for +other platforms. For further information, please see L<File::Spec::Mac>, +L<File::Spec::OS2>, L<File::Spec::Win32>, or L<File::Spec::VMS>. + +=head2 Exports + +The following functions are exported by default. + + canonpath + catdir + catfile + curdir + rootdir + updir + no_upwards + file_name_is_absolute + path + + +The following functions are exported only by request. + + devnull + tmpdir + splitpath + splitdir + catpath + abs2rel + rel2abs + +All the functions may be imported using the C<:ALL> tag. + +=head1 SEE ALSO + +File::Spec, File::Spec::Unix, File::Spec::Mac, File::Spec::OS2, +File::Spec::Win32, File::Spec::VMS, ExtUtils::MakeMaker diff --git a/contrib/perl5/lib/File/Spec/Mac.pm b/contrib/perl5/lib/File/Spec/Mac.pm index 63a9e12..959e33d 100644 --- a/contrib/perl5/lib/File/Spec/Mac.pm +++ b/contrib/perl5/lib/File/Spec/Mac.pm @@ -1,18 +1,9 @@ package File::Spec::Mac; -use Exporter (); -use Config; use strict; -use File::Spec; -use vars qw(@ISA $VERSION $Is_Mac); - -$VERSION = '1.0'; - +use vars qw(@ISA); +require File::Spec::Unix; @ISA = qw(File::Spec::Unix); -$Is_Mac = $^O eq 'MacOS'; - -Exporter::import('File::Spec', '$Verbose'); - =head1 NAME @@ -20,7 +11,7 @@ File::Spec::Mac - File::Spec for MacOS =head1 SYNOPSIS -C<require File::Spec::Mac;> + require File::Spec::Mac; # Done internally by File::Spec if needed =head1 DESCRIPTION @@ -37,8 +28,8 @@ On MacOS, there's nothing to be done. Returns what it's given. =cut sub canonpath { - my($self,$path) = @_; - $path; + my ($self,$path) = @_; + return $path; } =item catdir @@ -84,20 +75,17 @@ aren't done here. This routine will treat this as absolute. =cut -# '; - sub catdir { shift; my @args = @_; - $args[0] =~ s/:$//; - my $result = shift @args; - for (@args) { - s/:$//; - s/^://; - $result .= ":$_"; + my $result = shift @args; + $result =~ s/:\z//; + foreach (@args) { + s/:\z//; + s/^://s; + $result .= ":$_"; } - $result .= ":"; - $result; + return "$result:"; } =item catfile @@ -118,50 +106,69 @@ give the same answer, as one might expect. =cut sub catfile { - my $self = shift @_; + my $self = shift; my $file = pop @_; return $file unless @_; my $dir = $self->catdir(@_); - $file =~ s/^://; + $file =~ s/^://s; return $dir.$file; } =item curdir -Returns a string representing of the current directory. +Returns a string representing the current directory. =cut sub curdir { - return ":" ; + return ":"; +} + +=item devnull + +Returns a string representing the null device. + +=cut + +sub devnull { + return "Dev:Null"; } =item rootdir Returns a string representing the root directory. Under MacPerl, returns the name of the startup volume, since that's the closest in -concept, although other volumes aren't rooted there. On any other -platform returns '', since there's no common way to indicate "root -directory" across all Macs. +concept, although other volumes aren't rooted there. =cut sub rootdir { # -# There's no real root directory on MacOS. If you're using MacPerl, -# the name of the startup volume is returned, since that's the closest in -# concept. On other platforms, simply return '', because nothing better -# can be done. +# There's no real root directory on MacOS. The name of the startup +# volume is returned, since that's the closest in concept. # - if($Is_Mac) { - require Mac::Files; - my $system = Mac::Files::FindFolder(&Mac::Files::kOnSystemDisk, - &Mac::Files::kSystemFolderType); - $system =~ s/:.*$/:/; - return $system; - } else { - return ''; - } + require Mac::Files; + my $system = Mac::Files::FindFolder(&Mac::Files::kOnSystemDisk, + &Mac::Files::kSystemFolderType); + $system =~ s/:.*\z/:/s; + return $system; +} + +=item tmpdir + +Returns a string representation of the first existing directory +from the following list or '' if none exist: + + $ENV{TMPDIR} + +=cut + +my $tmpdir; +sub tmpdir { + return $tmpdir if defined $tmpdir; + $tmpdir = $ENV{TMPDIR} if -d $ENV{TMPDIR}; + $tmpdir = '' unless defined $tmpdir; + return $tmpdir; } =item updir @@ -185,11 +192,11 @@ distinguish unambiguously. =cut sub file_name_is_absolute { - my($self,$file) = @_; - if ($file =~ /:/) { - return ($file !~ m/^:/); - } else { - return (! -e ":$file"); + my ($self,$file) = @_; + if ($file =~ /:/) { + return ($file !~ m/^:/s); + } else { + return (! -e ":$file"); } } @@ -207,16 +214,178 @@ sub path { # The concept is meaningless under the MacPerl application. # Under MPW, it has a meaning. # - my($self) = @_; - my @path; - if(exists $ENV{Commands}) { - @path = split /,/,$ENV{Commands}; - } else { - @path = (); - } - @path; + return unless exists $ENV{Commands}; + return split(/,/, $ENV{Commands}); +} + +=item splitpath + +=cut + +sub splitpath { + my ($self,$path, $nofile) = @_; + + my ($volume,$directory,$file) = ('','',''); + + if ( $nofile ) { + ( $volume, $directory ) = $path =~ m@((?:[^:]+(?::|\z))?)(.*)@s; + } + else { + $path =~ + m@^( (?: [^:]+: )? ) + ( (?: .*: )? ) + ( .* ) + @xs; + $volume = $1; + $directory = $2; + $file = $3; + } + + # Make sure non-empty volumes and directories end in ':' + $volume .= ':' if $volume =~ m@[^:]\z@ ; + $directory .= ':' if $directory =~ m@[^:]\z@ ; + return ($volume,$directory,$file); +} + + +=item splitdir + +=cut + +sub splitdir { + my ($self,$directories) = @_ ; + # + # split() likes to forget about trailing null fields, so here we + # check to be sure that there will not be any before handling the + # simple case. + # + if ( $directories !~ m@:\z@ ) { + return split( m@:@, $directories ); + } + else { + # + # since there was a trailing separator, add a file name to the end, + # then do the split, then replace it with ''. + # + my( @directories )= split( m@:@, "${directories}dummy" ) ; + $directories[ $#directories ]= '' ; + return @directories ; + } +} + + +=item catpath + +=cut + +sub catpath { + my $self = shift ; + + my $result = shift ; + $result =~ s@^([^/])@/$1@s ; + + my $segment ; + for $segment ( @_ ) { + if ( $result =~ m@[^/]\z@ && $segment =~ m@^[^/]@s ) { + $result .= "/$segment" ; + } + elsif ( $result =~ m@/\z@ && $segment =~ m@^/@s ) { + $result =~ s@/+\z@/@; + $segment =~ s@^/+@@s; + $result .= "$segment" ; + } + else { + $result .= $segment ; + } + } + + return $result ; } +=item abs2rel + +=cut + +sub abs2rel { + my($self,$path,$base) = @_; + + # Clean up $path + if ( ! $self->file_name_is_absolute( $path ) ) { + $path = $self->rel2abs( $path ) ; + } + + # Figure out the effective $base and clean it up. + if ( !defined( $base ) || $base eq '' ) { + $base = cwd() ; + } + elsif ( ! $self->file_name_is_absolute( $base ) ) { + $base = $self->rel2abs( $base ) ; + } + + # Now, remove all leading components that are the same + my @pathchunks = $self->splitdir( $path ); + my @basechunks = $self->splitdir( $base ); + + while (@pathchunks && @basechunks && $pathchunks[0] eq $basechunks[0]) { + shift @pathchunks ; + shift @basechunks ; + } + + $path = join( ':', @pathchunks ); + + # @basechunks now contains the number of directories to climb out of. + $base = ':' x @basechunks ; + + return "$base:$path" ; +} + +=item rel2abs + +Converts a relative path to an absolute path. + + $abs_path = File::Spec->rel2abs( $destination ) ; + $abs_path = File::Spec->rel2abs( $destination, $base ) ; + +If $base is not present or '', then L<cwd()> is used. If $base is relative, +then it is converted to absolute form using L</rel2abs()>. This means that it +is taken to be relative to L<cwd()>. + +On systems with the concept of a volume, this assumes that both paths +are on the $base volume, and ignores the $destination 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 +directories. + +If $path is absolute, it is cleaned up and returned using L</canonpath()>. + +Based on code written by Shigio Yamaguchi. + +No checks against the filesystem are made. + +=cut + +sub rel2abs($;$;) { + my ($self,$path,$base ) = @_; + + if ( ! $self->file_name_is_absolute( $path ) ) { + if ( !defined( $base ) || $base eq '' ) { + $base = cwd() ; + } + elsif ( ! $self->file_name_is_absolute( $base ) ) { + $base = $self->rel2abs( $base ) ; + } + else { + $base = $self->canonpath( $base ) ; + } + + $path = $self->canonpath("$base$path") ; + } + + return $path ; +} + + =back =head1 SEE ALSO @@ -226,5 +395,3 @@ L<File::Spec> =cut 1; -__END__ - diff --git a/contrib/perl5/lib/File/Spec/OS2.pm b/contrib/perl5/lib/File/Spec/OS2.pm index d602617..33370f0 100644 --- a/contrib/perl5/lib/File/Spec/OS2.pm +++ b/contrib/perl5/lib/File/Spec/OS2.pm @@ -1,34 +1,44 @@ package File::Spec::OS2; -#use Config; -#use Cwd; -#use File::Basename; use strict; -require Exporter; - -use File::Spec; use vars qw(@ISA); - -Exporter::import('File::Spec', - qw( $Verbose)); - +require File::Spec::Unix; @ISA = qw(File::Spec::Unix); -$ENV{EMXSHELL} = 'sh'; # to run `commands` +sub devnull { + return "/dev/nul"; +} + +sub case_tolerant { + return 1; +} sub file_name_is_absolute { - my($self,$file) = @_; - $file =~ m{^([a-z]:)?[\\/]}i ; + my ($self,$file) = @_; + return scalar($file =~ m{^([a-z]:)?[\\/]}is); } sub path { - my($self) = @_; - my $path_sep = ";"; my $path = $ENV{PATH}; $path =~ s:\\:/:g; - my @path = split $path_sep, $path; - foreach(@path) { $_ = '.' if $_ eq '' } - @path; + my @path = split(';',$path); + foreach (@path) { $_ = '.' if $_ eq '' } + return @path; +} + +my $tmpdir; +sub tmpdir { + return $tmpdir if defined $tmpdir; + my $self = shift; + foreach (@ENV{qw(TMPDIR TEMP TMP)}, qw(/tmp /)) { + next unless defined && -d; + $tmpdir = $_; + last; + } + $tmpdir = '' unless defined $tmpdir; + $tmpdir =~ s:\\:/:g; + $tmpdir = $self->canonpath($tmpdir); + return $tmpdir; } 1; @@ -40,12 +50,10 @@ File::Spec::OS2 - methods for OS/2 file specs =head1 SYNOPSIS - use File::Spec::OS2; # Done internally by File::Spec if needed + require File::Spec::OS2; # Done internally by File::Spec if needed =head1 DESCRIPTION See File::Spec::Unix for a documentation of the methods provided there. This package overrides the implementation of these methods, not the semantics. - -=cut diff --git a/contrib/perl5/lib/File/Spec/Unix.pm b/contrib/perl5/lib/File/Spec/Unix.pm index 77de73a..2305b75 100644 --- a/contrib/perl5/lib/File/Spec/Unix.pm +++ b/contrib/perl5/lib/File/Spec/Unix.pm @@ -1,23 +1,8 @@ package File::Spec::Unix; -use Exporter (); -use Config; -use File::Basename qw(basename dirname fileparse); -use DirHandle; use strict; -use vars qw(@ISA $Is_Mac $Is_OS2 $Is_VMS $Is_Win32); -use File::Spec; -Exporter::import('File::Spec', '$Verbose'); - -$Is_OS2 = $^O eq 'os2'; -$Is_Mac = $^O eq 'MacOS'; -$Is_Win32 = $^O eq 'MSWin32'; - -if ($Is_VMS = $^O eq 'VMS') { - require VMS::Filespec; - import VMS::Filespec qw( &vmsify ); -} +use Cwd; =head1 NAME @@ -25,7 +10,7 @@ File::Spec::Unix - methods used by File::Spec =head1 SYNOPSIS -C<require File::Spec::Unix;> + require File::Spec::Unix; # Done automatically by File::Spec =head1 DESCRIPTION @@ -40,15 +25,18 @@ Methods for manipulating file specifications. No physical check on the filesystem, but a logical cleanup of a path. On UNIX eliminated successive slashes and successive "/.". + $cpath = File::Spec->canonpath( $path ) ; + =cut sub canonpath { - my($self,$path) = @_; - $path =~ s|/+|/|g ; # xx////xx -> xx/xx - $path =~ s|(/\.)+/|/|g ; # xx/././xx -> xx/xx - $path =~ s|^(\./)+|| unless $path eq "./"; # ./xx -> xx - $path =~ s|/$|| unless $path eq "/"; # xx/ -> xx - $path; + my ($self,$path) = @_; + $path =~ s|/+|/|g unless($^O eq 'cygwin'); # xx////xx -> xx/xx + $path =~ s|(/\.)+/|/|g; # xx/././xx -> xx/xx + $path =~ s|^(\./)+||s unless $path eq "./"; # ./xx -> xx + $path =~ s|^/(\.\./)+|/|s; # /../../xx -> xx + $path =~ s|/\z|| unless $path eq "/"; # xx/ -> xx + return $path; } =item catdir @@ -61,20 +49,14 @@ trailing slash :-) =cut -# '; - sub catdir { - shift; + my $self = shift; my @args = @_; - for (@args) { + foreach (@args) { # append a slash to each argument unless it has one there - $_ .= "/" if $_ eq '' or substr($_,-1) ne "/"; + $_ .= "/" if $_ eq '' || substr($_,-1) ne "/"; } - my $result = join('', @args); - # remove a trailing slash unless we are root - substr($result,-1) = "" - if length($result) > 1 && substr($result,-1) eq "/"; - $result; + return $self->canonpath(join('', @args)); } =item catfile @@ -85,29 +67,37 @@ complete path ending with a filename =cut sub catfile { - my $self = shift @_; + my $self = shift; my $file = pop @_; return $file unless @_; my $dir = $self->catdir(@_); - for ($dir) { - $_ .= "/" unless substr($_,length($_)-1,1) eq "/"; - } + $dir .= "/" unless substr($dir,-1) eq "/"; return $dir.$file; } =item curdir -Returns a string representing of the current directory. "." on UNIX. +Returns a string representation of the current directory. "." on UNIX. =cut sub curdir { - return "." ; + return "."; +} + +=item devnull + +Returns a string representation of the null device. "/dev/null" on UNIX. + +=cut + +sub devnull { + return "/dev/null"; } =item rootdir -Returns a string representing of the root directory. "/" on UNIX. +Returns a string representation of the root directory. "/" on UNIX. =cut @@ -115,9 +105,31 @@ sub rootdir { return "/"; } +=item tmpdir + +Returns a string representation of the first writable directory +from the following list or "" if none are writable: + + $ENV{TMPDIR} + /tmp + +=cut + +my $tmpdir; +sub tmpdir { + return $tmpdir if defined $tmpdir; + foreach ($ENV{TMPDIR}, "/tmp") { + next unless defined && -d && -w _; + $tmpdir = $_; + last; + } + $tmpdir = '' unless defined $tmpdir; + return $tmpdir; +} + =item updir -Returns a string representing of the parent directory. ".." on UNIX. +Returns a string representation of the parent directory. ".." on UNIX. =cut @@ -133,8 +145,19 @@ directory. (Does not strip symlinks, only '.', '..', and equivalents.) =cut sub no_upwards { - my($self) = shift; - return grep(!/^\.{1,2}$/, @_); + my $self = shift; + return grep(!/^\.{1,2}\z/s, @_); +} + +=item case_tolerant + +Returns a true or false value indicating, respectively, that alphabetic +is not or is significant when comparing file specifications. + +=cut + +sub case_tolerant { + return 0; } =item file_name_is_absolute @@ -144,8 +167,8 @@ Takes as argument a path and returns true, if it is an absolute path. =cut sub file_name_is_absolute { - my($self,$file) = @_; - $file =~ m:^/: ; + my ($self,$file) = @_; + return scalar($file =~ m:^/:s); } =item path @@ -155,12 +178,9 @@ Takes no argument, returns the environment variable PATH as an array. =cut sub path { - my($self) = @_; - my $path_sep = ":"; - my $path = $ENV{PATH}; - my @path = split $path_sep, $path; - foreach(@path) { $_ = '.' if $_ eq '' } - @path; + my @path = split(':', $ENV{PATH}); + foreach (@path) { $_ = '.' if $_ eq '' } + return @path; } =item join @@ -170,21 +190,247 @@ join is the same as catfile. =cut sub join { - my($self) = shift @_; - $self->catfile(@_); + my $self = shift; + return $self->catfile(@_); +} + +=item splitpath + + ($volume,$directories,$file) = File::Spec->splitpath( $path ); + ($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file ); + +Splits a path in to volume, directory, and filename portions. On systems +with no concept of volume, returns undef for volume. + +For systems with no syntax differentiating filenames from directories, +assumes that the last file is a path unless $no_file is true or a +trailing separator or /. or /.. is present. On Unix this means that $no_file +true makes this return ( '', $path, '' ). + +The directory portion may or may not be returned with a trailing '/'. + +The results can be passed to L</catpath()> to get back a path equivalent to +(usually identical to) the original path. + +=cut + +sub splitpath { + my ($self,$path, $nofile) = @_; + + my ($volume,$directory,$file) = ('','',''); + + if ( $nofile ) { + $directory = $path; + } + else { + $path =~ m|^ ( (?: .* / (?: \.\.?\z )? )? ) ([^/]*) |xs; + $directory = $1; + $file = $2; + } + + return ($volume,$directory,$file); +} + + +=item splitdir + +The opposite of L</catdir()>. + + @dirs = File::Spec->splitdir( $directories ); + +$directories must be only the directory portion of the path on systems +that have the concept of a volume or that have path syntax that differentiates +files from directories. + +Unlike just splitting the directories on the separator, empty +directory names (C<''>) can be returned, because these are significant +on some OSs (e.g. MacOS). + +On Unix, + + File::Spec->splitdir( "/a/b//c/" ); + +Yields: + + ( '', 'a', 'b', '', 'c', '' ) + +=cut + +sub splitdir { + my ($self,$directories) = @_ ; + # + # split() likes to forget about trailing null fields, so here we + # check to be sure that there will not be any before handling the + # simple case. + # + if ( $directories !~ m|/\z| ) { + return split( m|/|, $directories ); + } + else { + # + # since there was a trailing separator, add a file name to the end, + # then do the split, then replace it with ''. + # + my( @directories )= split( m|/|, "${directories}dummy" ) ; + $directories[ $#directories ]= '' ; + return @directories ; + } } -=item nativename -TBW. +=item catpath + +Takes volume, directory and file portions and returns an entire path. Under +Unix, $volume is ignored, and directory and file are catenated. A '/' is +inserted if need be. On other OSs, $volume is significant. =cut -sub nativename { - my($self,$name) = shift @_; - $name; +sub catpath { + my ($self,$volume,$directory,$file) = @_; + + if ( $directory ne '' && + $file ne '' && + substr( $directory, -1 ) ne '/' && + substr( $file, 0, 1 ) ne '/' + ) { + $directory .= "/$file" ; + } + else { + $directory .= $file ; + } + + return $directory ; } +=item abs2rel + +Takes a destination path and an optional base path returns a relative path +from the base path to the destination path: + + $rel_path = File::Spec->abs2rel( $destination ) ; + $rel_path = File::Spec->abs2rel( $destination, $base ) ; + +If $base is not present or '', then L<cwd()> is used. If $base is relative, +then it is converted to absolute form using L</rel2abs()>. This means that it +is taken to be relative to L<cwd()>. + +On systems with the concept of a volume, this assumes that both paths +are on the $destination volume, and ignores the $base 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 +directories. + +If $path is relative, it is converted to absolute form using L</rel2abs()>. +This means that it is taken to be relative to L<cwd()>. + +Based on code written by Shigio Yamaguchi. + +No checks against the filesystem are made. + +=cut + +sub abs2rel { + my($self,$path,$base) = @_; + + # 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 = cwd() ; + } + elsif ( ! $self->file_name_is_absolute( $base ) ) { + $base = $self->rel2abs( $base ) ; + } + else { + $base = $self->canonpath( $base ) ; + } + + # Now, remove all leading components that are the same + my @pathchunks = $self->splitdir( $path); + my @basechunks = $self->splitdir( $base); + + while (@pathchunks && @basechunks && $pathchunks[0] eq $basechunks[0]) { + shift @pathchunks ; + shift @basechunks ; + } + + $path = CORE::join( '/', @pathchunks ); + $base = CORE::join( '/', @basechunks ); + + # $base now contains the directories the resulting relative path + # must ascend out of before it can descend to $path_directory. So, + # replace all names with $parentDir + $base =~ s|[^/]+|..|g ; + + # Glue the two together, using a separator if necessary, and preventing an + # empty result. + if ( $path ne '' && $base ne '' ) { + $path = "$base/$path" ; + } else { + $path = "$base$path" ; + } + + return $self->canonpath( $path ) ; +} + +=item rel2abs + +Converts a relative path to an absolute path. + + $abs_path = File::Spec->rel2abs( $destination ) ; + $abs_path = File::Spec->rel2abs( $destination, $base ) ; + +If $base is not present or '', then L<cwd()> is used. If $base is relative, +then it is converted to absolute form using L</rel2abs()>. This means that it +is taken to be relative to L<cwd()>. + +On systems with the concept of a volume, this assumes that both paths +are on the $base volume, and ignores the $destination 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 +directories. + +If $path is absolute, it is cleaned up and returned using L</canonpath()>. + +Based on code written by Shigio Yamaguchi. + +No checks against the filesystem are made. + +=cut + +sub rel2abs($;$;) { + my ($self,$path,$base ) = @_; + + # Clean up $path + if ( ! $self->file_name_is_absolute( $path ) ) { + # Figure out the effective $base and clean it up. + if ( !defined( $base ) || $base eq '' ) { + $base = cwd() ; + } + elsif ( ! $self->file_name_is_absolute( $base ) ) { + $base = $self->rel2abs( $base ) ; + } + else { + $base = $self->canonpath( $base ) ; + } + + # Glom them together + $path = $self->catdir( $base, $path ) ; + } + + return $self->canonpath( $path ) ; +} + + =back =head1 SEE ALSO @@ -194,4 +440,3 @@ L<File::Spec> =cut 1; -__END__ diff --git a/contrib/perl5/lib/File/Spec/VMS.pm b/contrib/perl5/lib/File/Spec/VMS.pm index c5269fd..a2ac8ca 100644 --- a/contrib/perl5/lib/File/Spec/VMS.pm +++ b/contrib/perl5/lib/File/Spec/VMS.pm @@ -1,19 +1,13 @@ - package File::Spec::VMS; -use Carp qw( &carp ); -use Config; -require Exporter; -use VMS::Filespec; -use File::Basename; - -use File::Spec; -use vars qw($Revision); -$Revision = '5.3901 (6-Mar-1997)'; - +use strict; +use vars qw(@ISA); +require File::Spec::Unix; @ISA = qw(File::Spec::Unix); -Exporter::import('File::Spec', '$Verbose'); +use Cwd; +use File::Basename; +use VMS::Filespec; =head1 NAME @@ -21,7 +15,7 @@ File::Spec::VMS - methods for VMS file specs =head1 SYNOPSIS - use File::Spec::VMS; # Done internally by File::Spec if needed + require File::Spec::VMS; # Done internally by File::Spec if needed =head1 DESCRIPTION @@ -29,67 +23,202 @@ See File::Spec::Unix for a documentation of the methods provided there. This package overrides the implementation of these methods, not the semantics. +=over + +=item eliminate_macros + +Expands MM[KS]/Make macros in a text string, using the contents of +identically named elements of C<%$self>, and returns the result +as a file specification in Unix syntax. + +=cut + +sub eliminate_macros { + my($self,$path) = @_; + return '' unless $path; + $self = {} unless ref $self; + my($npath) = unixify($path); + 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}) { + ($head,$macro,$tail) = ($1,$2,$3); + if (ref $self->{$macro}) { + if (ref $self->{$macro} eq 'ARRAY') { + $macro = join ' ', @{$self->{$macro}}; + } + else { + print "Note: can't expand macro \$($macro) containing ",ref($self->{$macro}), + "\n\t(using MMK-specific deferred substitutuon; MMS will break)\n"; + $macro = "\cB$macro\cB"; + $complex = 1; + } + } + else { ($macro = unixify($self->{$macro})) =~ s#/\z##; } + $npath = "$head$macro$tail"; + } + } + if ($complex) { $npath =~ s#\cB(.*?)\cB#\${$1}#gs; } + $npath; +} + +=item fixpath + +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. + +If optional second argument has a TRUE value, then the return string is +a VMS-syntax directory specification, if it is FALSE, the return string +is a VMS-syntax file specification, and if it is not specified, fixpath() +checks to see whether it matches the name of a directory in the current +default directory, and returns a directory or file specification accordingly. + +=cut + +sub fixpath { + my($self,$path,$force_path) = @_; + return '' unless $path; + $self = bless {} unless ref $self; + my($fixedpath,$prefix,$name); + + if ($path =~ m#^\$\([^\)]+\)\z#s || $path =~ m#[/:>\]]#) { + if ($force_path or $path =~ /(?:DIR\)|\])\z/) { + $fixedpath = vmspath($self->eliminate_macros($path)); + } + else { + $fixedpath = vmsify($self->eliminate_macros($path)); + } + } + elsif ((($prefix,$name) = ($path =~ m#^\$\(([^\)]+)\)(.+)#s)) && $self->{$prefix}) { + my($vmspre) = $self->eliminate_macros("\$($prefix)"); + # is it a dir or just a name? + $vmspre = ($vmspre =~ m|/| or $prefix =~ /DIR\z/) ? vmspath($vmspre) : ''; + $fixedpath = ($vmspre ? $vmspre : $self->{$prefix}) . $name; + $fixedpath = vmspath($fixedpath) if $force_path; + } + else { + $fixedpath = $path; + $fixedpath = vmspath($fixedpath) if $force_path; + } + # No hints, so we try to guess + if (!defined($force_path) and $fixedpath !~ /[:>(.\]]/) { + $fixedpath = vmspath($fixedpath) if -d $fixedpath; + } + + # Trim off root dirname if it's had other dirs inserted in front of it. + $fixedpath =~ s/\.000000([\]>])/$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 ($path =~ /^[\[>][^.\-]/) { $fixedpath =~ s/^[^\[<]+//; } + $fixedpath; +} + +=back + =head2 Methods always loaded =over +=item canonpath (override) + +Removes redundant portions of file specifications according to VMS syntax. + +=cut + +sub canonpath { + my($self,$path) = @_; + + if ($path =~ m|/|) { # Fake Unix + my $pathify = $path =~ m|/\z|; + $path = $self->SUPER::canonpath($path); + if ($pathify) { return vmspath($path); } + else { return vmsify($path); } + } + else { + $path =~ s-\]\[--g; $path =~ s/><//g; # foo.][bar ==> foo.bar + $path =~ s/([\[<])000000\./$1/; # [000000.foo ==> foo + 1 while $path =~ s{([\[<-])\.-}{$1-}; # [.-.- ==> [-- + $path =~ s/\.[^\[<\.]+\.-([\]\>])/$1/; # bar.foo.-] ==> bar] + $path =~ s/([\[<])(-+)/$1 . "\cx" x length($2)/e; # encode leading '-'s + $path =~ s/([\[<\.])([^\[<\.\cx]+)\.-\.?/$1/g; # bar.-.foo ==> foo + $path =~ s/([\[<])(\cx+)/$1 . '-' x length($2)/e; # then decode + return $path; + } +} + =item catdir Concatenates a list of file specifications, and returns the result as a -VMS-syntax directory specification. +VMS-syntax directory specification. No check is made for "impossible" +cases (e.g. elements other than the first being absolute filespecs). =cut sub catdir { - my($self,@dirs) = @_; - my($dir) = pop @dirs; + my ($self,@dirs) = @_; + my $dir = pop @dirs; @dirs = grep($_,@dirs); - my($rslt); + my $rslt; if (@dirs) { - my($path) = (@dirs == 1 ? $dirs[0] : $self->catdir(@dirs)); - my($spath,$sdir) = ($path,$dir); - $spath =~ s/.dir$//; $sdir =~ s/.dir$//; - $sdir = $self->eliminate_macros($sdir) unless $sdir =~ /^[\w\-]+$/; - $rslt = $self->fixpath($self->eliminate_macros($spath)."/$sdir",1); + my $path = (@dirs == 1 ? $dirs[0] : $self->catdir(@dirs)); + my ($spath,$sdir) = ($path,$dir); + $spath =~ s/\.dir\z//; $sdir =~ s/\.dir\z//; + $sdir = $self->eliminate_macros($sdir) unless $sdir =~ /^[\w\-]+\z/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 ($dir =~ /^\$\([^\)]+\)$/) { $rslt = $dir; } - else { $rslt = vmspath($dir); } + else { + if (not defined $dir or not length $dir) { $rslt = ''; } + elsif ($dir =~ /^\$\([^\)]+\)\z/s) { $rslt = $dir; } + else { $rslt = vmspath($dir); } } - print "catdir(",join(',',@_[1..$#_]),") = |$rslt|\n" if $Verbose >= 3; - $rslt; + return $self->canonpath($rslt); } =item catfile Concatenates a list of file specifications, and returns the result as a -VMS-syntax directory specification. +VMS-syntax file specification. =cut sub catfile { - my($self,@files) = @_; - my($file) = pop @files; + my ($self,@files) = @_; + my $file = pop @files; @files = grep($_,@files); - my($rslt); + my $rslt; if (@files) { - my($path) = (@files == 1 ? $files[0] : $self->catdir(@files)); - my($spath) = $path; - $spath =~ s/.dir$//; - if ( $spath =~ /^[^\)\]\/:>]+\)$/ && basename($file) eq $file) { $rslt = "$spath$file"; } - else { - $rslt = $self->eliminate_macros($spath); - $rslt = vmsify($rslt.($rslt ? '/' : '').unixify($file)); - } + my $path = (@files == 1 ? $files[0] : $self->catdir(@files)); + my $spath = $path; + $spath =~ s/\.dir\z//; + if ($spath =~ /^[^\)\]\/:>]+\)\z/s && basename($file) eq $file) { + $rslt = "$spath$file"; + } + else { + $rslt = $self->eliminate_macros($spath); + $rslt = vmsify($rslt.($rslt ? '/' : '').unixify($file)); + } } - else { $rslt = vmsify($file); } - print "catfile(",join(',',@_[1..$#_]),") = |$rslt|\n" if $Verbose >= 3; - $rslt; + else { $rslt = (defined($file) && length($file)) ? vmsify($file) : ''; } + return $self->canonpath($rslt); } + =item curdir (override) -Returns a string representing of the current directory. +Returns a string representation of the current directory: '[]' =cut @@ -97,19 +226,51 @@ sub curdir { return '[]'; } +=item devnull (override) + +Returns a string representation of the null device: '_NLA0:' + +=cut + +sub devnull { + return "_NLA0:"; +} + =item rootdir (override) -Returns a string representing of the root directory. +Returns a string representation of the root directory: 'SYS$DISK:[000000]' =cut sub rootdir { - return ''; + return 'SYS$DISK:[000000]'; +} + +=item tmpdir (override) + +Returns a string representation of the first writable directory +from the following list or '' if none are writable: + + sys$scratch + $ENV{TMPDIR} + +=cut + +my $tmpdir; +sub tmpdir { + return $tmpdir if defined $tmpdir; + foreach ('sys$scratch', $ENV{TMPDIR}) { + next unless defined && -d && -w _; + $tmpdir = $_; + last; + } + $tmpdir = '' unless defined $tmpdir; + return $tmpdir; } =item updir (override) -Returns a string representing of the parent directory. +Returns a string representation of the parent directory: '[-]' =cut @@ -117,6 +278,16 @@ sub updir { return '[-]'; } +=item case_tolerant (override) + +VMS file specification syntax is case-tolerant. + +=cut + +sub case_tolerant { + return 1; +} + =item path (override) Translate logical name DCL$PATH as a searchlist, rather than trying @@ -125,9 +296,9 @@ to C<split> string value of C<$ENV{'PATH'}>. =cut sub path { - my(@dirs,$dir,$i); + my (@dirs,$dir,$i); while ($dir = $ENV{'DCL$PATH;' . $i++}) { push(@dirs,$dir); } - @dirs; + return @dirs; } =item file_name_is_absolute (override) @@ -137,12 +308,185 @@ Checks for VMS directory spec as well as Unix separators. =cut sub file_name_is_absolute { - my($self,$file) = @_; + my ($self,$file) = @_; # If it's a logical name, expand it. - $file = $ENV{$file} while $file =~ /^[\w\$\-]+$/ and $ENV{$file}; - $file =~ m!^/! or $file =~ m![<\[][^.\-\]>]! or $file =~ /:[^<\[]/; + $file = $ENV{$file} while $file =~ /^[\w\$\-]+\z/s && $ENV{$file}; + return scalar($file =~ m!^/!s || + $file =~ m![<\[][^.\-\]>]! || + $file =~ /:[^<\[]/); } -1; -__END__ +=item splitpath (override) + +Splits using VMS syntax. + +=cut + +sub splitpath { + my($self,$path) = @_; + my($dev,$dir,$file) = ('','',''); + + vmsify($path) =~ /(.+:)?([\[<].*[\]>])?(.*)/s; + return ($1 || '',$2 || '',$3); +} + +=item splitdir (override) + +Split dirspec using VMS syntax. + +=cut + +sub splitdir { + my($self,$dirspec) = @_; + $dirspec =~ s/\]\[//g; $dirspec =~ s/\-\-/-.-/g; + $dirspec = "[$dirspec]" unless $dirspec =~ /[\[<]/; # make legal + my(@dirs) = split('\.', vmspath($dirspec)); + $dirs[0] =~ s/^[\[<]//s; $dirs[-1] =~ s/[\]>]\z//s; + @dirs; +} + + +=item catpath (override) + +Construct a complete filespec using VMS syntax + +=cut + +sub catpath { + my($self,$dev,$dir,$file) = @_; + if ($dev =~ m|^/+([^/]+)|) { $dev = "$1:"; } + else { $dev .= ':' unless $dev eq '' or $dev =~ /:\z/; } + if (length($dev) or length($dir)) { + $dir = "[$dir]" unless $dir =~ /[\[<\/]/; + $dir = vmspath($dir); + } + "$dev$dir$file"; +} + +=item abs2rel (override) + +Use VMS syntax when converting filespecs. + +=cut + +sub abs2rel { + my $self = shift; + + return vmspath(File::Spec::Unix::abs2rel( $self, @_ )) + if ( join( '', @_ ) =~ m{/} ) ; + + my($path,$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 = cwd() ; + } + elsif ( ! $self->file_name_is_absolute( $base ) ) { + $base = $self->rel2abs( $base ) ; + } + else { + $base = $self->canonpath( $base ) ; + } + + # Split up paths + my ( undef, $path_directories, $path_file ) = + $self->splitpath( $path, 1 ) ; + + $path_directories = $1 + if $path_directories =~ /^\[(.*)\]\z/s ; + + my ( undef, $base_directories, undef ) = + $self->splitpath( $base, 1 ) ; + + $base_directories = $1 + if $base_directories =~ /^\[(.*)\]\z/s ; + + # Now, remove all leading components that are the same + my @pathchunks = $self->splitdir( $path_directories ); + my @basechunks = $self->splitdir( $base_directories ); + + while ( @pathchunks && + @basechunks && + lc( $pathchunks[0] ) eq lc( $basechunks[0] ) + ) { + shift @pathchunks ; + shift @basechunks ; + } + + # @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}{} ; + return $self->canonpath( $self->catpath( '', $path_directories, $path_file ) ) ; +} + + +=item rel2abs (override) + +Use VMS syntax when converting filespecs. + +=cut + +sub rel2abs($;$;) { + my $self = shift ; + return vmspath(File::Spec::Unix::rel2abs( $self, @_ )) + if ( join( '', @_ ) =~ m{/} ) ; + + my ($path,$base ) = @_; + # Clean up and split up $path + if ( ! $self->file_name_is_absolute( $path ) ) { + # Figure out the effective $base and clean it up. + if ( !defined( $base ) || $base eq '' ) { + $base = cwd() ; + } + elsif ( ! $self->file_name_is_absolute( $base ) ) { + $base = $self->rel2abs( $base ) ; + } + else { + $base = $self->canonpath( $base ) ; + } + + # Split up paths + my ( undef, $path_directories, $path_file ) = + $self->splitpath( $path ) ; + + my ( $base_volume, $base_directories, undef ) = + $self->splitpath( $base ) ; + + $path_directories = '' if $path_directories eq '[]' || + $path_directories eq '<>'; + my $sep = '' ; + $sep = '.' + if ( $base_directories =~ m{[^.\]>]\z} && + $path_directories =~ m{^[^.\[<]}s + ) ; + $base_directories = "$base_directories$sep$path_directories"; + $base_directories =~ s{\.?[\]>][\[<]\.?}{.}; + + $path = $self->catpath( $base_volume, $base_directories, $path_file ); + } + + return $self->canonpath( $path ) ; +} + + +=back + +=head1 SEE ALSO + +L<File::Spec> + +=cut + +1; diff --git a/contrib/perl5/lib/File/Spec/Win32.pm b/contrib/perl5/lib/File/Spec/Win32.pm index 034a0cb..aa95fbd 100644 --- a/contrib/perl5/lib/File/Spec/Win32.pm +++ b/contrib/perl5/lib/File/Spec/Win32.pm @@ -1,12 +1,18 @@ package File::Spec::Win32; +use strict; +use Cwd; +use vars qw(@ISA); +require File::Spec::Unix; +@ISA = qw(File::Spec::Unix); + =head1 NAME File::Spec::Win32 - methods for Win32 file specs =head1 SYNOPSIS - use File::Spec::Win32; # Done internally by File::Spec if needed + require File::Spec::Win32; # Done internally by File::Spec if needed =head1 DESCRIPTION @@ -16,37 +22,50 @@ the semantics. =over -=cut +=item devnull -#use Config; -#use Cwd; -use File::Basename; -require Exporter; -use strict; +Returns a string representation of the null device. -use vars qw(@ISA); +=cut -use File::Spec; -Exporter::import('File::Spec', qw( $Verbose)); +sub devnull { + return "nul"; +} -@ISA = qw(File::Spec::Unix); +=item tmpdir -$ENV{EMXSHELL} = 'sh'; # to run `commands` +Returns a string representation of the first existing directory +from the following list: -sub file_name_is_absolute { - my($self,$file) = @_; - $file =~ m{^([a-z]:)?[\\/]}i ; -} + $ENV{TMPDIR} + $ENV{TEMP} + $ENV{TMP} + /tmp + / -sub catdir { +=cut + +my $tmpdir; +sub tmpdir { + return $tmpdir if defined $tmpdir; my $self = shift; - my @args = @_; - for (@args) { - # append a slash to each argument unless it has one there - $_ .= "\\" if $_ eq '' or substr($_,-1) ne "\\"; + foreach (@ENV{qw(TMPDIR TEMP TMP)}, qw(/tmp /)) { + next unless defined && -d; + $tmpdir = $_; + last; } - my $result = $self->canonpath(join('', @args)); - $result; + $tmpdir = '' unless defined $tmpdir; + $tmpdir = $self->canonpath($tmpdir); + return $tmpdir; +} + +sub case_tolerant { + return 1; +} + +sub file_name_is_absolute { + my ($self,$file) = @_; + return scalar($file =~ m{^([a-z]:)?[\\/]}is); } =item catfile @@ -57,22 +76,19 @@ complete path ending with a filename =cut sub catfile { - my $self = shift @_; + my $self = shift; my $file = pop @_; return $file unless @_; my $dir = $self->catdir(@_); - $dir =~ s/(\\\.)$//; - $dir .= "\\" unless substr($dir,length($dir)-1,1) eq "\\"; + $dir .= "\\" unless substr($dir,-1) eq "\\"; return $dir.$file; } sub path { - local $^W = 1; - my($self) = @_; my $path = $ENV{'PATH'} || $ENV{'Path'} || $ENV{'path'}; my @path = split(';',$path); - foreach(@path) { $_ = '.' if $_ eq '' } - @path; + foreach (@path) { $_ = '.' if $_ eq '' } + return @path; } =item canonpath @@ -83,22 +99,307 @@ path. On UNIX eliminated successive slashes and successive "/.". =cut sub canonpath { - my($self,$path) = @_; - $path =~ s/^([a-z]:)/\u$1/; + my ($self,$path) = @_; + $path =~ s/^([a-z]:)/\u$1/s; $path =~ s|/|\\|g; - $path =~ s|\\+|\\|g ; # xx////xx -> xx/xx - $path =~ s|(\\\.)+\\|\\|g ; # xx/././xx -> xx/xx - $path =~ s|^(\.\\)+|| unless $path eq ".\\"; # ./xx -> xx - $path =~ s|\\$|| - unless $path =~ m#^([a-z]:)?\\#; # xx/ -> xx - $path .= '.' if $path =~ m#\\$#; - $path; + $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|| + unless $path =~ m#^([A-Z]:)?\\\z#s; # xx/ -> xx + return $path; } -1; -__END__ +=item splitpath + + ($volume,$directories,$file) = File::Spec->splitpath( $path ); + ($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file ); + +Splits a path in to volume, directory, and filename portions. Assumes that +the last file is a path unless the path ends in '\\', '\\.', '\\..' +or $no_file is true. On Win32 this means that $no_file true makes this return +( $volume, $path, undef ). + +Separators accepted are \ and /. + +Volumes can be drive letters or UNC sharenames (\\server\share). + +The results can be passed to L</catpath> to get back a path equivalent to +(usually identical to) the original path. + +=cut + +sub splitpath { + my ($self,$path, $nofile) = @_; + my ($volume,$directory,$file) = ('','',''); + if ( $nofile ) { + $path =~ + m{^( (?:[a-zA-Z]:|(?:\\\\|//)[^\\/]+[\\/][^\\/]+)? ) + (.*) + }xs; + $volume = $1; + $directory = $2; + } + else { + $path =~ + m{^ ( (?: [a-zA-Z]: | + (?:\\\\|//)[^\\/]+[\\/][^\\/]+ + )? + ) + ( (?:.*[\\\\/](?:\.\.?\z)?)? ) + (.*) + }xs; + $volume = $1; + $directory = $2; + $file = $3; + } + + return ($volume,$directory,$file); +} + + +=item splitdir + +The opposite of L</catdir()>. + + @dirs = File::Spec->splitdir( $directories ); + +$directories must be only the directory portion of the path on systems +that have the concept of a volume or that have path syntax that differentiates +files from directories. + +Unlike just splitting the directories on the separator, leading empty and +trailing directory entries can be returned, because these are significant +on some OSs. So, + + File::Spec->splitdir( "/a/b/c" ); + +Yields: + + ( '', 'a', 'b', '', 'c', '' ) + +=cut + +sub splitdir { + my ($self,$directories) = @_ ; + # + # split() likes to forget about trailing null fields, so here we + # check to be sure that there will not be any before handling the + # simple case. + # + if ( $directories !~ m|[\\/]\z| ) { + return split( m|[\\/]|, $directories ); + } + else { + # + # since there was a trailing separator, add a file name to the end, + # then do the split, then replace it with ''. + # + my( @directories )= split( m|[\\/]|, "${directories}dummy" ) ; + $directories[ $#directories ]= '' ; + return @directories ; + } +} + + +=item catpath + +Takes volume, directory and file portions and returns an entire path. Under +Unix, $volume is ignored, and this is just like catfile(). On other OSs, +the $volume become significant. + +=cut + +sub catpath { + my ($self,$volume,$directory,$file) = @_; + + # If it's UNC, make sure the glue separator is there, reusing + # whatever separator is first in the $volume + $volume .= $1 + if ( $volume =~ m@^([\\/])[\\/][^\\/]+[\\/][^\\/]+\z@s && + $directory =~ m@^[^\\/]@s + ) ; + + $volume .= $directory ; + + # If the volume is not just A:, make sure the glue separator is + # there, reusing whatever separator is first in the $volume if possible. + if ( $volume !~ m@^[a-zA-Z]:\z@s && + $volume =~ m@[^\\/]\z@ && + $file =~ m@[^\\/]@ + ) { + $volume =~ m@([\\/])@ ; + my $sep = $1 ? $1 : '\\' ; + $volume .= $sep ; + } + + $volume .= $file ; + + return $volume ; +} + + +=item abs2rel + +Takes a destination path and an optional base path returns a relative path +from the base path to the destination path: + + $rel_path = File::Spec->abs2rel( $destination ) ; + $rel_path = File::Spec->abs2rel( $destination, $base ) ; + +If $base is not present or '', then L</cwd()> is used. If $base is relative, +then it is converted to absolute form using L</rel2abs()>. This means that it +is taken to be relative to L<cwd()>. + +On systems with the concept of a volume, this assumes that both paths +are on the $destination volume, and ignores the $base 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 +directories. + +If $path is relative, it is converted to absolute form using L</rel2abs()>. +This means that it is taken to be relative to L</cwd()>. + +Based on code written by Shigio Yamaguchi. + +No checks against the filesystem are made. + +=cut + +sub abs2rel { + my($self,$path,$base) = @_; + + # 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 ( ! $self->file_name_is_absolute( $base ) ) { + $base = $self->rel2abs( $base ) ; + } + elsif ( !defined( $base ) || $base eq '' ) { + $base = cwd() ; + } + else { + $base = $self->canonpath( $base ) ; + } + + # Split up paths + my ( $path_volume, $path_directories, $path_file ) = + $self->splitpath( $path, 1 ) ; + + my ( undef, $base_directories, undef ) = + $self->splitpath( $base, 1 ) ; + + # Now, remove all leading components that are the same + my @pathchunks = $self->splitdir( $path_directories ); + my @basechunks = $self->splitdir( $base_directories ); + + while ( @pathchunks && + @basechunks && + lc( $pathchunks[0] ) eq lc( $basechunks[0] ) + ) { + shift @pathchunks ; + shift @basechunks ; + } + + # No need to catdir, we know these are well formed. + $path_directories = CORE::join( '\\', @pathchunks ); + $base_directories = CORE::join( '\\', @basechunks ); + + # $base_directories now contains the directories the resulting relative + # path must ascend out of before it can descend to $path_directory. So, + # replace all names with $parentDir + + #FA Need to replace between backslashes... + $base_directories =~ s|[^\\]+|..|g ; + + # Glue the two together, using a separator if necessary, and preventing an + # empty result. + + #FA Must check that new directories are not empty. + if ( $path_directories ne '' && $base_directories ne '' ) { + $path_directories = "$base_directories\\$path_directories" ; + } else { + $path_directories = "$base_directories$path_directories" ; + } + + # It makes no sense to add a relative path to a UNC volume + $path_volume = '' unless $path_volume =~ m{^[A-Z]:}is ; + + return $self->canonpath( + $self->catpath($path_volume, $path_directories, $path_file ) + ) ; +} + +=item rel2abs + +Converts a relative path to an absolute path. + + $abs_path = File::Spec->rel2abs( $destination ) ; + $abs_path = File::Spec->rel2abs( $destination, $base ) ; + +If $base is not present or '', then L<cwd()> is used. If $base is relative, +then it is converted to absolute form using L</rel2abs()>. This means that it +is taken to be relative to L</cwd()>. + +Assumes that both paths are on the $base volume, and ignores the +$destination 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 +directories. + +If $path is absolute, it is cleaned up and returned using L</canonpath()>. + +Based on code written by Shigio Yamaguchi. + +No checks against the filesystem are made. + +=cut + +sub rel2abs($;$;) { + my ($self,$path,$base ) = @_; + + if ( ! $self->file_name_is_absolute( $path ) ) { + + if ( !defined( $base ) || $base eq '' ) { + $base = cwd() ; + } + elsif ( ! $self->file_name_is_absolute( $base ) ) { + $base = $self->rel2abs( $base ) ; + } + else { + $base = $self->canonpath( $base ) ; + } + + my ( undef, $path_directories, $path_file ) = + $self->splitpath( $path, 1 ) ; + + my ( $base_volume, $base_directories, undef ) = + $self->splitpath( $base, 1 ) ; + + $path = $self->catpath( + $base_volume, + $self->catdir( $base_directories, $path_directories ), + $path_file + ) ; + } + + return $self->canonpath( $path ) ; +} =back -=cut +=head1 SEE ALSO + +L<File::Spec> +=cut + +1; diff --git a/contrib/perl5/lib/File/stat.pm b/contrib/perl5/lib/File/stat.pm index f5d17f7..0cf7a0b 100644 --- a/contrib/perl5/lib/File/stat.pm +++ b/contrib/perl5/lib/File/stat.pm @@ -1,9 +1,11 @@ package File::stat; use strict; +use 5.005_64; +our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS); + BEGIN { use Exporter (); - use vars qw(@EXPORT @EXPORT_OK %EXPORT_TAGS); @EXPORT = qw(stat lstat); @EXPORT_OK = qw( $st_dev $st_ino $st_mode $st_nlink $st_uid $st_gid @@ -13,7 +15,7 @@ BEGIN { ); %EXPORT_TAGS = ( FIELDS => [ @EXPORT_OK, @EXPORT ] ); } -use vars @EXPORT_OK; +use vars @EXPORT_OK; # Class::Struct forbids use of @ISA sub import { goto &Exporter::import } |
