summaryrefslogtreecommitdiff
path: root/contrib/perl5/lib/File
diff options
context:
space:
mode:
authorcvs2svn <cvs2svn@FreeBSD.org>2000-08-20 08:43:08 +0000
committercvs2svn <cvs2svn@FreeBSD.org>2000-08-20 08:43:08 +0000
commit6d777319a259846b6241779c2d5108d0ddffef71 (patch)
tree7c92c5394c1f532d31424612d1c9ba2a8fd12392 /contrib/perl5/lib/File
parent8947993a910c7e5d244200623325b9fcb54a9eee (diff)
Notes
Diffstat (limited to 'contrib/perl5/lib/File')
-rw-r--r--contrib/perl5/lib/File/Basename.pm273
-rw-r--r--contrib/perl5/lib/File/CheckTree.pm151
-rw-r--r--contrib/perl5/lib/File/Compare.pm182
-rw-r--r--contrib/perl5/lib/File/Copy.pm353
-rw-r--r--contrib/perl5/lib/File/DosGlob.pm254
-rw-r--r--contrib/perl5/lib/File/Find.pm735
-rw-r--r--contrib/perl5/lib/File/Path.pm238
-rw-r--r--contrib/perl5/lib/File/Spec.pm92
-rw-r--r--contrib/perl5/lib/File/Spec/Functions.pm95
-rw-r--r--contrib/perl5/lib/File/Spec/Mac.pm397
-rw-r--r--contrib/perl5/lib/File/Spec/OS2.pm59
-rw-r--r--contrib/perl5/lib/File/Spec/Unix.pm442
-rw-r--r--contrib/perl5/lib/File/Spec/VMS.pm492
-rw-r--r--contrib/perl5/lib/File/Spec/Win32.pm405
-rw-r--r--contrib/perl5/lib/File/stat.pm115
15 files changed, 0 insertions, 4283 deletions
diff --git a/contrib/perl5/lib/File/Basename.pm b/contrib/perl5/lib/File/Basename.pm
deleted file mode 100644
index 4581e7e93c26c..0000000000000
--- a/contrib/perl5/lib/File/Basename.pm
+++ /dev/null
@@ -1,273 +0,0 @@
-package File::Basename;
-
-=head1 NAME
-
-fileparse - split a pathname into pieces
-
-basename - extract just the filename from a path
-
-dirname - extract just the directory from a path
-
-=head1 SYNOPSIS
-
- use File::Basename;
-
- ($name,$path,$suffix) = fileparse($fullname,@suffixlist)
- fileparse_set_fstype($os_string);
- $basename = basename($fullname,@suffixlist);
- $dirname = dirname($fullname);
-
- ($name,$path,$suffix) = fileparse("lib/File/Basename.pm","\.pm");
- fileparse_set_fstype("VMS");
- $basename = basename("lib/File/Basename.pm",".pm");
- $dirname = dirname("lib/File/Basename.pm");
-
-=head1 DESCRIPTION
-
-These routines allow you to parse file specifications into useful
-pieces using the syntax of different operating systems.
-
-=over 4
-
-=item fileparse_set_fstype
-
-You select the syntax via the routine fileparse_set_fstype().
-
-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
-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
-rules instead, for that function call only.
-
-If the argument passed to it contains one of the substrings "VMS",
-"MSDOS", "MacOS", "AmigaOS", "os2", "MSWin32" or "RISCOS", then the pattern
-matching for suffix removal is performed without regard for case,
-since those systems are not case-sensitive when opening existing files
-(though some of them preserve case on file creation).
-
-If you haven't called fileparse_set_fstype(), the syntax is chosen
-by examining the builtin variable C<$^O> according to these rules.
-
-=item fileparse
-
-The fileparse() routine divides a file specification into three
-parts: a leading B<path>, a file B<name>, and a B<suffix>. The
-B<path> contains everything up to and including the last directory
-separator in the input file specification. The remainder of the input
-file specification is then divided into B<name> and B<suffix> based on
-the optional patterns you specify in C<@suffixlist>. Each element of
-this list is interpreted as a regular expression, and is matched
-against the end of B<name>. If this succeeds, the matching portion of
-B<name> is removed and prepended to B<suffix>. By proper use of
-C<@suffixlist>, you can remove file types or versions for examination.
-
-You are guaranteed that if you concatenate B<path>, B<name>, and
-B<suffix> together in that order, the result will denote the same
-file as the input file specification.
-
-=back
-
-=head1 EXAMPLES
-
-Using Unix file syntax:
-
- ($base,$path,$type) = fileparse('/virgil/aeneid/draft.book7',
- '\.book\d+');
-
-would yield
-
- $base eq 'draft'
- $path eq '/virgil/aeneid/',
- $type eq '.book7'
-
-Similarly, using VMS syntax:
-
- ($name,$dir,$type) = fileparse('Doc_Root:[Help]Rhetoric.Rnh',
- '\..*');
-
-would yield
-
- $name eq 'Rhetoric'
- $dir eq 'Doc_Root:[Help]'
- $type eq '.Rnh'
-
-=over
-
-=item C<basename>
-
-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).
-
-=item C<dirname>
-
-The dirname() routine returns the directory portion of the input file
-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
-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
-directory name to be F<.>).
-
-=back
-
-=cut
-
-
-## use strict;
-# 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);
-$VERSION = "2.6";
-
-
-# fileparse_set_fstype() - specify OS-based rules used in future
-# calls to routines in this package
-#
-# Currently recognized values: VMS, MSDOS, MacOS, AmigaOS, os2, RISCOS
-# Any other name uses Unix-style rules and is case-sensitive
-
-sub fileparse_set_fstype {
- my @old = ($Fileparse_fstype, $Fileparse_igncase);
- if (@_) {
- $Fileparse_fstype = $_[0];
- $Fileparse_igncase = ($_[0] =~ /^(?:MacOS|VMS|AmigaOS|os2|RISCOS|MSWin32|MSDOS)/i);
- }
- wantarray ? @old : $old[0];
-}
-
-# fileparse() - parse file specification
-#
-# Version 2.4 27-Sep-1996 Charles Bailey bailey@genetics.upenn.edu
-
-
-sub fileparse {
- my($fullname,@suffices) = @_;
- my($fstype,$igncase) = ($Fileparse_fstype, $Fileparse_igncase);
- my($dirpath,$tail,$suffix,$basename);
- my($taint) = substr($fullname,0,0); # Is $fullname tainted?
-
- if ($fstype =~ /^VMS/i) {
- if ($fullname =~ m#/#) { $fstype = '' } # We're doing Unix emulation
- else {
- ($dirpath,$basename) = ($fullname =~ /^(.*[:>\]])?(.*)/s);
- $dirpath ||= ''; # should always be defined
- }
- }
- if ($fstype =~ /^MS(DOS|Win32)/i) {
- ($dirpath,$basename) = ($fullname =~ /^((?:.*[:\\\/])?)(.*)/s);
- $dirpath .= '.\\' unless $dirpath =~ /[\\\/]\z/;
- }
- elsif ($fstype =~ /^MacOS/si) {
- ($dirpath,$basename) = ($fullname =~ /^(.*:)?(.*)/s);
- }
- elsif ($fstype =~ /^AmigaOS/i) {
- ($dirpath,$basename) = ($fullname =~ /(.*[:\/])?(.*)/s);
- $dirpath = './' unless $dirpath;
- }
- elsif ($fstype !~ /^VMS/i) { # default to Unix
- ($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);
- }
- $dirpath = './' unless $dirpath;
- }
-
- if (@suffices) {
- $tail = '';
- foreach $suffix (@suffices) {
- my $pat = ($igncase ? '(?i)' : '') . "($suffix)\$";
- if ($basename =~ s/$pat//s) {
- $taint .= substr($suffix,0,0);
- $tail = $1 . $tail;
- }
- }
- }
-
- $tail .= $taint if defined $tail; # avoid warning if $tail == undef
- wantarray ? ($basename . $taint, $dirpath . $taint, $tail)
- : $basename . $taint;
-}
-
-
-# basename() - returns first element of list returned by fileparse()
-
-sub basename {
- my($name) = shift;
- (fileparse($name, map("\Q$_\E",@_)))[0];
-}
-
-
-# dirname() - returns device and directory portion of file specification
-# Behavior matches that of Unix dirname(1) exactly for Unix and MSDOS
-# filespecs except for names ending with a separator, e.g., "/xx/yy/".
-# This differs from the second element of the list returned
-# by fileparse() in that the trailing '/' (Unix) or '\' (MSDOS) (and
-# the last directory name if the filespec ends in a '/' or '\'), is lost.
-
-sub dirname {
- my($basename,$dirname) = fileparse($_[0]);
- my($fstype) = $Fileparse_fstype;
-
- if ($fstype =~ /VMS/i) {
- if ($_[0] =~ m#/#) { $fstype = '' }
- else { return $dirname || $ENV{DEFAULT} }
- }
- if ($fstype =~ /MacOS/i) { return $dirname }
- elsif ($fstype =~ /MSDOS/i) {
- $dirname =~ s/([^:])[\\\/]*\z/$1/;
- unless( length($basename) ) {
- ($basename,$dirname) = fileparse $dirname;
- $dirname =~ s/([^:])[\\\/]*\z/$1/;
- }
- }
- elsif ($fstype =~ /MSWin32/i) {
- $dirname =~ s/([^:])[\\\/]*\z/$1/;
- unless( length($basename) ) {
- ($basename,$dirname) = fileparse $dirname;
- $dirname =~ s/([^:])[\\\/]*\z/$1/;
- }
- }
- elsif ($fstype =~ /AmigaOS/i) {
- if ( $dirname =~ /:\z/) { return $dirname }
- chop $dirname;
- $dirname =~ s#[^:/]+\z## unless length($basename);
- }
- else {
- $dirname =~ s:(.)/*\z:$1:s;
- unless( length($basename) ) {
- local($File::Basename::Fileparse_fstype) = $fstype;
- ($basename,$dirname) = fileparse $dirname;
- $dirname =~ s:(.)/*\z:$1:s;
- }
- }
-
- $dirname;
-}
-
-fileparse_set_fstype $^O;
-
-1;
diff --git a/contrib/perl5/lib/File/CheckTree.pm b/contrib/perl5/lib/File/CheckTree.pm
deleted file mode 100644
index ae1877741bc99..0000000000000
--- a/contrib/perl5/lib/File/CheckTree.pm
+++ /dev/null
@@ -1,151 +0,0 @@
-package File::CheckTree;
-require 5.000;
-require Exporter;
-
-=head1 NAME
-
-validate - run many filetest checks on a tree
-
-=head1 SYNOPSIS
-
- use File::CheckTree;
-
- $warnings += validate( q{
- /vmunix -e || die
- /boot -e || die
- /bin cd
- csh -ex
- csh !-ug
- sh -ex
- sh !-ug
- /usr -d || warn "What happened to $file?\n"
- });
-
-=head1 DESCRIPTION
-
-The validate() routine takes a single multiline string consisting of
-lines containing a filename plus a file test to try on it. (The
-file test may also be a "cd", causing subsequent relative filenames
-to be interpreted relative to that directory.) After the file test
-you may put C<|| die> to make it a fatal error if the file test fails.
-The default is C<|| warn>. The file test may optionally have a "!' prepended
-to test for the opposite condition. If you do a cd and then list some
-relative filenames, you may want to indent them slightly for readability.
-If you supply your own die() or warn() message, you can use $file to
-interpolate the filename.
-
-Filetests may be bunched: "-rwx" tests for all of C<-r>, C<-w>, and C<-x>.
-Only the first failed test of the bunch will produce a warning.
-
-The routine returns the number of warnings issued.
-
-=cut
-
-@ISA = qw(Exporter);
-@EXPORT = qw(validate);
-
-# $RCSfile: validate.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:24:19 $
-
-# The validate routine takes a single multiline string consisting of
-# lines containing a filename plus a file test to try on it. (The
-# file test may also be a 'cd', causing subsequent relative filenames
-# to be interpreted relative to that directory.) After the file test
-# you may put '|| die' to make it a fatal error if the file test fails.
-# The default is '|| warn'. The file test may optionally have a ! prepended
-# to test for the opposite condition. If you do a cd and then list some
-# relative filenames, you may want to indent them slightly for readability.
-# If you supply your own "die" or "warn" message, you can use $file to
-# interpolate the filename.
-
-# Filetests may be bunched: -rwx tests for all of -r, -w and -x.
-# Only the first failed test of the bunch will produce a warning.
-
-# The routine returns the number of warnings issued.
-
-# Usage:
-# use File::CheckTree;
-# $warnings += validate('
-# /vmunix -e || die
-# /boot -e || die
-# /bin cd
-# csh -ex
-# csh !-ug
-# sh -ex
-# sh !-ug
-# /usr -d || warn "What happened to $file?\n"
-# ');
-
-sub validate {
- local($file,$test,$warnings,$oldwarnings);
- foreach $check (split(/\n/,$_[0])) {
- next if $check =~ /^#/;
- next if $check =~ /^$/;
- ($file,$test) = split(' ',$check,2);
- if ($test =~ s/^(!?-)(\w{2,}\b)/$1Z/) {
- $testlist = $2;
- @testlist = split(//,$testlist);
- }
- else {
- @testlist = ('Z');
- }
- $oldwarnings = $warnings;
- foreach $one (@testlist) {
- $this = $test;
- $this =~ s/(-\w\b)/$1 \$file/g;
- $this =~ s/-Z/-$one/;
- $this .= ' || warn' unless $this =~ /\|\|/;
- $this =~ s/^(.*\S)\s*\|\|\s*(die|warn)$/$1 || valmess('$2','$1')/;
- $this =~ s/\bcd\b/chdir (\$cwd = \$file)/g;
- eval $this;
- last if $warnings > $oldwarnings;
- }
- }
- $warnings;
-}
-
-sub valmess {
- local($disposition,$this) = @_;
- $file = $cwd . '/' . $file unless $file =~ m|^/|s;
- if ($this =~ /^(!?)-(\w)\s+\$file\s*$/) {
- $neg = $1;
- $tmp = $2;
- $tmp eq 'r' && ($mess = "$file is not readable by uid $>.");
- $tmp eq 'w' && ($mess = "$file is not writable by uid $>.");
- $tmp eq 'x' && ($mess = "$file is not executable by uid $>.");
- $tmp eq 'o' && ($mess = "$file is not owned by uid $>.");
- $tmp eq 'R' && ($mess = "$file is not readable by you.");
- $tmp eq 'W' && ($mess = "$file is not writable by you.");
- $tmp eq 'X' && ($mess = "$file is not executable by you.");
- $tmp eq 'O' && ($mess = "$file is not owned by you.");
- $tmp eq 'e' && ($mess = "$file does not exist.");
- $tmp eq 'z' && ($mess = "$file does not have zero size.");
- $tmp eq 's' && ($mess = "$file does not have non-zero size.");
- $tmp eq 'f' && ($mess = "$file is not a plain file.");
- $tmp eq 'd' && ($mess = "$file is not a directory.");
- $tmp eq 'l' && ($mess = "$file is not a symbolic link.");
- $tmp eq 'p' && ($mess = "$file is not a named pipe (FIFO).");
- $tmp eq 'S' && ($mess = "$file is not a socket.");
- $tmp eq 'b' && ($mess = "$file is not a block special file.");
- $tmp eq 'c' && ($mess = "$file is not a character special file.");
- $tmp eq 'u' && ($mess = "$file does not have the setuid bit set.");
- $tmp eq 'g' && ($mess = "$file does not have the setgid bit set.");
- $tmp eq 'k' && ($mess = "$file does not have the sticky bit set.");
- $tmp eq 'T' && ($mess = "$file is not a text file.");
- $tmp eq 'B' && ($mess = "$file is not a binary file.");
- if ($neg eq '!') {
- $mess =~ s/ is not / should not be / ||
- $mess =~ s/ does not / should not / ||
- $mess =~ s/ not / /;
- }
- }
- else {
- $this =~ s/\$file/'$file'/g;
- $mess = "Can't do $this.\n";
- }
- die "$mess\n" if $disposition eq 'die';
- warn "$mess\n";
- ++$warnings;
-}
-
-1;
-
diff --git a/contrib/perl5/lib/File/Compare.pm b/contrib/perl5/lib/File/Compare.pm
deleted file mode 100644
index 667e7cb883123..0000000000000
--- a/contrib/perl5/lib/File/Compare.pm
+++ /dev/null
@@ -1,182 +0,0 @@
-package File::Compare;
-
-use 5.005_64;
-use strict;
-our($VERSION, @ISA, @EXPORT, @EXPORT_OK, $Too_Big);
-
-require Exporter;
-use Carp;
-
-$VERSION = '1.1002';
-@ISA = qw(Exporter);
-@EXPORT = qw(compare);
-@EXPORT_OK = qw(cmp compare_text);
-
-$Too_Big = 1024 * 1024 * 2;
-
-sub VERSION {
- # Version of File::Compare
- return $File::Compare::VERSION;
-}
-
-sub compare {
- croak("Usage: compare( file1, file2 [, buffersize]) ")
- unless(@_ == 2 || @_ == 3);
-
- 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);
-
- if (ref($from) &&
- (UNIVERSAL::isa($from,'GLOB') || UNIVERSAL::isa($from,'IO::Handle'))) {
- *FROM = *$from;
- } elsif (ref(\$from) eq 'GLOB') {
- *FROM = $from;
- } else {
- open(FROM,"<$from") or goto fail_open1;
- unless ($text_mode) {
- binmode FROM;
- $fromsize = -s FROM;
- }
- $closefrom = 1;
- }
-
- if (ref($to) &&
- (UNIVERSAL::isa($to,'GLOB') || UNIVERSAL::isa($to,'IO::Handle'))) {
- *TO = *$to;
- } elsif (ref(\$to) eq 'GLOB') {
- *TO = $to;
- } else {
- open(TO,"<$to") or goto fail_open2;
- binmode TO unless $text_mode;
- $closeto = 1;
- }
-
- 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 ($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;
- }
-
- 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;
- }
-
- close(TO) || goto fail_open2 if $closeto;
- close(FROM) || goto fail_open1 if $closefrom;
-
- return 0;
-
- # All of these contortions try to preserve error messages...
- fail_inner:
- close(TO) || goto fail_open2 if $closeto;
- close(FROM) || goto fail_open1 if $closefrom;
-
- return 1;
-
- fail_open2:
- if ($closefrom) {
- my $status = $!;
- $! = 0;
- close FROM;
- $! = $status unless $!;
- }
- fail_open1:
- 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__
-
-=head1 NAME
-
-File::Compare - Compare files or filehandles
-
-=head1 SYNOPSIS
-
- use File::Compare;
-
- if (compare("file1","file2") == 0) {
- print "They're equal\n";
- }
-
-=head1 DESCRIPTION
-
-The File::Compare::compare function compares the contents of two
-sources, each of which can be a file or a file handle. It is exported
-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
-files are unequal, or -1 if an error was encountered.
-
-=head1 AUTHOR
-
-File::Compare was written by Nick Ing-Simmons.
-Its original documentation was written by Chip Salzenberg.
-
-=cut
-
diff --git a/contrib/perl5/lib/File/Copy.pm b/contrib/perl5/lib/File/Copy.pm
deleted file mode 100644
index e6cf78603423d..0000000000000
--- a/contrib/perl5/lib/File/Copy.pm
+++ /dev/null
@@ -1,353 +0,0 @@
-# File/Copy.pm. Written in 1994 by Aaron Sherman <ajs@ajs.com>. This
-# source code has been placed in the public domain by the author.
-# Please be kind and preserve the documentation.
-#
-# Additions copyright 1996 by Charles Bailey. Permission is granted
-# to distribute the revised code under the same terms as Perl itself.
-
-package File::Copy;
-
-use 5.005_64;
-use strict;
-use Carp;
-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.03';
-
-require Exporter;
-@ISA = qw(Exporter);
-@EXPORT = qw(copy move);
-@EXPORT_OK = qw(cp mv);
-
-$Too_Big = 1024 * 1024 * 2;
-
-sub _catname { # Will be replaced by File::Spec when it arrives
- my($from, $to) = @_;
- if (not defined &basename) {
- require File::Basename;
- import File::Basename 'basename';
- }
- if ($^O eq 'VMS') { $to = VMS::Filespec::vmspath($to) . basename($from); }
- elsif ($^O eq 'MacOS') { $to .= ':' . basename($from); }
- elsif ($to =~ m|\\|) { $to .= '\\' . basename($from); }
- else { $to .= '/' . basename($from); }
-}
-
-sub copy {
- croak("Usage: copy(FROM, TO [, BUFFERSIZE]) ")
- unless(@_ == 2 || @_ == 3);
-
- my $from = shift;
- my $to = shift;
-
- my $from_a_handle = (ref($from)
- ? (ref($from) eq 'GLOB'
- || UNIVERSAL::isa($from, 'GLOB')
- || UNIVERSAL::isa($from, 'IO::Handle'))
- : (ref(\$from) eq 'GLOB'));
- my $to_a_handle = (ref($to)
- ? (ref($to) eq 'GLOB'
- || UNIVERSAL::isa($to, 'GLOB')
- || UNIVERSAL::isa($to, 'IO::Handle'))
- : (ref(\$to) eq 'GLOB'));
-
- if (!$from_a_handle && !$to_a_handle && -d $to && ! -d $from) {
- $to = _catname($from, $to);
- }
-
- 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);
- }
-
- my $closefrom = 0;
- my $closeto = 0;
- my ($size, $status, $r, $buf);
- local(*FROM, *TO);
- local($\) = '';
-
- if ($from_a_handle) {
- *FROM = *$from{FILEHANDLE};
- } else {
- $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/s;
- open(TO,"> $to\0") or goto fail_open2;
- binmode TO or die "($!,$^E)";
- $closeto = 1;
- }
-
- if (@_) {
- $size = shift(@_) + 0;
- croak("Bad buffer size for copy: $size\n") unless ($size > 0);
- } else {
- $size = -s FROM;
- $size = 1024 if ($size < 512);
- $size = $Too_Big if ($size > $Too_Big);
- }
-
- $! = 0;
- for (;;) {
- my ($r, $w, $t);
- defined($r = sysread(FROM, $buf, $size))
- or goto fail_inner;
- last unless $r;
- for ($w = 0; $w < $r; $w += $t) {
- $t = syswrite(TO, $buf, $r - $w, $w)
- or goto fail_inner;
- }
- }
-
- close(TO) || goto fail_open2 if $closeto;
- close(FROM) || goto fail_open1 if $closefrom;
-
- # Use this idiom to avoid uninitialized value warning.
- return 1;
-
- # All of these contortions try to preserve error messages...
- fail_inner:
- if ($closeto) {
- $status = $!;
- $! = 0;
- close TO;
- $! = $status unless $!;
- }
- fail_open2:
- if ($closefrom) {
- $status = $!;
- $! = 0;
- close FROM;
- $! = $status unless $!;
- }
- fail_open1:
- return 0;
-}
-
-sub move {
- my($from,$to) = @_;
- my($copied,$fromsz,$tosz1,$tomt1,$tosz2,$tomt2,$sts,$ossts);
-
- if (-d $to && ! -d $from) {
- $to = _catname($from, $to);
- }
-
- ($tosz1,$tomt1) = (stat($to))[7,9];
- $fromsz = -s $from;
- if ($^O eq 'os2' and defined $tosz1 and defined $fromsz) {
- # will not rename with overwrite
- unlink $to;
- }
- return 1 if rename $from, $to;
-
- ($sts,$ossts) = ($! + 0, $^E + 0);
- # Did rename return an error even though it succeeded, because $to
- # is on a remote NFS file system, and NFS lost the server's ack?
- return 1 if defined($fromsz) && !-e $from && # $from disappeared
- (($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);
- return 0;
-}
-
-*cp = \&copy;
-*mv = \&move;
-
-# &syscopy is an XSUB under OS/2
-unless (defined &syscopy) {
- if ($^O eq 'VMS') {
- *syscopy = \&rmscopy;
- } elsif ($^O eq 'mpeix') {
- *syscopy = sub {
- return 0 unless @_ == 2;
- # Use the MPE cp program in order to
- # 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 = \&copy;
- }
-}
-
-1;
-
-__END__
-
-=head1 NAME
-
-File::Copy - Copy files or filehandles
-
-=head1 SYNOPSIS
-
- use File::Copy;
-
- copy("file1","file2");
- copy("Copy.pm",\*STDOUT);'
- move("/dev1/fileA","/dev2/fileB");
-
- use POSIX;
- use File::Copy cp;
-
- $n=FileHandle->new("/dev/null","r");
- cp($n,"x");'
-
-=head1 DESCRIPTION
-
-The File::Copy module provides two basic functions, C<copy> and
-C<move>, which are useful for getting the contents of a file from
-one place to another.
-
-=over 4
-
-=item *
-
-The C<copy> function takes two
-parameters: a file to copy from and a file to copy to. Either
-argument may be a string, a FileHandle reference or a FileHandle
-glob. Obviously, if the first argument is a filehandle of some
-sort, it will be read from, and if it is a file I<name> it will
-be opened for reading. Likewise, the second argument will be
-written to (and created if need be).
-
-B<Note that passing in
-files as handles instead of names may lead to loss of information
-on some operating systems; it is recommended that you use file
-names whenever possible.> Files are opened in binary mode where
-applicable. To get a consistent behaviour when copying from a
-filehandle to a file, use C<binmode> on the filehandle.
-
-An optional third parameter can be used to specify the buffer
-size used for copying. This is the number of bytes from the
-first file, that wil be held in memory at any given time, before
-being written to the second file. The default buffer size depends
-upon the file, but will generally be the whole file (up to 2Mb), or
-1k for filehandles that do not reference files (eg. sockets).
-
-You may use the syntax C<use File::Copy "cp"> to get at the
-"cp" alias for this function. The syntax is I<exactly> the same.
-
-=item *
-
-The C<move> function also takes two parameters: the current name
-and the intended name of the file to be moved. If the destination
-already exists and is a directory, and the source is not a
-directory, then the source file will be renamed into the directory
-specified by the destination.
-
-If possible, move() will simply rename the file. Otherwise, it copies
-the file to the new location and deletes the original. If an error occurs
-during this copy-and-delete process, you may be left with a (possibly partial)
-copy of the file under the destination name.
-
-You may use the "mv" alias for this function in the same way that
-you may use the "cp" alias for C<copy>.
-
-=back
-
-File::Copy also provides the C<syscopy> routine, which copies the
-file specified in the first parameter to the file specified in the
-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. For Win32 systems, this calls C<Win32::CopyFile>.
-
-=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
-the input file to a new output file, in order to preserve file
-attributes, indexed file structure, I<etc.> The buffer size
-parameter is ignored. If either argument to C<copy> is a
-handle to an opened file, then data is copied using Perl
-operators, and no effort is made to preserve file attributes
-or record structure.
-
-The system copy routine may also be called directly under VMS and OS/2
-as C<File::Copy::syscopy> (or under VMS as C<File::Copy::rmscopy>, which
-is the routine that does the actual work for syscopy).
-
-=over 4
-
-=item rmscopy($from,$to[,$date_flag])
-
-The first and second arguments may be strings, typeglobs, typeglob
-references, or objects inheriting from IO::Handle;
-they are used in all cases to obtain the
-I<filespec> of the input and output files, respectively. The
-name and type of the input file are used as defaults for the
-output file, if necessary.
-
-A new version of the output file is always created, which
-inherits the structure and RMS attributes of the input file,
-except for owner and protections (and possibly timestamps;
-see below). All data from the input file is copied to the
-output file; if either of the first two parameters to C<rmscopy>
-is a file handle, its position is unchanged. (Note that this
-means a file handle pointing to the output file will be
-associated with an old version of that file after C<rmscopy>
-returns, not the newly created version.)
-
-The third parameter is an integer flag, which tells C<rmscopy>
-how to handle timestamps. If it is E<lt> 0, none of the input file's
-timestamps are propagated to the output file. If it is E<gt> 0, then
-it is interpreted as a bitmask: if bit 0 (the LSB) is set, then
-timestamps other than the revision date are propagated; if bit 1
-is set, the revision date is propagated. If the third parameter
-to C<rmscopy> is 0, then it behaves much like the DCL COPY command:
-if the name or type of the output file was explicitly specified,
-then no timestamps are propagated, but if they were taken implicitly
-from the input filespec, then all timestamps other than the
-revision date are propagated. If this parameter is not supplied,
-it defaults to 0.
-
-Like C<copy>, C<rmscopy> returns 1 on success. If an error occurs,
-it sets C<$!>, deletes the output file, and returns 0.
-
-=back
-
-=head1 RETURN
-
-All functions return 1 on success, 0 on failure.
-$! will be set if an error was encountered.
-
-=head1 AUTHOR
-
-File::Copy was written by Aaron Sherman I<E<lt>ajs@ajs.comE<gt>> in 1995,
-and updated by Charles Bailey I<E<lt>bailey@newman.upenn.eduE<gt>> in 1996.
-
-=cut
-
diff --git a/contrib/perl5/lib/File/DosGlob.pm b/contrib/perl5/lib/File/DosGlob.pm
deleted file mode 100644
index d7dea7b46cf3a..0000000000000
--- a/contrib/perl5/lib/File/DosGlob.pm
+++ /dev/null
@@ -1,254 +0,0 @@
-#!perl -w
-
-#
-# Documentation at the __END__
-#
-
-package File::DosGlob;
-
-sub doglob {
- my $cond = shift;
- my @retval = ();
- #print "doglob: ", join('|', @_), "\n";
- OUTER:
- for my $arg (@_) {
- local $_ = $arg;
- my @matched = ();
- my @globdirs = ();
- my $head = '.';
- my $sepchr = '/';
- next OUTER unless defined $_ and $_ ne '';
- # if arg is within quotes strip em and do no globbing
- if (/^"(.*)"\z/s) {
- $_ = $1;
- if ($cond eq 'd') { push(@retval, $_) if -d $_ }
- else { push(@retval, $_) if -e $_ }
- next OUTER;
- }
- # 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";
- push (@retval, $_), next OUTER if $tail eq '';
- if ($head =~ /[*?]/) {
- @globdirs = doglob('d', $head);
- push(@retval, doglob($cond, map {"$_$sepchr$tail"} @globdirs)),
- next OUTER if @globdirs;
- }
- $head .= $sepchr if $head eq '' or $head =~ /^[A-Za-z]:\z/s;
- $_ = $tail;
- }
- #
- # If file component has no wildcards, we can avoid opendir
- unless (/[*?]/) {
- $head = '' if $head eq '.';
- $head .= $sepchr unless $head eq '' or substr($head,-1) eq $sepchr;
- $head .= $_;
- if ($cond eq 'd') { push(@retval,$head) if -d $head }
- else { push(@retval,$head) if -e $head }
- next OUTER;
- }
- opendir(D, $head) or next OUTER;
- my @leaves = readdir D;
- closedir D;
- $head = '' if $head eq '.';
- $head .= $sepchr unless $head eq '' or substr($head,-1) eq $sepchr;
-
- # escape regex metachars but not glob chars
- s:([].+^\-\${}[|]):\\$1:g;
- # and convert DOS-style wildcards to regex
- s/\*/.*/g;
- s/\?/.?/g;
-
- #print "regex: '$_', head: '$head'\n";
- my $matchsub = eval 'sub { $_[0] =~ m|^' . $_ . '\\z|ios }';
- warn($@), next OUTER if $@;
- INNER:
- for my $e (@leaves) {
- next INNER if $e eq '.' or $e eq '..';
- next INNER if $cond eq 'd' and ! -d "$head$e";
- push(@matched, "$head$e"), next INNER if &$matchsub($e);
- #
- # [DOS compatibility special case]
- # Failed, add a trailing dot and try again, but only
- # if name does not have a dot in it *and* pattern
- # has a dot *and* name is shorter than 9 chars.
- #
- if (index($e,'.') == -1 and length($e) < 9
- and index($_,'\\.') != -1) {
- push(@matched, "$head$e"), next INNER if &$matchsub("$e.");
- }
- }
- push @retval, @matched if @matched;
- }
- return @retval;
-}
-
-#
-# this can be used to override CORE::glob in a specific
-# package by saying C<use File::DosGlob 'glob';> in that
-# namespace.
-#
-
-# context (keyed by second cxix arg provided by core)
-my %iter;
-my %entries;
-
-sub glob {
- my $pat = shift;
- my $cxix = shift;
- my @pat;
-
- # glob without args defaults to $_
- $pat = $_ unless defined $pat;
-
- # extract patterns
- if ($pat =~ /\s/) {
- require Text::ParseWords;
- @pat = Text::ParseWords::parse_line('\s+',0,$pat);
- }
- else {
- push @pat, $pat;
- }
-
- # assume global context if not provided one
- $cxix = '_G_' unless defined $cxix;
- $iter{$cxix} = 0 unless exists $iter{$cxix};
-
- # if we're just beginning, do it all first
- if ($iter{$cxix} == 0) {
- $entries{$cxix} = [doglob(1,@pat)];
- }
-
- # chuck it all out, quick or slow
- if (wantarray) {
- delete $iter{$cxix};
- return @{delete $entries{$cxix}};
- }
- else {
- if ($iter{$cxix} = scalar @{$entries{$cxix}}) {
- return shift @{$entries{$cxix}};
- }
- else {
- # return undef for EOL
- delete $iter{$cxix};
- delete $entries{$cxix};
- return undef;
- }
- }
-}
-
-sub import {
- my $pkg = shift;
- return unless @_;
- my $sym = shift;
- my $callpkg = ($sym =~ s/^GLOBAL_//s ? 'CORE::GLOBAL' : caller(0));
- *{$callpkg.'::'.$sym} = \&{$pkg.'::'.$sym} if $sym eq 'glob';
-}
-
-1;
-
-__END__
-
-=head1 NAME
-
-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?>"
-
-=head1 DESCRIPTION
-
-A module that implements DOS-like globbing with a few enhancements.
-It is largely compatible with perlglob.exe (the M$ setargv.obj
-version) in all but one respect--it understands wildcards in
-directory components.
-
-For example, C<<..\\l*b\\file/*glob.p?>> will work as expected (in
-that it will find something like '..\lib\File/DosGlob.pm' alright).
-Note that all path components are case-insensitive, and that
-backslashes and forward slashes are both accepted, and preserved.
-You may have to double the backslashes if you are putting them in
-literally, due to double-quotish parsing of the pattern by perl.
-
-Spaces in the argument delimit distinct patterns, so
-C<glob('*.exe *.dll')> globs all filenames that end in C<.exe>
-or C<.dll>. If you want to put in literal spaces in the glob
-pattern, you can escape them with either double quotes, or backslashes.
-e.g. C<glob('c:/"Program Files"/*/*.dll')>, or
-C<glob('c:/Program\ Files/*/*.dll')>. The argument is tokenized using
-C<Text::ParseWords::parse_line()>, so see L<Text::ParseWords> for details
-of the quoting rules used.
-
-Extending it to csh patterns is left as an exercise to the reader.
-
-=head1 EXPORTS (by request only)
-
-glob()
-
-=head1 BUGS
-
-Should probably be built into the core, and needs to stop
-pandering to DOS habits. Needs a dose of optimizium too.
-
-=head1 AUTHOR
-
-Gurusamy Sarathy <gsar@activestate.com>
-
-=head1 HISTORY
-
-=over 4
-
-=item *
-
-Support for globally overriding glob() (GSAR 3-JUN-98)
-
-=item *
-
-Scalar context, independent iterator context fixes (GSAR 15-SEP-97)
-
-=item *
-
-A few dir-vs-file optimizations result in glob importation being
-10 times faster than using perlglob.exe, and using perlglob.bat is
-only twice as slow as perlglob.exe (GSAR 28-MAY-97)
-
-=item *
-
-Several cleanups prompted by lack of compatible perlglob.exe
-under Borland (GSAR 27-MAY-97)
-
-=item *
-
-Initial version (GSAR 20-FEB-97)
-
-=back
-
-=head1 SEE ALSO
-
-perl
-
-perlglob.bat
-
-Text::ParseWords
-
-=cut
-
diff --git a/contrib/perl5/lib/File/Find.pm b/contrib/perl5/lib/File/Find.pm
deleted file mode 100644
index ac73f1b5eb245..0000000000000
--- a/contrib/perl5/lib/File/Find.pm
+++ /dev/null
@@ -1,735 +0,0 @@
-package File::Find;
-use 5.005_64;
-require Exporter;
-require Cwd;
-
-=head1 NAME
-
-find - traverse a file tree
-
-finddepth - traverse a directory structure depth-first
-
-=head1 SYNOPSIS
-
- use File::Find;
- find(\&wanted, '/foo', '/bar');
- sub wanted { ... }
-
- use File::Find;
- 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, or a code reference.
-
-Here are the possible keys for the hash:
-
-=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.
-
-
-=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
-
-produces something like:
-
- sub wanted {
- /^\.nfs.*\z/s &&
- (($dev, $ino, $mode, $nlink, $uid, $gid) = lstat($_)) &&
- int(-M _) > 7 &&
- unlink($_)
- ||
- ($nlink || (($dev, $ino, $mode, $nlink, $uid, $gid) = lstat($_))) &&
- $dev < 0 &&
- ($File::Find::prune = 1);
- }
-
-Set the variable C<$File::Find::dont_use_nlink> if you're using AFS,
-since AFS cheats.
-
-
-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";
- }
-
-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.
-
-
-=cut
-
-@ISA = qw(Exporter);
-@EXPORT = qw(find finddepth);
-
-
-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;
- 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;
- }
- }
- }
-
- 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;
- }
- }
- }
- 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++;
- }
-
- $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;
- }
-
- }
- 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;
- }
- }
- }
- }
- 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;
- }
- }
- }
-}
-
-
-# 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 {
- next;
- }
- }
- }
- 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;
- 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), @_);
- %SLnkSeen= (); # free memory
-}
-
-sub finddepth {
- 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;
- $File::Find::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 ($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
deleted file mode 100644
index 46f360a461595..0000000000000
--- a/contrib/perl5/lib/File/Path.pm
+++ /dev/null
@@ -1,238 +0,0 @@
-package File::Path;
-
-=head1 NAME
-
-File::Path - create or remove directory trees
-
-=head1 SYNOPSIS
-
- use File::Path;
-
- mkpath(['/foo/bar/baz', 'blurfl/quux'], 1, 0711);
- rmtree(['foo/bar/baz', 'blurfl/quux'], 1, 1);
-
-=head1 DESCRIPTION
-
-The C<mkpath> function provides a convenient way to create directories, even
-if your C<mkdir> kernel call won't create more than one level of directory at
-a time. C<mkpath> takes three arguments:
-
-=over 4
-
-=item *
-
-the name of the path to create, or a reference
-to a list of paths to create,
-
-=item *
-
-a boolean value, which if TRUE will cause C<mkpath>
-to print the name of each directory as it is created
-(defaults to FALSE), and
-
-=item *
-
-the numeric mode to use when creating the directories
-(defaults to 0777)
-
-=back
-
-It returns a list of all directories (including intermediates, determined
-using the Unix '/' separator) created.
-
-Similarly, the C<rmtree> function provides a convenient way to delete a
-subtree from the directory structure, much like the Unix command C<rm -r>.
-C<rmtree> takes three arguments:
-
-=over 4
-
-=item *
-
-the root of the subtree to delete, or a reference to
-a list of roots. All of the files and directories
-below each root, as well as the roots themselves,
-will be deleted.
-
-=item *
-
-a boolean value, which if TRUE will cause C<rmtree> to
-print a message each time it examines a file, giving the
-name of the file, and indicating whether it's using C<rmdir>
-or C<unlink> to remove it, or that it's skipping it.
-(defaults to FALSE)
-
-=item *
-
-a boolean value, which if TRUE will cause C<rmtree> to
-skip any files to which you do not have delete access
-(if running under VMS) or write access (if running
-under another OS). This will change in the future when
-a criterion for 'delete permission' under OSs other
-than VMS is settled. (defaults to FALSE)
-
-=back
-
-It returns the number of files successfully deleted. Symlinks are
-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
-were not deleted may be left with permissions reset to allow world
-read and write access. Note also that the occurrence of errors in
-rmtree can be determined I<only> by trapping diagnostic messages
-using C<$SIG{__WARN__}>; it is not apparent from the return value.
-Therefore, you must be extremely careful about using C<rmtree($foo,$bar,0>
-in situations where security is an issue.
-
-=head1 AUTHORS
-
-Tim Bunce <F<Tim.Bunce@ig.co.uk>> and
-Charles Bailey <F<bailey@newman.upenn.edu>>
-
-=cut
-
-use 5.005_64;
-use Carp;
-use File::Basename ();
-use Exporter ();
-use strict;
-
-our $VERSION = "1.0403";
-our @ISA = qw( Exporter );
-our @EXPORT = qw( mkpath rmtree );
-
-my $Is_VMS = $^O eq 'VMS';
-
-# These OSes complain if you want to remove a file that you have no
-# write permission to:
-my $force_writeable = ($^O eq 'os2' || $^O eq 'dos' || $^O eq 'MSWin32'
- || $^O eq 'amigaos');
-
-sub mkpath {
- my($paths, $verbose, $mode) = @_;
- # $paths -- either a path string or ref to list of paths
- # $verbose -- optional print "mkdir $path" for each directory created
- # $mode -- optional permissions, defaults to 0777
- local($")="/";
- $mode = 0777 unless defined($mode);
- $paths = [$paths] unless ref $paths;
- my(@created,$path);
- foreach $path (@$paths) {
- $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/?:) {
- 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;
- }
- push(@created, $path);
- }
- @created;
-}
-
-sub rmtree {
- my($roots, $verbose, $safe) = @_;
- my(@files);
- my($count) = 0;
- $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#/\z##;
- (undef, undef, my $rp) = lstat $root or next;
- $rp &= 07777; # don't forget setuid, setgid, sticky bits
- if ( -d _ ) {
- # notabene: 0777 is for making readable in the first place,
- # it's also intended to change it to writable in case we have
- # to recurse in which case we are better than rm -rf for
- # subtrees with strange permissions
- chmod(0777, ($Is_VMS ? VMS::Filespec::fileify($root) : $root))
- or carp "Can't make directory $root read+writeable: $!"
- unless $safe;
-
- 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\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)) {
- print "skipped $root\n" if $verbose;
- next;
- }
- chmod 0777, $root
- or carp "Can't make directory $root writeable: $!"
- if $force_writeable;
- print "rmdir $root\n" if $verbose;
- if (rmdir $root) {
- ++$count;
- }
- else {
- carp "Can't remove directory $root: $!";
- chmod($rp, ($Is_VMS ? VMS::Filespec::fileify($root) : $root))
- or carp("and can't restore permissions to "
- . sprintf("0%o",$rp) . "\n");
- }
- }
- else {
- if ($safe &&
- ($Is_VMS ? !&VMS::Filespec::candelete($root)
- : !(-l $root || -w $root)))
- {
- print "skipped $root\n" if $verbose;
- next;
- }
- chmod 0666, $root
- or carp "Can't make file $root writeable: $!"
- if $force_writeable;
- print "unlink $root\n" if $verbose;
- # delete all versions under VMS
- for (;;) {
- unless (unlink $root) {
- carp "Can't unlink file $root: $!";
- if ($force_writeable) {
- chmod $rp, $root
- or carp("and can't restore permissions to "
- . sprintf("0%o",$rp) . "\n");
- }
- last;
- }
- ++$count;
- last unless $Is_VMS && lstat $root;
- }
- }
- }
-
- $count;
-}
-
-1;
diff --git a/contrib/perl5/lib/File/Spec.pm b/contrib/perl5/lib/File/Spec.pm
deleted file mode 100644
index 40f5345140c7f..0000000000000
--- a/contrib/perl5/lib/File/Spec.pm
+++ /dev/null
@@ -1,92 +0,0 @@
-package File::Spec;
-
-use strict;
-use vars qw(@ISA $VERSION);
-
-$VERSION = '0.8';
-
-my %module = (MacOS => 'Mac',
- MSWin32 => 'Win32',
- os2 => 'OS2',
- VMS => 'VMS');
-
-my $module = $module{$^O} || 'Unix';
-require "File/Spec/$module.pm";
-@ISA = ("File::Spec::$module");
-
-1;
-__END__
-
-=head1 NAME
-
-File::Spec - portably perform operations on file names
-
-=head1 SYNOPSIS
-
- use File::Spec;
-
- $x=File::Spec->catfile('a', 'b', 'c');
-
-which returns 'a/b/c' under Unix. Or:
-
- use File::Spec::Functions;
-
- $x = catfile('a', 'b', 'c');
-
-=head1 DESCRIPTION
-
-This module is designed to support operations commonly performed on file
-specifications (usually called "file names", but not to be confused with the
-contents of a file, or Perl's file handles), such as concatenating several
-directory and file names into a single path, or determining whether a path
-is rooted. It is based on code directly taken from MakeMaker 5.17, code
-written by Andreas KE<ouml>nig, Andy Dougherty, Charles Bailey, Ilya
-Zakharevich, Paul Schinder, and others.
-
-Since these functions are different for most operating systems, each set of
-OS specific routines is available in a separate module, including:
-
- File::Spec::Unix
- File::Spec::Mac
- File::Spec::OS2
- File::Spec::Win32
- File::Spec::VMS
-
-The module appropriate for the current OS is automatically loaded by
-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 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, File::Spec::Functions, ExtUtils::MakeMaker
-
-=head1 AUTHORS
-
-Kenneth Albanowski <F<kjahds@kjahds.com>>, Andy Dougherty
-<F<doughera@lafcol.lafayette.edu>>, Andreas KE<ouml>nig
-<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>>. 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
deleted file mode 100644
index 140738f443986..0000000000000
--- a/contrib/perl5/lib/File/Spec/Functions.pm
+++ /dev/null
@@ -1,95 +0,0 @@
-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
deleted file mode 100644
index 959e33d0cf3bc..0000000000000
--- a/contrib/perl5/lib/File/Spec/Mac.pm
+++ /dev/null
@@ -1,397 +0,0 @@
-package File::Spec::Mac;
-
-use strict;
-use vars qw(@ISA);
-require File::Spec::Unix;
-@ISA = qw(File::Spec::Unix);
-
-=head1 NAME
-
-File::Spec::Mac - File::Spec for MacOS
-
-=head1 SYNOPSIS
-
- require File::Spec::Mac; # Done internally by File::Spec if needed
-
-=head1 DESCRIPTION
-
-Methods for manipulating file specifications.
-
-=head1 METHODS
-
-=over 2
-
-=item canonpath
-
-On MacOS, there's nothing to be done. Returns what it's given.
-
-=cut
-
-sub canonpath {
- my ($self,$path) = @_;
- return $path;
-}
-
-=item catdir
-
-Concatenate two or more directory names to form a complete path ending with
-a directory. Put a trailing : on the end of the complete path if there
-isn't one, because that's what's done in MacPerl's environment.
-
-The fundamental requirement of this routine is that
-
- File::Spec->catdir(split(":",$path)) eq $path
-
-But because of the nature of Macintosh paths, some additional
-possibilities are allowed to make using this routine give reasonable results
-for some common situations. Here are the rules that are used. Each
-argument has its trailing ":" removed. Each argument, except the first,
-has its leading ":" removed. They are then joined together by a ":".
-
-So
-
- File::Spec->catdir("a","b") = "a:b:"
- File::Spec->catdir("a:",":b") = "a:b:"
- File::Spec->catdir("a:","b") = "a:b:"
- File::Spec->catdir("a",":b") = "a:b"
- File::Spec->catdir("a","","b") = "a::b"
-
-etc.
-
-To get a relative path (one beginning with :), begin the first argument with :
-or put a "" as the first argument.
-
-If you don't want to worry about these rules, never allow a ":" on the ends
-of any of the arguments except at the beginning of the first.
-
-Under MacPerl, there is an additional ambiguity. Does the user intend that
-
- File::Spec->catfile("LWP","Protocol","http.pm")
-
-be relative or absolute? There's no way of telling except by checking for the
-existence of LWP: or :LWP, and even there he may mean a dismounted volume or
-a relative path in a different directory (like in @INC). So those checks
-aren't done here. This routine will treat this as absolute.
-
-=cut
-
-sub catdir {
- shift;
- my @args = @_;
- my $result = shift @args;
- $result =~ s/:\z//;
- foreach (@args) {
- s/:\z//;
- s/^://s;
- $result .= ":$_";
- }
- return "$result:";
-}
-
-=item catfile
-
-Concatenate one or more directory names and a filename to form a
-complete path ending with a filename. Since this uses catdir, the
-same caveats apply. Note that the leading : is removed from the filename,
-so that
-
- File::Spec->catfile($ENV{HOME},"file");
-
-and
-
- File::Spec->catfile($ENV{HOME},":file");
-
-give the same answer, as one might expect.
-
-=cut
-
-sub catfile {
- my $self = shift;
- my $file = pop @_;
- return $file unless @_;
- my $dir = $self->catdir(@_);
- $file =~ s/^://s;
- return $dir.$file;
-}
-
-=item curdir
-
-Returns a string representing the current directory.
-
-=cut
-
-sub curdir {
- 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.
-
-=cut
-
-sub rootdir {
-#
-# There's no real root directory on MacOS. The name of the startup
-# volume is returned, since that's the closest in concept.
-#
- 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
-
-Returns a string representing the parent directory.
-
-=cut
-
-sub updir {
- return "::";
-}
-
-=item file_name_is_absolute
-
-Takes as argument a path and returns true, if it is an absolute path. In
-the case where a name can be either relative or absolute (for example, a
-folder named "HD" in the current working directory on a drive named "HD"),
-relative wins. Use ":" in the appropriate place in the path if you want to
-distinguish unambiguously.
-
-=cut
-
-sub file_name_is_absolute {
- my ($self,$file) = @_;
- if ($file =~ /:/) {
- return ($file !~ m/^:/s);
- } else {
- return (! -e ":$file");
- }
-}
-
-=item path
-
-Returns the null list for the MacPerl application, since the concept is
-usually meaningless under MacOS. But if you're using the MacPerl tool under
-MPW, it gives back $ENV{Commands} suitably split, as is done in
-:lib:ExtUtils:MM_Mac.pm.
-
-=cut
-
-sub path {
-#
-# The concept is meaningless under the MacPerl application.
-# Under MPW, it has a meaning.
-#
- 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
-
-L<File::Spec>
-
-=cut
-
-1;
diff --git a/contrib/perl5/lib/File/Spec/OS2.pm b/contrib/perl5/lib/File/Spec/OS2.pm
deleted file mode 100644
index 33370f06c1959..0000000000000
--- a/contrib/perl5/lib/File/Spec/OS2.pm
+++ /dev/null
@@ -1,59 +0,0 @@
-package File::Spec::OS2;
-
-use strict;
-use vars qw(@ISA);
-require File::Spec::Unix;
-@ISA = qw(File::Spec::Unix);
-
-sub devnull {
- return "/dev/nul";
-}
-
-sub case_tolerant {
- return 1;
-}
-
-sub file_name_is_absolute {
- my ($self,$file) = @_;
- return scalar($file =~ m{^([a-z]:)?[\\/]}is);
-}
-
-sub path {
- my $path = $ENV{PATH};
- $path =~ s:\\:/:g;
- 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;
-__END__
-
-=head1 NAME
-
-File::Spec::OS2 - methods for OS/2 file specs
-
-=head1 SYNOPSIS
-
- 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.
diff --git a/contrib/perl5/lib/File/Spec/Unix.pm b/contrib/perl5/lib/File/Spec/Unix.pm
deleted file mode 100644
index 2305b75b761f8..0000000000000
--- a/contrib/perl5/lib/File/Spec/Unix.pm
+++ /dev/null
@@ -1,442 +0,0 @@
-package File::Spec::Unix;
-
-use strict;
-
-use Cwd;
-
-=head1 NAME
-
-File::Spec::Unix - methods used by File::Spec
-
-=head1 SYNOPSIS
-
- require File::Spec::Unix; # Done automatically by File::Spec
-
-=head1 DESCRIPTION
-
-Methods for manipulating file specifications.
-
-=head1 METHODS
-
-=over 2
-
-=item canonpath
-
-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 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
-
-Concatenate two or more directory names to form a complete path ending
-with a directory. But remove the trailing slash from the resulting
-string, because it doesn't look good, isn't necessary and confuses
-OS2. Of course, if this is the root directory, don't cut off the
-trailing slash :-)
-
-=cut
-
-sub catdir {
- my $self = shift;
- my @args = @_;
- foreach (@args) {
- # append a slash to each argument unless it has one there
- $_ .= "/" if $_ eq '' || substr($_,-1) ne "/";
- }
- return $self->canonpath(join('', @args));
-}
-
-=item catfile
-
-Concatenate one or more directory names and a filename to form a
-complete path ending with a filename
-
-=cut
-
-sub catfile {
- my $self = shift;
- my $file = pop @_;
- return $file unless @_;
- my $dir = $self->catdir(@_);
- $dir .= "/" unless substr($dir,-1) eq "/";
- return $dir.$file;
-}
-
-=item curdir
-
-Returns a string representation of the current directory. "." on UNIX.
-
-=cut
-
-sub curdir {
- 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 representation of the root directory. "/" on UNIX.
-
-=cut
-
-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 representation of the parent directory. ".." on UNIX.
-
-=cut
-
-sub updir {
- return "..";
-}
-
-=item no_upwards
-
-Given a list of file names, strip out those that refer to a parent
-directory. (Does not strip symlinks, only '.', '..', and equivalents.)
-
-=cut
-
-sub no_upwards {
- 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
-
-Takes as argument a path and returns true, if it is an absolute path.
-
-=cut
-
-sub file_name_is_absolute {
- my ($self,$file) = @_;
- return scalar($file =~ m:^/:s);
-}
-
-=item path
-
-Takes no argument, returns the environment variable PATH as an array.
-
-=cut
-
-sub path {
- my @path = split(':', $ENV{PATH});
- foreach (@path) { $_ = '.' if $_ eq '' }
- return @path;
-}
-
-=item join
-
-join is the same as catfile.
-
-=cut
-
-sub join {
- 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 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 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
-
-L<File::Spec>
-
-=cut
-
-1;
diff --git a/contrib/perl5/lib/File/Spec/VMS.pm b/contrib/perl5/lib/File/Spec/VMS.pm
deleted file mode 100644
index a2ac8cac0bb53..0000000000000
--- a/contrib/perl5/lib/File/Spec/VMS.pm
+++ /dev/null
@@ -1,492 +0,0 @@
-package File::Spec::VMS;
-
-use strict;
-use vars qw(@ISA);
-require File::Spec::Unix;
-@ISA = qw(File::Spec::Unix);
-
-use Cwd;
-use File::Basename;
-use VMS::Filespec;
-
-=head1 NAME
-
-File::Spec::VMS - methods for VMS file specs
-
-=head1 SYNOPSIS
-
- require File::Spec::VMS; # 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.
-
-=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. 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;
- @dirs = grep($_,@dirs);
- my $rslt;
- if (@dirs) {
- 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 (not defined $dir or not length $dir) { $rslt = ''; }
- elsif ($dir =~ /^\$\([^\)]+\)\z/s) { $rslt = $dir; }
- else { $rslt = vmspath($dir); }
- }
- return $self->canonpath($rslt);
-}
-
-=item catfile
-
-Concatenates a list of file specifications, and returns the result as a
-VMS-syntax file specification.
-
-=cut
-
-sub catfile {
- my ($self,@files) = @_;
- my $file = pop @files;
- @files = grep($_,@files);
- my $rslt;
- if (@files) {
- 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 = (defined($file) && length($file)) ? vmsify($file) : ''; }
- return $self->canonpath($rslt);
-}
-
-
-=item curdir (override)
-
-Returns a string representation of the current directory: '[]'
-
-=cut
-
-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 representation of the root directory: 'SYS$DISK:[000000]'
-
-=cut
-
-sub rootdir {
- 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 representation of the parent directory: '[-]'
-
-=cut
-
-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
-to C<split> string value of C<$ENV{'PATH'}>.
-
-=cut
-
-sub path {
- my (@dirs,$dir,$i);
- while ($dir = $ENV{'DCL$PATH;' . $i++}) { push(@dirs,$dir); }
- return @dirs;
-}
-
-=item file_name_is_absolute (override)
-
-Checks for VMS directory spec as well as Unix separators.
-
-=cut
-
-sub file_name_is_absolute {
- my ($self,$file) = @_;
- # If it's a logical name, expand it.
- $file = $ENV{$file} while $file =~ /^[\w\$\-]+\z/s && $ENV{$file};
- return scalar($file =~ m!^/!s ||
- $file =~ m![<\[][^.\-\]>]! ||
- $file =~ /:[^<\[]/);
-}
-
-=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
deleted file mode 100644
index aa95fbde363e4..0000000000000
--- a/contrib/perl5/lib/File/Spec/Win32.pm
+++ /dev/null
@@ -1,405 +0,0 @@
-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
-
- require File::Spec::Win32; # 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.
-
-=over
-
-=item devnull
-
-Returns a string representation of the null device.
-
-=cut
-
-sub devnull {
- return "nul";
-}
-
-=item tmpdir
-
-Returns a string representation of the first existing directory
-from the following list:
-
- $ENV{TMPDIR}
- $ENV{TEMP}
- $ENV{TMP}
- /tmp
- /
-
-=cut
-
-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 = $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
-
-Concatenate one or more directory names and a filename to form a
-complete path ending with a filename
-
-=cut
-
-sub catfile {
- my $self = shift;
- my $file = pop @_;
- return $file unless @_;
- my $dir = $self->catdir(@_);
- $dir .= "\\" unless substr($dir,-1) eq "\\";
- return $dir.$file;
-}
-
-sub path {
- my $path = $ENV{'PATH'} || $ENV{'Path'} || $ENV{'path'};
- my @path = split(';',$path);
- foreach (@path) { $_ = '.' if $_ eq '' }
- return @path;
-}
-
-=item canonpath
-
-No physical check on the filesystem, but a logical cleanup of a
-path. On UNIX eliminated successive slashes and successive "/.".
-
-=cut
-
-sub canonpath {
- my ($self,$path) = @_;
- $path =~ s/^([a-z]:)/\u$1/s;
- $path =~ s|/|\\|g;
- $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;
-}
-
-=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
-
-=head1 SEE ALSO
-
-L<File::Spec>
-
-=cut
-
-1;
diff --git a/contrib/perl5/lib/File/stat.pm b/contrib/perl5/lib/File/stat.pm
deleted file mode 100644
index 0cf7a0b7aa82d..0000000000000
--- a/contrib/perl5/lib/File/stat.pm
+++ /dev/null
@@ -1,115 +0,0 @@
-package File::stat;
-use strict;
-
-use 5.005_64;
-our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS);
-
-BEGIN {
- use Exporter ();
- @EXPORT = qw(stat lstat);
- @EXPORT_OK = qw( $st_dev $st_ino $st_mode
- $st_nlink $st_uid $st_gid
- $st_rdev $st_size
- $st_atime $st_mtime $st_ctime
- $st_blksize $st_blocks
- );
- %EXPORT_TAGS = ( FIELDS => [ @EXPORT_OK, @EXPORT ] );
-}
-use vars @EXPORT_OK;
-
-# Class::Struct forbids use of @ISA
-sub import { goto &Exporter::import }
-
-use Class::Struct qw(struct);
-struct 'File::stat' => [
- map { $_ => '$' } qw{
- dev ino mode nlink uid gid rdev size
- atime mtime ctime blksize blocks
- }
-];
-
-sub populate (@) {
- return unless @_;
- my $stob = new();
- @$stob = (
- $st_dev, $st_ino, $st_mode, $st_nlink, $st_uid, $st_gid, $st_rdev,
- $st_size, $st_atime, $st_mtime, $st_ctime, $st_blksize, $st_blocks )
- = @_;
- return $stob;
-}
-
-sub lstat ($) { populate(CORE::lstat(shift)) }
-
-sub stat ($) {
- my $arg = shift;
- my $st = populate(CORE::stat $arg);
- return $st if $st;
- no strict 'refs';
- require Symbol;
- return populate(CORE::stat \*{Symbol::qualify($arg)});
-}
-
-1;
-__END__
-
-=head1 NAME
-
-File::stat - by-name interface to Perl's built-in stat() functions
-
-=head1 SYNOPSIS
-
- use File::stat;
- $st = stat($file) or die "No $file: $!";
- if ( ($st->mode & 0111) && $st->nlink > 1) ) {
- print "$file is executable with lotsa links\n";
- }
-
- use File::stat qw(:FIELDS);
- stat($file) or die "No $file: $!";
- if ( ($st_mode & 0111) && $st_nlink > 1) ) {
- print "$file is executable with lotsa links\n";
- }
-
-=head1 DESCRIPTION
-
-This module's default exports override the core stat()
-and lstat() functions, replacing them with versions that return
-"File::stat" objects. This object has methods that
-return the similarly named structure field name from the
-stat(2) function; namely,
-dev,
-ino,
-mode,
-nlink,
-uid,
-gid,
-rdev,
-size,
-atime,
-mtime,
-ctime,
-blksize,
-and
-blocks.
-
-You may also import all the structure fields directly into your namespace
-as regular variables using the :FIELDS import tag. (Note that this still
-overrides your stat() and lstat() functions.) Access these fields as
-variables named with a preceding C<st_> in front their method names.
-Thus, C<$stat_obj-E<gt>dev()> corresponds to $st_dev if you import
-the fields.
-
-To access this functionality without the core overrides,
-pass the C<use> an empty import list, and then access
-function functions with their full qualified names.
-On the other hand, the built-ins are still available
-via the C<CORE::> pseudo-package.
-
-=head1 NOTE
-
-While this class is currently implemented using the Class::Struct
-module to build a struct-like class, you shouldn't rely upon this.
-
-=head1 AUTHOR
-
-Tom Christiansen