summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/File
diff options
context:
space:
mode:
authorKarl Berry <karl@freefriends.org>2012-05-21 00:15:27 +0000
committerKarl Berry <karl@freefriends.org>2012-05-21 00:15:27 +0000
commita4c42bfb2337d37da89d789cb8cc226367994e32 (patch)
treec3eabdef5d565a4e515d2be0d9d4d0540bde0250 /Master/tlpkg/tlperl/lib/File
parent8274475057f024d35332ac47c2e2f23ea156e6ed (diff)
perl 5.14.2 from siep
git-svn-id: svn://tug.org/texlive/trunk@26525 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Master/tlpkg/tlperl/lib/File')
-rw-r--r--Master/tlpkg/tlperl/lib/File/Basename.pm8
-rw-r--r--Master/tlpkg/tlperl/lib/File/CheckTree.pm8
-rw-r--r--Master/tlpkg/tlperl/lib/File/Copy.pm62
-rw-r--r--Master/tlpkg/tlperl/lib/File/DosGlob.pm275
-rw-r--r--Master/tlpkg/tlperl/lib/File/Fetch.pm210
-rw-r--r--Master/tlpkg/tlperl/lib/File/Find.pm350
-rw-r--r--Master/tlpkg/tlperl/lib/File/Glob.pm97
-rw-r--r--Master/tlpkg/tlperl/lib/File/GlobMapper.pm4
-rw-r--r--Master/tlpkg/tlperl/lib/File/Listing.pm45
-rw-r--r--Master/tlpkg/tlperl/lib/File/Spec.pm9
-rw-r--r--Master/tlpkg/tlperl/lib/File/Spec/Cygwin.pm2
-rw-r--r--Master/tlpkg/tlperl/lib/File/Spec/Epoc.pm2
-rw-r--r--Master/tlpkg/tlperl/lib/File/Spec/Functions.pm2
-rw-r--r--Master/tlpkg/tlperl/lib/File/Spec/Mac.pm4
-rw-r--r--Master/tlpkg/tlperl/lib/File/Spec/OS2.pm2
-rw-r--r--Master/tlpkg/tlperl/lib/File/Spec/Unix.pm2
-rw-r--r--Master/tlpkg/tlperl/lib/File/Spec/VMS.pm14
-rw-r--r--Master/tlpkg/tlperl/lib/File/Spec/Win32.pm2
-rw-r--r--Master/tlpkg/tlperl/lib/File/Which.pm254
-rw-r--r--Master/tlpkg/tlperl/lib/File/stat.pm9
20 files changed, 354 insertions, 1007 deletions
diff --git a/Master/tlpkg/tlperl/lib/File/Basename.pm b/Master/tlpkg/tlperl/lib/File/Basename.pm
index d842844daf1..486eba1bbf6 100644
--- a/Master/tlpkg/tlperl/lib/File/Basename.pm
+++ b/Master/tlpkg/tlperl/lib/File/Basename.pm
@@ -54,7 +54,7 @@ our(@ISA, @EXPORT, $VERSION, $Fileparse_fstype, $Fileparse_igncase);
require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(fileparse fileparse_set_fstype basename dirname);
-$VERSION = "2.78";
+$VERSION = "2.82";
fileparse_set_fstype($^O);
@@ -78,8 +78,8 @@ The remainder of the $path is the $filename.
# On Unix returns ("baz", "/foo/bar/", "")
fileparse("/foo/bar/baz");
- # On Windows returns ("baz", "C:\foo\bar\", "")
- fileparse("C:\foo\bar\baz");
+ # On Windows returns ("baz", 'C:\foo\bar\', "")
+ fileparse('C:\foo\bar\baz');
# On Unix returns ("", "/foo/bar/baz/", "")
fileparse("/foo/bar/baz/");
@@ -170,7 +170,7 @@ sub fileparse {
}
}
- # Ensure taint is propgated from the path to its pieces.
+ # Ensure taint is propagated from the path to its pieces.
$tail .= $taint;
wantarray ? ($basename .= $taint, $dirpath .= $taint, $tail)
: ($basename .= $taint);
diff --git a/Master/tlpkg/tlperl/lib/File/CheckTree.pm b/Master/tlpkg/tlperl/lib/File/CheckTree.pm
index d7948f2385f..4d53c5254dd 100644
--- a/Master/tlpkg/tlperl/lib/File/CheckTree.pm
+++ b/Master/tlpkg/tlperl/lib/File/CheckTree.pm
@@ -7,7 +7,7 @@ use File::Spec;
use warnings;
use strict;
-our $VERSION = '4.4';
+our $VERSION = '4.41';
our @ISA = qw(Exporter);
our @EXPORT = qw(validate);
@@ -119,7 +119,7 @@ sub validate {
my $this = $test;
# expand relative $file to full pathname if preceded by cd directive
- $file = File::Spec->catfile($cwd, $file)
+ $file = File::Spec->catfile($cwd, $file)
if $cwd && !File::Spec->file_name_is_absolute($file);
# put filename in after the test operator
@@ -137,7 +137,7 @@ sub validate {
}
else {
# add "|| warn" as a default disposition
- $this .= ' || warn' unless $this =~ /\|\|/;
+ $this .= ' || warn' unless $this =~ /\|\|/;
# change a generic ".. || die" or ".. || warn"
# to call valmess instead of die/warn directly
@@ -163,7 +163,7 @@ sub validate {
# do the test
eval $this;
- # re-raise an exception caused by a "... || die" test
+ # re-raise an exception caused by a "... || die" test
if (my $err = $@) {
# in case of any cd directives, return from whence we came
if ($starting_dir ne cwd) {
diff --git a/Master/tlpkg/tlperl/lib/File/Copy.pm b/Master/tlpkg/tlperl/lib/File/Copy.pm
index eed6a53195b..1cf084bb916 100644
--- a/Master/tlpkg/tlperl/lib/File/Copy.pm
+++ b/Master/tlpkg/tlperl/lib/File/Copy.pm
@@ -22,7 +22,7 @@ sub syscopy;
sub cp;
sub mv;
-$VERSION = '2.18';
+$VERSION = '2.21';
require Exporter;
@ISA = qw(Exporter);
@@ -41,13 +41,6 @@ sub carp {
goto &Carp::carp;
}
-my $macfiles;
-if ($^O eq 'MacOS') {
- $macfiles = eval { require Mac::MoreFiles };
- warn 'Mac::MoreFiles could not be loaded; using non-native syscopy'
- if $@ && $^W;
-}
-
# Look up the feature settings on VMS using VMS::Feature when available.
my $use_vms_feature = 0;
@@ -93,11 +86,6 @@ sub _catname {
import File::Basename 'basename';
}
- if ($^O eq 'MacOS') {
- # a partial dir name that's valid only in the cwd (e.g. 'tmp')
- $to = ':' . $to if $to !~ /:/;
- }
-
return File::Spec->catfile($to, basename($from));
}
@@ -166,7 +154,6 @@ sub copy {
&& !($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')
- && !($from_a_handle && $^O eq 'MacOS')
&& !($from_a_handle && $^O eq 'NetWare')
)
{
@@ -436,22 +423,6 @@ unless (defined &syscopy) {
return 0 unless @_ == 2;
return Win32::CopyFile(@_, 1);
};
- } elsif ($macfiles) {
- *syscopy = sub {
- my($from, $to) = @_;
- my($dir, $toname);
-
- return 0 unless -e $from;
-
- if ($to =~ /(.*:)([^:]+):?$/) {
- ($dir, $toname) = ($1, $2);
- } else {
- ($dir, $toname) = (":", $to);
- }
-
- unlink($to);
- Mac::MoreFiles::FSpFileCopy($from, $dir, $toname, 1);
- };
} else {
$Syscopy_is_copy = 1;
*syscopy = \&copy;
@@ -558,9 +529,6 @@ 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>.
-On Mac OS (Classic), C<syscopy> calls C<Mac::MoreFiles::FSpFileCopy>,
-if available.
-
B<Special behaviour if C<syscopy> is defined (OS/2, VMS and Win32)>:
If both arguments to C<copy> are not file handles,
@@ -619,34 +587,6 @@ it sets C<$!>, deletes the output file, and returns 0.
All functions return 1 on success, 0 on failure.
$! will be set if an error was encountered.
-=head1 NOTES
-
-=over 4
-
-=item *
-
-On Mac OS (Classic), the path separator is ':', not '/', and the
-current directory is denoted as ':', not '.'. You should be careful
-about specifying relative pathnames. While a full path always begins
-with a volume name, a relative pathname should always begin with a
-':'. If specifying a volume name only, a trailing ':' is required.
-
-E.g.
-
- copy("file1", "tmp"); # creates the file 'tmp' in the current directory
- copy("file1", ":tmp:"); # creates :tmp:file1
- copy("file1", ":tmp"); # same as above
- copy("file1", "tmp"); # same as above, if 'tmp' is a directory (but don't do
- # that, since it may cause confusion, see example #1)
- copy("file1", "tmp:file1"); # error, since 'tmp:' is not a volume
- copy("file1", ":tmp:file1"); # ok, partial path
- copy("file1", "DataHD:"); # creates DataHD:file1
-
- move("MacintoshHD:fileA", "DataHD:fileB"); # moves (doesn't copy) files from one
- # volume to another
-
-=back
-
=head1 AUTHOR
File::Copy was written by Aaron Sherman I<E<lt>ajs@ajs.comE<gt>> in 1995,
diff --git a/Master/tlpkg/tlperl/lib/File/DosGlob.pm b/Master/tlpkg/tlperl/lib/File/DosGlob.pm
index 496a14c1379..90434fd467d 100644
--- a/Master/tlpkg/tlperl/lib/File/DosGlob.pm
+++ b/Master/tlpkg/tlperl/lib/File/DosGlob.pm
@@ -9,13 +9,14 @@
package File::DosGlob;
-our $VERSION = '1.01';
+our $VERSION = '1.04';
use strict;
use warnings;
sub doglob {
my $cond = shift;
my @retval = ();
+ my $fix_drive_relative_paths;
#print "doglob: ", join('|', @_), "\n";
OUTER:
for my $pat (@_) {
@@ -36,6 +37,7 @@ sub doglob {
# to h:./*.pm to expand correctly
if ($pat =~ m|^([A-Za-z]:)[^/\\]|s) {
substr($pat,0,2) = $1 . "./";
+ $fix_drive_relative_paths = 1;
}
if ($pat =~ m|^(.*)([\\/])([^\\/]*)\z|s) {
($head, $sepchr, $tail) = ($1,$2,$3);
@@ -66,7 +68,7 @@ sub doglob {
$head .= $sepchr unless $head eq '' or substr($head,-1) eq $sepchr;
# escape regex metachars but not glob chars
- $pat =~ s:([].+^\-\${}[|]):\\$1:g;
+ $pat =~ s:([].+^\-\${}()[|]):\\$1:g;
# and convert DOS-style wildcards to regex
$pat =~ s/\*/.*/g;
$pat =~ s/\?/.?/g;
@@ -91,211 +93,13 @@ sub doglob {
}
push @retval, @matched if @matched;
}
- return @retval;
-}
-
-
-#
-# Do DOS-like globbing on Mac OS
-#
-sub doglob_Mac {
- my $cond = shift;
- my @retval = ();
-
- #print "doglob_Mac: ", join('|', @_), "\n";
- OUTER:
- for my $arg (@_) {
- local $_ = $arg;
- my @matched = ();
- my @globdirs = ();
- my $head = ':';
- my $not_esc_head = $head;
- my $sepchr = ':';
- next OUTER unless defined $_ and $_ ne '';
- # if arg is within quotes strip em and do no globbing
- if (/^"(.*)"\z/s) {
- $_ = $1;
- # $_ may contain escaped metachars '\*', '\?' and '\'
- my $not_esc_arg = $_;
- $not_esc_arg =~ s/\\([*?\\])/$1/g;
- if ($cond eq 'd') { push(@retval, $not_esc_arg) if -d $not_esc_arg }
- else { push(@retval, $not_esc_arg) if -e $not_esc_arg }
- next OUTER;
- }
-
- if (m|^(.*?)(:+)([^:]*)\z|s) { # note: $1 is not greedy
- my $tail;
- ($head, $sepchr, $tail) = ($1,$2,$3);
- #print "div: |$head|$sepchr|$tail|\n";
- push (@retval, $_), next OUTER if $tail eq '';
- #
- # $head may contain escaped metachars '\*' and '\?'
-
- my $tmp_head = $head;
- # if a '*' or '?' is preceded by an odd count of '\', temporary delete
- # it (and its preceding backslashes), i.e. don't treat '\*' and '\?' as
- # wildcards
- $tmp_head =~ s/(\\*)([*?])/$2 x ((length($1) + 1) % 2)/eg;
-
- if ($tmp_head =~ /[*?]/) { # if there are wildcards ...
- @globdirs = doglob_Mac('d', $head);
- push(@retval, doglob_Mac($cond, map {"$_$sepchr$tail"} @globdirs)),
- next OUTER if @globdirs;
- }
-
- $head .= $sepchr;
- $not_esc_head = $head;
- # unescape $head for file operations
- $not_esc_head =~ s/\\([*?\\])/$1/g;
- $_ = $tail;
- }
- #
- # If file component has no wildcards, we can avoid opendir
-
- my $tmp_tail = $_;
- # if a '*' or '?' is preceded by an odd count of '\', temporary delete
- # it (and its preceding backslashes), i.e. don't treat '\*' and '\?' as
- # wildcards
- $tmp_tail =~ s/(\\*)([*?])/$2 x ((length($1) + 1) % 2)/eg;
-
- unless ($tmp_tail =~ /[*?]/) { # if there are wildcards ...
- $not_esc_head = $head = '' if $head eq ':';
- my $not_esc_tail = $_;
- # unescape $head and $tail for file operations
- $not_esc_tail =~ s/\\([*?\\])/$1/g;
- $head .= $_;
- $not_esc_head .= $not_esc_tail;
- if ($cond eq 'd') { push(@retval,$head) if -d $not_esc_head }
- else { push(@retval,$head) if -e $not_esc_head }
- next OUTER;
- }
- #print "opendir($not_esc_head)\n";
- opendir(D, $not_esc_head) or next OUTER;
- my @leaves = readdir D;
- closedir D;
-
- # escape regex metachars but not '\' and glob chars '*', '?'
- $_ =~ s:([].+^\-\${}[|]):\\$1:g;
- # and convert DOS-style wildcards to regex,
- # but only if they are not escaped
- $_ =~ s/(\\*)([*?])/$1 . ('.' x ((length($1) + 1) % 2)) . $2/eg;
-
- #print "regex: '$_', head: '$head', unescaped head: '$not_esc_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 "$not_esc_head$e";
-
- if (&$matchsub($e)) {
- my $leave = (($not_esc_head eq ':') && (-f "$not_esc_head$e")) ?
- "$e" : "$not_esc_head$e";
- #
- # On Mac OS, the two glob metachars '*' and '?' and the escape
- # char '\' are valid characters for file and directory names.
- # We have to escape and treat them specially.
- $leave =~ s|([*?\\])|\\$1|g;
- push(@matched, $leave);
- next INNER;
- }
- }
- push @retval, @matched if @matched;
+ if ($fix_drive_relative_paths) {
+ s|^([A-Za-z]:)\./|$1| for @retval;
}
return @retval;
}
#
-# _expand_volume() will only be used on Mac OS (Classic):
-# Takes an array of original patterns as argument and returns an array of
-# possibly modified patterns. Each original pattern is processed like
-# that:
-# + If there's a volume name in the pattern, we push a separate pattern
-# for each mounted volume that matches (with '*', '?' and '\' escaped).
-# + If there's no volume name in the original pattern, it is pushed
-# unchanged.
-# Note that the returned array of patterns may be empty.
-#
-sub _expand_volume {
-
- require MacPerl; # to be verbose
-
- my @pat = @_;
- my @new_pat = ();
- my @FSSpec_Vols = MacPerl::Volumes();
- my @mounted_volumes = ();
-
- foreach my $spec_vol (@FSSpec_Vols) {
- # push all mounted volumes into array
- push @mounted_volumes, MacPerl::MakePath($spec_vol);
- }
- #print "mounted volumes: |@mounted_volumes|\n";
-
- while (@pat) {
- my $pat = shift @pat;
- if ($pat =~ /^([^:]+:)(.*)\z/) { # match a volume name?
- my $vol_pat = $1;
- my $tail = $2;
- #
- # escape regex metachars but not '\' and glob chars '*', '?'
- $vol_pat =~ s:([].+^\-\${}[|]):\\$1:g;
- # and convert DOS-style wildcards to regex,
- # but only if they are not escaped
- $vol_pat =~ s/(\\*)([*?])/$1 . ('.' x ((length($1) + 1) % 2)) . $2/eg;
- #print "volume regex: '$vol_pat' \n";
-
- foreach my $volume (@mounted_volumes) {
- if ($volume =~ m|^$vol_pat\z|ios) {
- #
- # On Mac OS, the two glob metachars '*' and '?' and the
- # escape char '\' are valid characters for volume names.
- # We have to escape and treat them specially.
- $volume =~ s|([*?\\])|\\$1|g;
- push @new_pat, $volume . $tail;
- }
- }
- } else { # no volume name in pattern, push original pattern
- push @new_pat, $pat;
- }
- }
- return @new_pat;
-}
-
-
-#
-# _preprocess_pattern() will only be used on Mac OS (Classic):
-# Resolves any updirs in the pattern. Removes a single trailing colon
-# from the pattern, unless it's a volume name pattern like "*HD:"
-#
-sub _preprocess_pattern {
- my @pat = @_;
-
- foreach my $p (@pat) {
- my $proceed;
- # resolve any updirs, e.g. "*HD:t?p::a*" -> "*HD:a*"
- do {
- $proceed = ($p =~ s/^(.*):[^:]+::(.*?)\z/$1:$2/);
- } while ($proceed);
- # remove a single trailing colon, e.g. ":*:" -> ":*"
- $p =~ s/:([^:]+):\z/:$1/;
- }
- return @pat;
-}
-
-
-#
-# _un_escape() will only be used on Mac OS (Classic):
-# Unescapes a list of arguments which may contain escaped
-# metachars '*', '?' and '\'.
-#
-sub _un_escape {
- foreach (@_) {
- s/\\([*?\\])/$1/g;
- }
- return @_;
-}
-
-#
# this can be used to override CORE::glob in a specific
# package by saying C<use File::DosGlob 'glob';> in that
# namespace.
@@ -335,7 +139,7 @@ sub glob {
my $tmp = "$start$match$end";
while ( $tmp =~ s/^(.*?)(?<!\\)\{(?:.*(?<!\\)\,)?(.*\Q$match\E.*?)(?:(?<!\\)\,.*)?(?<!\\)\}(.*)$/$1$2$3/ ) {
#print "Striped: $tmp\n";
- # these expanshions will be preformed by the original,
+ # these expansions will be preformed by the original,
# when we call REHASH.
}
push @appendpat, ("$tmp");
@@ -373,15 +177,7 @@ sub glob {
# if we're just beginning, do it all first
if ($iter{$cxix} == 0) {
- if ($^O eq 'MacOS') {
- # first, take care of updirs and trailing colons
- @pat = _preprocess_pattern(@pat);
- # expand volume names
- @pat = _expand_volume(@pat);
- $entries{$cxix} = (@pat) ? [_un_escape( doglob_Mac(1,@pat) )] : [()];
- } else {
- $entries{$cxix} = [doglob(1,@pat)];
- }
+ $entries{$cxix} = [doglob(1,@pat)];
}
# chuck it all out, quick or slow
@@ -462,61 +258,6 @@ of the quoting rules used.
Extending it to csh patterns is left as an exercise to the reader.
-=head1 NOTES
-
-=over 4
-
-=item *
-
-Mac OS (Classic) users should note a few differences. The specification
-of pathnames in glob patterns adheres to the usual Mac OS conventions:
-The path separator is a colon ':', not a slash '/' or backslash '\'. A
-full path always begins with a volume name. A relative pathname on Mac
-OS must always begin with a ':', except when specifying a file or
-directory name in the current working directory, where the leading colon
-is optional. If specifying a volume name only, a trailing ':' is
-required. Due to these rules, a glob like E<lt>*:E<gt> will find all
-mounted volumes, while a glob like E<lt>*E<gt> or E<lt>:*E<gt> will find
-all files and directories in the current directory.
-
-Note that updirs in the glob pattern are resolved before the matching begins,
-i.e. a pattern like "*HD:t?p::a*" will be matched as "*HD:a*". Note also,
-that a single trailing ':' in the pattern is ignored (unless it's a volume
-name pattern like "*HD:"), i.e. a glob like <:*:> will find both directories
-I<and> files (and not, as one might expect, only directories).
-
-The metachars '*', '?' and the escape char '\' are valid characters in
-volume, directory and file names on Mac OS. Hence, if you want to match
-a '*', '?' or '\' literally, you have to escape these characters. Due to
-perl's quoting rules, things may get a bit complicated, when you want to
-match a string like '\*' literally, or when you want to match '\' literally,
-but treat the immediately following character '*' as metachar. So, here's a
-rule of thumb (applies to both single- and double-quoted strings): escape
-each '*' or '?' or '\' with a backslash, if you want to treat them literally,
-and then double each backslash and your are done. E.g.
-
-- Match '\*' literally
-
- escape both '\' and '*' : '\\\*'
- double the backslashes : '\\\\\\*'
-
-(Internally, the glob routine sees a '\\\*', which means that both '\' and
-'*' are escaped.)
-
-
-- Match '\' literally, treat '*' as metachar
-
- escape '\' but not '*' : '\\*'
- double the backslashes : '\\\\*'
-
-(Internally, the glob routine sees a '\\*', which means that '\' is escaped and
-'*' is not.)
-
-Note that you also have to quote literal spaces in the glob pattern, as described
-above.
-
-=back
-
=head1 EXPORTS (by request only)
glob()
diff --git a/Master/tlpkg/tlperl/lib/File/Fetch.pm b/Master/tlpkg/tlperl/lib/File/Fetch.pm
index 4aabc29be55..5d0a51df161 100644
--- a/Master/tlpkg/tlperl/lib/File/Fetch.pm
+++ b/Master/tlpkg/tlperl/lib/File/Fetch.pm
@@ -22,7 +22,7 @@ use vars qw[ $VERBOSE $PREFER_BIN $FROM_EMAIL $USER_AGENT
$FTP_PASSIVE $TIMEOUT $DEBUG $WARN
];
-$VERSION = '0.24';
+$VERSION = '0.32';
$VERSION = eval $VERSION; # avoid warnings with development releases
$PREFER_BIN = 0; # XXX TODO implement
$FROM_EMAIL = 'File-Fetch@example.com';
@@ -36,8 +36,8 @@ $WARN = 1;
### methods available to fetch the file depending on the scheme
$METHODS = {
- http => [ qw|lwp wget curl lftp lynx iosock| ],
- ftp => [ qw|lwp netftp wget curl lftp ncftp ftp| ],
+ http => [ qw|lwp httptiny wget curl lftp fetch httplite lynx iosock| ],
+ ftp => [ qw|lwp netftp wget curl lftp fetch ncftp ftp| ],
file => [ qw|lwp lftp file| ],
rsync => [ qw|rsync| ]
};
@@ -54,7 +54,7 @@ use constant ON_VMS => ($^O eq 'VMS');
use constant ON_UNIX => (!ON_WIN);
use constant HAS_VOL => (ON_WIN);
use constant HAS_SHARE => (ON_WIN);
-
+use constant HAS_FETCH => ( $^O =~ m!^(freebsd|netbsd|dragonfly)$! );
=pod
@@ -498,7 +498,7 @@ sub fetch {
if( ref $target and UNIVERSAL::isa( $target, 'SCALAR' ) ) {
### open the file
- open my $fh, $file or do {
+ open my $fh, "<$file" or do {
$self->_error(
loc("Could not open '%1': %2", $file, $!));
return;
@@ -584,6 +584,125 @@ sub _lwp_fetch {
}
}
+### HTTP::Tiny fetching ###
+sub _httptiny_fetch {
+ my $self = shift;
+ my %hash = @_;
+
+ my ($to);
+ my $tmpl = {
+ to => { required => 1, store => \$to }
+ };
+ check( $tmpl, \%hash ) or return;
+
+ my $use_list = {
+ 'HTTP::Tiny' => '0.008',
+
+ };
+
+ if( can_load(modules => $use_list) ) {
+
+ my $uri = $self->uri;
+
+ my $http = HTTP::Tiny->new( ( $TIMEOUT ? ( timeout => $TIMEOUT ) : () ) );
+
+ my $rc = $http->mirror( $uri, $to );
+
+ unless ( $rc->{success} ) {
+
+ return $self->_error(loc( "Fetch failed! HTTP response: %1 [%2]",
+ $rc->{status}, $rc->{reason} ) );
+
+ }
+
+ return $to;
+
+ }
+ else {
+ $METHOD_FAIL->{'httptiny'} = 1;
+ return;
+ }
+}
+
+### HTTP::Lite fetching ###
+sub _httplite_fetch {
+ my $self = shift;
+ my %hash = @_;
+
+ my ($to);
+ my $tmpl = {
+ to => { required => 1, store => \$to }
+ };
+ check( $tmpl, \%hash ) or return;
+
+ ### modules required to download with lwp ###
+ my $use_list = {
+ 'HTTP::Lite' => '2.2',
+
+ };
+
+ # https://github.com/dagolden/cpanpm/compare/master...private%2Fuse-http-lite
+
+ if( can_load(modules => $use_list) ) {
+
+ my $uri = $self->uri;
+ my $retries = 0;
+
+ RETRIES: while ( $retries++ < 5 ) {
+
+ my $http = HTTP::Lite->new();
+ # Naughty naughty but there isn't any accessor/setter
+ $http->{timeout} = $TIMEOUT if $TIMEOUT;
+ $http->http11_mode(1);
+
+ my $fh = FileHandle->new;
+
+ unless ( $fh->open($to,'>') ) {
+ return $self->_error(loc(
+ "Could not open '%1' for writing: %2",$to,$!));
+ }
+
+ $fh->autoflush(1);
+
+ binmode $fh;
+
+ my $rc = $http->request( $uri, sub { my ($self,$dref,$cbargs) = @_; local $\; print {$cbargs} $$dref }, $fh );
+
+ close $fh;
+
+ if ( $rc == 301 || $rc == 302 ) {
+ my $loc;
+ HEADERS: for ($http->headers_array) {
+ /Location: (\S+)/ and $loc = $1, last HEADERS;
+ }
+ #$loc or last; # Think we should squeal here.
+ if ($loc =~ m!^/!) {
+ $uri =~ s{^(\w+?://[^/]+)/.*$}{$1};
+ $uri .= $loc;
+ }
+ else {
+ $uri = $loc;
+ }
+ next RETRIES;
+ }
+ elsif ( $rc == 200 ) {
+ return $to;
+ }
+ else {
+ return $self->_error(loc("Fetch failed! HTTP response: %1 [%2]",
+ $rc, $http->status_message));
+ }
+
+ } # Loop for 5 retries.
+
+ return $self->_error("Fetch failed! Gave up after 5 tries");
+
+ } else {
+ $METHOD_FAIL->{'httplite'} = 1;
+ return;
+ }
+}
+
### Simple IO::Socket::INET fetching ###
sub _iosock_fetch {
my $self = shift;
@@ -619,6 +738,9 @@ sub _iosock_fetch {
"Could not open '%1' for writing: %2",$to,$!));
}
+ $fh->autoflush(1);
+ binmode $fh;
+
my $path = File::Spec::Unix->catfile( $self->path, $self->file );
my $req = "GET $path HTTP/1.0\x0d\x0aHost: " . $self->host . "\x0d\x0a\x0d\x0a";
$sock->send( $req );
@@ -641,7 +763,7 @@ sub _iosock_fetch {
}
# Check the "response"
- # Strip preceeding blank lines apparently they are allowed (RFC 2616 4.1)
+ # Strip preceding blank lines apparently they are allowed (RFC 2616 4.1)
$resp =~ s/^(\x0d?\x0a)+//;
# Check it is an HTTP response
unless ( $resp =~ m!^HTTP/(\d+)\.(\d+)!i ) {
@@ -654,7 +776,10 @@ sub _iosock_fetch {
return $self->_error(loc("Got a '%1' from '%2' expected '200'",$code,$self->host));
}
- print $fh +($resp =~ m/\x0d\x0a\x0d\x0a(.*)$/s )[0];
+ {
+ local $\;
+ print $fh +($resp =~ m/\x0d\x0a\x0d\x0a(.*)$/s )[0];
+ }
close $fh;
return $to;
@@ -1002,7 +1127,7 @@ sub _ncftp_fetch {
};
check( $tmpl, \%hash ) or return;
- ### we can only set passive mode in interactive sesssions, so bail out
+ ### we can only set passive mode in interactive sessions, so bail out
### if $FTP_PASSIVE is set
return if $FTP_PASSIVE;
@@ -1095,6 +1220,60 @@ sub _curl_fetch {
}
}
+### /usr/bin/fetch fetch! ###
+sub _fetch_fetch {
+ my $self = shift;
+ my %hash = @_;
+
+ my ($to);
+ my $tmpl = {
+ to => { required => 1, store => \$to }
+ };
+ check( $tmpl, \%hash ) or return;
+
+ ### see if we have a wget binary ###
+ if( HAS_FETCH and my $fetch = can_run('fetch') ) {
+
+ ### no verboseness, thanks ###
+ my $cmd = [ $fetch, '-q' ];
+
+ ### if a timeout is set, add it ###
+ push(@$cmd, '-T', $TIMEOUT) if $TIMEOUT;
+
+ ### run passive if specified ###
+ #push @$cmd, '-p' if $FTP_PASSIVE;
+ local $ENV{'FTP_PASSIVE_MODE'} = 1 if $FTP_PASSIVE;
+
+ ### set the output document, add the uri ###
+ push @$cmd, '-o', $to, $self->uri;
+
+ ### with IPC::Cmd > 0.41, this is fixed in teh library,
+ ### and there's no need for special casing any more.
+ ### DO NOT quote things for IPC::Run, it breaks stuff.
+ # $IPC::Cmd::USE_IPC_RUN
+ # ? ($to, $self->uri)
+ # : (QUOTE. $to .QUOTE, QUOTE. $self->uri .QUOTE);
+
+ ### shell out ###
+ my $captured;
+ unless(run( command => $cmd,
+ buffer => \$captured,
+ verbose => $DEBUG
+ )) {
+ ### wget creates the output document always, even if the fetch
+ ### fails.. so unlink it in that case
+ 1 while unlink $to;
+
+ return $self->_error(loc( "Command failed: %1", $captured || '' ));
+ }
+
+ return $to;
+
+ } else {
+ $METHOD_FAIL->{'wget'} = 1;
+ return;
+ }
+}
### use File::Copy for fetching file:// urls ###
###
@@ -1117,7 +1296,7 @@ sub _file_fetch {
### prefix a / on unix systems with a file uri, since it would
### look somewhat like this:
### file:///home/kane/file
- ### wheras windows file uris for 'c:\some\dir\file' might look like:
+ ### whereas windows file uris for 'c:\some\dir\file' might look like:
### file:///C:/some/dir/file
### file:///C|/some/dir/file
### or for a network share '\\host\share\some\dir\file':
@@ -1266,8 +1445,8 @@ Below is a mapping of what utilities will be used in what order
for what schemes, if available:
file => LWP, lftp, file
- http => LWP, wget, curl, lftp, lynx, iosock
- ftp => LWP, Net::FTP, wget, curl, lftp, ncftp, ftp
+ http => LWP, HTTP::Lite, wget, curl, lftp, fetch, lynx, iosock
+ ftp => LWP, Net::FTP, wget, curl, lftp, fetch, ncftp, ftp
rsync => rsync
If you'd like to disable the use of one or more of these utilities
@@ -1278,6 +1457,10 @@ If a utility or module isn't available, it will be marked in a cache
tried again. The C<fetch> method will only fail when all options are
exhausted, and it was not able to retrieve the file.
+The C<fetch> utility is available on FreeBSD. NetBSD and Dragonfly BSD
+may also have it from C<pkgsrc>. We only check for C<fetch> on those
+three platforms.
+
C<iosock> is a very limited L<IO::Socket::INET> based mechanism for
retrieving C<http> schemed urls. It doesn't follow redirects for instance.
@@ -1379,6 +1562,8 @@ Here's a quick mapping for the utilities/modules, and their names for
the $BLACKLIST, $METHOD_FAIL and other internal functions.
LWP => lwp
+ HTTP::Lite => httplite
+ HTTP::Tiny => httptiny
Net::FTP => netftp
wget => wget
lynx => lynx
@@ -1387,6 +1572,7 @@ the $BLACKLIST, $METHOD_FAIL and other internal functions.
curl => curl
rsync => rsync
lftp => lftp
+ fetch => fetch
IO::Socket => iosock
=head1 FREQUENTLY ASKED QUESTIONS
@@ -1409,7 +1595,7 @@ which we in turn capture. If that content is a 'custom' error file
Sadly, C<lynx> doesn't support any options to return a different exit
code on non-C<200 OK> status, giving us no way to tell the difference
-between a 'successfull' fetch and a custom error page.
+between a 'successful' fetch and a custom error page.
Therefor, we recommend to only use C<lynx> as a last resort. This is
why it is at the back of our list of methods to try as well.
diff --git a/Master/tlpkg/tlperl/lib/File/Find.pm b/Master/tlpkg/tlperl/lib/File/Find.pm
index e72f3e32b30..cdcf97e0a79 100644
--- a/Master/tlpkg/tlperl/lib/File/Find.pm
+++ b/Master/tlpkg/tlperl/lib/File/Find.pm
@@ -3,12 +3,12 @@ use 5.006;
use strict;
use warnings;
use warnings::register;
-our $VERSION = '1.15';
+our $VERSION = '1.19';
require Exporter;
require Cwd;
#
-# Modified to ensure sub-directory traversal order is not inverded by stack
+# Modified to ensure sub-directory traversal order is not inverted by stack
# push and pops. That is remains in the same order as in the directory file,
# or user pre-processing (EG:sorted).
#
@@ -324,81 +324,6 @@ in an unknown directory.
=back
-=head1 NOTES
-
-=over 4
-
-=item *
-
-Mac OS (Classic) users should note a few differences:
-
-=over 4
-
-=item *
-
-The path separator is ':', not '/', and the current directory is denoted
-as ':', not '.'. You should be careful about specifying relative pathnames.
-While a full path always begins with a volume name, a relative pathname
-should always begin with a ':'. If specifying a volume name only, a
-trailing ':' is required.
-
-=item *
-
-C<$File::Find::dir> is guaranteed to end with a ':'. If C<$_>
-contains the name of a directory, that name may or may not end with a
-':'. Likewise, C<$File::Find::name>, which contains the complete
-pathname to that directory, and C<$File::Find::fullname>, which holds
-the absolute pathname of that directory with all symbolic links resolved,
-may or may not end with a ':'.
-
-=item *
-
-The default C<untaint_pattern> (see above) on Mac OS is set to
-C<qr|^(.+)$|>. Note that the parentheses are vital.
-
-=item *
-
-The invisible system file "Icon\015" is ignored. While this file may
-appear in every directory, there are some more invisible system files
-on every volume, which are all located at the volume root level (i.e.
-"MacintoshHD:"). These system files are B<not> excluded automatically.
-Your filter may use the following code to recognize invisible files or
-directories (requires Mac::Files):
-
- use Mac::Files;
-
- # invisible() -- returns 1 if file/directory is invisible,
- # 0 if it's visible or undef if an error occurred
-
- sub invisible($) {
- my $file = shift;
- my ($fileCat, $fileInfo);
- my $invisible_flag = 1 << 14;
-
- if ( $fileCat = FSpGetCatInfo($file) ) {
- if ($fileInfo = $fileCat->ioFlFndrInfo() ) {
- return (($fileInfo->fdFlags & $invisible_flag) && 1);
- }
- }
- return undef;
- }
-
-Generally, invisible files are system files, unless an odd application
-decides to use invisible files for its own purposes. To distinguish
-such files from system files, you have to look at the B<type> and B<creator>
-file attributes. The MacPerl built-in functions C<GetFileInfo(FILE)> and
-C<SetFileInfo(CREATOR, TYPE, FILES)> offer access to these attributes
-(see MacPerl.pm for details).
-
-Files that appear on the desktop actually reside in an (hidden) directory
-named "Desktop Folder" on the particular disk volume. Note that, although
-all desktop files appear to be on the same "virtual" desktop, each disk
-volume actually maintains its own "Desktop Folder" directory.
-
-=back
-
-=back
-
=head1 BUGS AND CAVEATS
Despite the name of the C<finddepth()> function, both C<find()> and
@@ -423,7 +348,7 @@ our @EXPORT = qw(find finddepth);
use strict;
my $Is_VMS;
-my $Is_MacOS;
+my $Is_Win32;
require File::Basename;
require File::Spec;
@@ -454,83 +379,24 @@ sub contract_name {
return $abs_name;
}
-# return the absolute name of a directory or file
-sub contract_name_Mac {
- my ($cdir,$fn) = @_;
- my $abs_name;
-
- if ($fn =~ /^(:+)(.*)$/) { # valid pathname starting with a ':'
-
- my $colon_count = length ($1);
- if ($colon_count == 1) {
- $abs_name = $cdir . $2;
- return $abs_name;
- }
- else {
- # need to move up the tree, but
- # only if it's not a volume name
- for (my $i=1; $i<$colon_count; $i++) {
- unless ($cdir =~ /^[^:]+:$/) { # volume name
- $cdir =~ s/[^:]+:$//;
- }
- else {
- return undef;
- }
- }
- $abs_name = $cdir . $2;
- return $abs_name;
- }
-
- }
- else {
-
- # $fn may be a valid path to a directory or file or (dangling)
- # symlink, without a leading ':'
- if ( (-e $fn) || (-l $fn) ) {
- if ($fn =~ /^[^:]+:/) { # a volume name like DataHD:*
- return $fn; # $fn is already an absolute path
- }
- else {
- $abs_name = $cdir . $fn;
- return $abs_name;
- }
- }
- else { # argh!, $fn is not a valid directory/file
- return undef;
- }
- }
-}
-
sub PathCombine($$) {
my ($Base,$Name) = @_;
my $AbsName;
- if ($Is_MacOS) {
- # $Name is the resolved symlink (always a full path on MacOS),
- # i.e. there's no need to call contract_name_Mac()
- $AbsName = $Name;
-
- # (simple) check for recursion
- if ( ( $Base =~ /^$AbsName/) && (-d $AbsName) ) { # recursion
- return undef;
- }
+ if (substr($Name,0,1) eq '/') {
+ $AbsName= $Name;
}
else {
- if (substr($Name,0,1) eq '/') {
- $AbsName= $Name;
- }
- else {
- $AbsName= contract_name($Base,$Name);
- }
+ $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;
- }
+ # (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;
@@ -629,8 +495,8 @@ sub _find_opt {
$pre_process = $wanted->{preprocess};
$post_process = $wanted->{postprocess};
$no_chdir = $wanted->{no_chdir};
- $full_check = $^O eq 'MSWin32' ? 0 : $wanted->{follow};
- $follow = $^O eq 'MSWin32' ? 0 :
+ $full_check = $Is_Win32 ? 0 : $wanted->{follow};
+ $follow = $Is_Win32 ? 0 :
$full_check || $wanted->{follow_fast};
$follow_skip = $wanted->{follow_skip};
$untaint = $wanted->{untaint};
@@ -652,11 +518,9 @@ sub _find_opt {
($topdev,$topino,$topmode,$topnlink) = $follow ? stat $top_item : lstat $top_item;
- if ($Is_MacOS) {
- $top_item = ":$top_item"
- if ( (-d _) && ( $top_item !~ /:/ ) );
- } elsif ($^O eq 'MSWin32') {
- $top_item =~ s|/\z|| unless $top_item =~ m|\w:/$|;
+ if ($Is_Win32) {
+ $top_item =~ s|[/\\]\z||
+ unless $top_item =~ m{^(?:\w:)?[/\\]$};
}
else {
$top_item =~ s|/\z|| unless $top_item eq '/';
@@ -666,32 +530,15 @@ sub _find_opt {
if ($follow) {
- if ($Is_MacOS) {
- $cwd = "$cwd:" unless ($cwd =~ /:$/); # for safety
-
- if ($top_item eq $File::Find::current_dir) {
- $abs_dir = $cwd;
- }
- else {
- $abs_dir = contract_name_Mac($cwd, $top_item);
- unless (defined $abs_dir) {
- warnings::warnif "Can't determine absolute path for $top_item (No such file or directory)\n";
- next Proc_Top_Item;
- }
- }
-
+ if (substr($top_item,0,1) eq '/') {
+ $abs_dir = $top_item;
}
- else {
- if (substr($top_item,0,1) eq '/') {
- $abs_dir = $top_item;
- }
- elsif ($top_item eq $File::Find::current_dir) {
- $abs_dir = $cwd;
- }
- else { # care about any ../
- $top_item =~ s/\.dir\z//i if $Is_VMS;
- $abs_dir = contract_name("$cwd/",$top_item);
- }
+ elsif ($top_item eq $File::Find::current_dir) {
+ $abs_dir = $cwd;
+ }
+ else { # care about any ../
+ $top_item =~ s/\.dir\z//i if $Is_VMS;
+ $abs_dir = contract_name("$cwd/",$top_item);
}
$abs_dir= Follow_SymLink($abs_dir);
unless (defined $abs_dir) {
@@ -729,12 +576,7 @@ sub _find_opt {
unless ($Is_Dir) {
unless (($_,$dir) = File::Basename::fileparse($abs_dir)) {
- if ($Is_MacOS) {
- ($dir,$_) = (':', $top_item); # $File::Find::dir, $_
- }
- else {
- ($dir,$_) = ('./', $top_item);
- }
+ ($dir,$_) = ('./', $top_item);
}
$abs_dir = $dir;
@@ -797,11 +639,10 @@ sub _find_dir($$$) {
my $tainted = 0;
my $no_nlink;
- if ($Is_MacOS) {
- $dir_pref= ($p_dir =~ /:$/) ? $p_dir : "$p_dir:"; # preface
- } elsif ($^O eq 'MSWin32') {
- $dir_pref = ($p_dir =~ m|\w:/?$| ? $p_dir : "$p_dir/" );
- } elsif ($^O eq 'VMS') {
+ if ($Is_Win32) {
+ $dir_pref
+ = ($p_dir =~ m{^(?:\w:[/\\]?|[/\\])$} ? $p_dir : "$p_dir/" );
+ } elsif ($Is_VMS) {
# VMS is returning trailing .dir on directories
# and trailing . on files and symbolic links
@@ -840,10 +681,6 @@ sub _find_dir($$$) {
# push the starting directory
push @Stack,[$CdLvl,$p_dir,$dir_rel,-1] if $bydepth;
- if ($Is_MacOS) {
- $p_dir = $dir_pref; # ensure trailing ':'
- }
-
while (defined $SE) {
unless ($bydepth) {
$dir= $p_dir; # $File::Find::dir
@@ -862,34 +699,20 @@ sub _find_dir($$$) {
( $udir ) = $dir_rel =~ m|$untaint_pat|;
unless (defined $udir) {
if ($untaint_skip == 0) {
- if ($Is_MacOS) {
- die "directory ($p_dir) $dir_rel is still tainted";
- }
- else {
- die "directory (" . ($p_dir ne '/' ? $p_dir : '') . "/) $dir_rel is still tainted";
- }
+ die "directory (" . ($p_dir ne '/' ? $p_dir : '') . "/) $dir_rel is still tainted";
} else { # $untaint_skip == 1
next;
}
}
}
unless (chdir ($Is_VMS && $udir !~ /[\/\[<]+/ ? "./$udir" : $udir)) {
- if ($Is_MacOS) {
- warnings::warnif "Can't cd to ($p_dir) $udir: $!\n";
- }
- else {
- warnings::warnif "Can't cd to (" .
- ($p_dir ne '/' ? $p_dir : '') . "/) $udir: $!\n";
- }
+ warnings::warnif "Can't cd to (" .
+ ($p_dir ne '/' ? $p_dir : '') . "/) $udir: $!\n";
next;
}
$CdLvl++;
}
- if ($Is_MacOS) {
- $dir_name = "$dir_name:" unless ($dir_name =~ /:$/);
- }
-
$dir= $dir_name; # $File::Find::dir
# Get the list of files in the current directory.
@@ -902,7 +725,7 @@ sub _find_dir($$$) {
@filenames = $pre_process->(@filenames) if $pre_process;
push @Stack,[$CdLvl,$dir_name,"",-2] if $post_process;
- # default: use whatever was specifid
+ # default: use whatever was specified
# (if $nlink >= 2, and $avoid_nlink == 0, this will switch back)
$no_nlink = $avoid_nlink;
# if dir has wrong nlink count, force switch to slower stat method
@@ -971,10 +794,7 @@ sub _find_dir($$$) {
($Level, $p_dir, $dir_rel, $nlink) = @$SE;
if ($CdLvl > $Level && !$no_chdir) {
my $tmp;
- if ($Is_MacOS) {
- $tmp = (':' x ($CdLvl-$Level)) . ':';
- }
- elsif ($Is_VMS) {
+ if ($Is_VMS) {
$tmp = '[' . ('-' x ($CdLvl-$Level)) . ']';
}
else {
@@ -985,14 +805,9 @@ sub _find_dir($$$) {
$CdLvl = $Level;
}
- if ($Is_MacOS) {
- # $pdir always has a trailing ':', except for the starting dir,
- # where $dir_rel eq ':'
- $dir_name = "$p_dir$dir_rel";
- $dir_pref = "$dir_name:";
- }
- elsif ($^O eq 'MSWin32') {
- $dir_name = ($p_dir =~ m|\w:/?$| ? "$p_dir$dir_rel" : "$p_dir/$dir_rel");
+ if ($Is_Win32) {
+ $dir_name = ($p_dir =~ m{^(?:\w:[/\\]?|[/\\])$}
+ ? "$p_dir$dir_rel" : "$p_dir/$dir_rel");
$dir_pref = "$dir_name/";
}
elsif ($^O eq 'VMS') {
@@ -1018,23 +833,13 @@ sub _find_dir($$$) {
}
elsif ( $nlink < 0 ) { # must be finddepth, report dirname now
$name = $dir_name;
- if ($Is_MacOS) {
- if ($dir_rel eq ':') { # must be the top dir, where we started
- $name =~ s|:$||; # $File::Find::name
- $p_dir = "$p_dir:" unless ($p_dir =~ /:$/);
- }
- $dir = $p_dir; # $File::Find::dir
- $_ = ($no_chdir ? $name : $dir_rel); # $_
+ if ( substr($name,-2) eq '/.' ) {
+ substr($name, length($name) == 2 ? -1 : -2) = '';
}
- else {
- if ( substr($name,-2) eq '/.' ) {
- substr($name, length($name) == 2 ? -1 : -2) = '';
- }
- $dir = $p_dir;
- $_ = ($no_chdir ? $dir_name : $dir_rel );
- if ( substr($_,-2) eq '/.' ) {
- substr($_, length($_) == 2 ? -1 : -2) = '';
- }
+ $dir = $p_dir;
+ $_ = ($no_chdir ? $dir_name : $dir_rel );
+ if ( substr($_,-2) eq '/.' ) {
+ substr($_, length($_) == 2 ? -1 : -2) = '';
}
{ $wanted_callback->() }; # protect against wild "next"
}
@@ -1069,13 +874,8 @@ sub _find_dir_symlnk($$$) {
my $tainted = 0;
my $ok = 1;
- if ($Is_MacOS) {
- $dir_pref = ($p_dir =~ /:$/) ? "$p_dir" : "$p_dir:";
- $loc_pref = ($dir_loc =~ /:$/) ? "$dir_loc" : "$dir_loc:";
- } else {
- $dir_pref = ( $p_dir eq '/' ? '/' : "$p_dir/" );
- $loc_pref = ( $dir_loc eq '/' ? '/' : "$dir_loc/" );
- }
+ $dir_pref = ( $p_dir eq '/' ? '/' : "$p_dir/" );
+ $loc_pref = ( $dir_loc eq '/' ? '/' : "$dir_loc/" );
local ($dir, $name, $fullname, $prune, *DIR);
@@ -1104,10 +904,6 @@ sub _find_dir_symlnk($$$) {
push @Stack,[$dir_loc,$updir_loc,$p_dir,$dir_rel,-1] if $bydepth;
- if ($Is_MacOS) {
- $p_dir = $dir_pref; # ensure trailing ':'
- }
-
while (defined $SE) {
unless ($bydepth) {
@@ -1150,10 +946,6 @@ sub _find_dir_symlnk($$$) {
}
}
- if ($Is_MacOS) {
- $dir_name = "$dir_name:" unless ($dir_name =~ /:$/);
- }
-
$dir = $dir_name; # $File::Find::dir
# Get the list of files in the current directory.
@@ -1216,18 +1008,9 @@ sub _find_dir_symlnk($$$) {
continue {
while (defined($SE = pop @Stack)) {
($dir_loc, $updir_loc, $p_dir, $dir_rel, $byd_flag) = @$SE;
- if ($Is_MacOS) {
- # $p_dir always has a trailing ':', except for the starting dir,
- # where $dir_rel eq ':'
- $dir_name = "$p_dir$dir_rel";
- $dir_pref = "$dir_name:";
- $loc_pref = ($dir_loc =~ /:$/) ? $dir_loc : "$dir_loc:";
- }
- else {
- $dir_name = ($p_dir eq '/' ? "/$dir_rel" : "$p_dir/$dir_rel");
- $dir_pref = "$dir_name/";
- $loc_pref = "$dir_loc/";
- }
+ $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 || ($dir_rel eq $File::Find::current_dir)) {
unless (chdir $updir_loc) { # $updir_loc (parent dir) is always untainted
@@ -1237,23 +1020,13 @@ sub _find_dir_symlnk($$$) {
}
$fullname = $dir_loc; # $File::Find::fullname
$name = $dir_name; # $File::Find::name
- if ($Is_MacOS) {
- if ($dir_rel eq ':') { # must be the top dir, where we started
- $name =~ s|:$||; # $File::Find::name
- $p_dir = "$p_dir:" unless ($p_dir =~ /:$/);
- }
- $dir = $p_dir; # $File::Find::dir
- $_ = ($no_chdir ? $name : $dir_rel); # $_
+ if ( substr($name,-2) eq '/.' ) {
+ substr($name, length($name) == 2 ? -1 : -2) = ''; # $File::Find::name
}
- else {
- if ( substr($name,-2) eq '/.' ) {
- substr($name, length($name) == 2 ? -1 : -2) = ''; # $File::Find::name
- }
- $dir = $p_dir; # $File::Find::dir
- $_ = ($no_chdir ? $dir_name : $dir_rel); # $_
- if ( substr($_,-2) eq '/.' ) {
- substr($_, length($_) == 2 ? -1 : -2) = '';
- }
+ $dir = $p_dir; # $File::Find::dir
+ $_ = ($no_chdir ? $dir_name : $dir_rel); # $_
+ if ( substr($_,-2) eq '/.' ) {
+ substr($_, length($_) == 2 ? -1 : -2) = '';
}
lstat($_); # make sure file tests with '_' work
@@ -1312,11 +1085,8 @@ if ($^O eq 'VMS') {
$Is_VMS = 1;
$File::Find::dont_use_nlink = 1;
}
-elsif ($^O eq 'MacOS') {
- $Is_MacOS = 1;
- $File::Find::dont_use_nlink = 1;
- $File::Find::skip_pattern = qr/^Icon\015\z/;
- $File::Find::untaint_pattern = qr|^(.+)$|;
+elsif ($^O eq 'MSWin32') {
+ $Is_Win32 = 1;
}
# this _should_ work properly on all platforms
@@ -1324,7 +1094,7 @@ elsif ($^O eq 'MacOS') {
$File::Find::current_dir = File::Spec->curdir || '.';
$File::Find::dont_use_nlink = 1
- if $^O eq 'os2' || $^O eq 'dos' || $^O eq 'amigaos' || $^O eq 'MSWin32' ||
+ if $^O eq 'os2' || $^O eq 'dos' || $^O eq 'amigaos' || $Is_Win32 ||
$^O eq 'interix' || $^O eq 'cygwin' || $^O eq 'epoc' || $^O eq 'qnx' ||
$^O eq 'nto';
diff --git a/Master/tlpkg/tlperl/lib/File/Glob.pm b/Master/tlpkg/tlperl/lib/File/Glob.pm
index 7c6b92cf415..af17cffa76b 100644
--- a/Master/tlpkg/tlperl/lib/File/Glob.pm
+++ b/Master/tlpkg/tlperl/lib/File/Glob.pm
@@ -1,38 +1,16 @@
package File::Glob;
use strict;
-our($VERSION, @ISA, @EXPORT_OK, @EXPORT_FAIL, %EXPORT_TAGS,
- $AUTOLOAD, $DEFAULT_FLAGS);
+our($VERSION, @ISA, @EXPORT_OK, @EXPORT_FAIL, %EXPORT_TAGS, $DEFAULT_FLAGS);
-use XSLoader ();
+require XSLoader;
+use feature 'switch';
@ISA = qw(Exporter);
# NOTE: The glob() export is only here for compatibility with 5.6.0.
# csh_glob() should not be used directly, unless you know what you're doing.
-@EXPORT_OK = qw(
- csh_glob
- bsd_glob
- glob
- GLOB_ABEND
- GLOB_ALPHASORT
- GLOB_ALTDIRFUNC
- GLOB_BRACE
- GLOB_CSH
- GLOB_ERR
- GLOB_ERROR
- GLOB_LIMIT
- GLOB_MARK
- GLOB_NOCASE
- GLOB_NOCHECK
- GLOB_NOMAGIC
- GLOB_NOSORT
- GLOB_NOSPACE
- GLOB_QUOTE
- GLOB_TILDE
-);
-
%EXPORT_TAGS = (
'glob' => [ qw(
GLOB_ABEND
@@ -56,72 +34,35 @@ use XSLoader ();
) ],
);
-$VERSION = '1.07';
+@EXPORT_OK = (@{$EXPORT_TAGS{'glob'}}, 'csh_glob');
+
+$VERSION = '1.13';
sub import {
require Exporter;
- my $i = 1;
- while ($i < @_) {
- if ($_[$i] =~ /^:(case|nocase|globally)$/) {
- splice(@_, $i, 1);
- $DEFAULT_FLAGS &= ~GLOB_NOCASE() if $1 eq 'case';
- $DEFAULT_FLAGS |= GLOB_NOCASE() if $1 eq 'nocase';
- if ($1 eq 'globally') {
- local $^W;
+ local $Exporter::ExportLevel = $Exporter::ExportLevel + 1;
+ Exporter::import(grep {
+ my $passthrough;
+ given ($_) {
+ $DEFAULT_FLAGS &= ~GLOB_NOCASE() when ':case';
+ $DEFAULT_FLAGS |= GLOB_NOCASE() when ':nocase';
+ when (':globally') {
+ no warnings 'redefine';
*CORE::GLOBAL::glob = \&File::Glob::csh_glob;
}
- next;
+ $passthrough = 1;
}
- ++$i;
- }
- goto &Exporter::import;
+ $passthrough;
+ } @_);
}
-sub AUTOLOAD {
- # This AUTOLOAD is used to 'autoload' constants from the constant()
- # XS function. If a constant is not found then control is passed
- # to the AUTOLOAD in AutoLoader.
-
- my $constname;
- ($constname = $AUTOLOAD) =~ s/.*:://;
- my ($error, $val) = constant($constname);
- if ($error) {
- require Carp;
- Carp::croak($error);
- }
- eval "sub $AUTOLOAD { $val }";
- goto &$AUTOLOAD;
-}
-
-XSLoader::load 'File::Glob', $VERSION;
-
-# Preloaded methods go here.
-
-sub GLOB_ERROR {
- return (constant('GLOB_ERROR'))[1];
-}
-
-sub GLOB_CSH () {
- GLOB_BRACE()
- | GLOB_NOMAGIC()
- | GLOB_QUOTE()
- | GLOB_TILDE()
- | GLOB_ALPHASORT()
-}
+XSLoader::load();
$DEFAULT_FLAGS = GLOB_CSH();
-if ($^O =~ /^(?:MSWin32|VMS|os2|dos|riscos|MacOS)$/) {
+if ($^O =~ /^(?:MSWin32|VMS|os2|dos|riscos)$/) {
$DEFAULT_FLAGS |= GLOB_NOCASE();
}
-# Autoload methods go after =cut, and are processed by the autosplit program.
-
-sub bsd_glob {
- my ($pat,$flags) = @_;
- $flags = $DEFAULT_FLAGS if @_ < 2;
- return doglob($pat,$flags);
-}
-
# File::Glob::glob() is deprecated because its prototype is different from
# CORE::glob() (use bsd_glob() instead)
sub glob {
diff --git a/Master/tlpkg/tlperl/lib/File/GlobMapper.pm b/Master/tlpkg/tlperl/lib/File/GlobMapper.pm
index 40a606309e0..76d4bed1178 100644
--- a/Master/tlpkg/tlperl/lib/File/GlobMapper.pm
+++ b/Master/tlpkg/tlperl/lib/File/GlobMapper.pm
@@ -31,7 +31,7 @@ $VERSION = '1.000';
our ($noPreBS, $metachars, $matchMetaRE, %mapping, %wildCount);
-$noPreBS = '(?<!\\\)' ; # no preceeding backslash
+$noPreBS = '(?<!\\\)' ; # no preceding backslash
$metachars = '.*?[](){}';
$matchMetaRE = '[' . quotemeta($metachars) . ']';
@@ -309,7 +309,7 @@ sub _parseOutputGlob
if $1 > $maxwild ;
}
- my $noPreBS = '(?<!\\\)' ; # no preceeding backslash
+ my $noPreBS = '(?<!\\\)' ; # no preceding backslash
#warn "noPreBS = '$noPreBS'\n";
#$string =~ s/${noPreBS}\$(\d)/\${$1}/g;
diff --git a/Master/tlpkg/tlperl/lib/File/Listing.pm b/Master/tlpkg/tlperl/lib/File/Listing.pm
index 53a6ddc66be..c8d72a7185f 100644
--- a/Master/tlpkg/tlperl/lib/File/Listing.pm
+++ b/Master/tlpkg/tlperl/lib/File/Listing.pm
@@ -1,7 +1,7 @@
package File::Listing;
sub Version { $VERSION; }
-$VERSION = "5.837";
+$VERSION = "6.04";
require Exporter;
@ISA = qw(Exporter);
@@ -35,30 +35,47 @@ sub init { } # Dummy sub
sub file_mode ($)
{
+ Carp::croak("Input to file_mode() must be a 10 character string.")
+ unless length($_[0]) == 10;
+
# This routine was originally borrowed from Graham Barr's
# Net::FTP package.
local $_ = shift;
my $mode = 0;
- my($type,$ch);
+ my($type);
s/^(.)// and $type = $1;
+ # When the set-group-ID bit (file mode bit 02000) is set, and the group
+ # execution bit (file mode bit 00020) is unset, and it is a regular file,
+ # some implementations of `ls' use the letter `S', others use `l' or `L'.
+ # Convert this `S'.
+
+ s/[Ll](...)$/S$1/;
+
while (/(.)/g) {
$mode <<= 1;
$mode |= 1 if $1 ne "-" &&
$1 ne 'S' &&
- $1 ne 't' &&
$1 ne 'T';
}
- $type eq "d" and $mode |= 0040000 or # Directory
- $type eq "l" and $mode |= 0120000 or # Symbolic Link
- $mode |= 0100000; # Regular File
+ $mode |= 0004000 if /^..s....../i;
+ $mode |= 0002000 if /^.....s.../i;
+ $mode |= 0001000 if /^........t/i;
- $mode |= 0004000 if /^...s....../i;
- $mode |= 0002000 if /^......s.../i;
- $mode |= 0001000 if /^.........t/i;
+ # De facto standard definitions. From 'stat.h' on Solaris 9.
+
+ $type eq "p" and $mode |= 0010000 or # fifo
+ $type eq "c" and $mode |= 0020000 or # character special
+ $type eq "d" and $mode |= 0040000 or # directory
+ $type eq "b" and $mode |= 0060000 or # block special
+ $type eq "-" and $mode |= 0100000 or # regular
+ $type eq "l" and $mode |= 0120000 or # symbolic link
+ $type eq "s" and $mode |= 0140000 or # socket
+ $type eq "D" and $mode |= 0150000 or # door
+ Carp::croak("Unknown file type: $type");
$mode;
}
@@ -288,6 +305,7 @@ sub line {
local($_) = shift;
my($tz, $error) = @_; # ignored for now...
+ s!</?t[rd][^>]*>! !g; # clean away various table stuff
if (m!<A\s+HREF=\"([^\"]+)\">.*</A>.*?(\d+)-([a-zA-Z]+|\d+)-(\d+)\s+(\d+):(\d+)\s+(?:([\d\.]+[kMG]?|-))!i) {
my($filename, $filesize) = ($1, $7);
my($d,$m,$y, $H,$M) = ($2,$3,$4,$5,$6);
@@ -387,7 +405,7 @@ assumed.
The third parameter is the type of listing to assume. Currently
supported formats are 'unix', 'apache' and 'dosftp'. The default
-value 'unix'. Ideally, the listing type should be determined
+value is 'unix'. Ideally, the listing type should be determined
automatically.
The fourth parameter specifies how unparseable lines should be treated.
@@ -406,7 +424,12 @@ $filetype value is one of the letters 'f', 'd', 'l' or '?'. The
$filetime value is the seconds since Jan 1, 1970. The
$filemode is a bitmask like the mode returned by stat().
-=head1 CREDITS
+=head1 COPYRIGHT
+
+Copyright 1996-2010, Gisle Aas
Based on lsparse.pl (from Lee McLoughlin's ftp mirror package) and
Net::FTP's parse_dir (Graham Barr).
+
+This library is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
diff --git a/Master/tlpkg/tlperl/lib/File/Spec.pm b/Master/tlpkg/tlperl/lib/File/Spec.pm
index 9caf4eba0d0..34c527eea2f 100644
--- a/Master/tlpkg/tlperl/lib/File/Spec.pm
+++ b/Master/tlpkg/tlperl/lib/File/Spec.pm
@@ -3,7 +3,7 @@ package File::Spec;
use strict;
use vars qw(@ISA $VERSION);
-$VERSION = '3.31_01';
+$VERSION = '3.33';
$VERSION = eval $VERSION;
my %module = (MacOS => 'Mac',
@@ -166,6 +166,7 @@ directory. (Does not strip symlinks, only '.', '..', and equivalents.)
Returns a true or false value indicating, respectively, that alphabetic
case is not or is significant when comparing file specifications.
+Cygwin and Win32 accept an optional drive argument.
$is_case_tolerant = File::Spec->case_tolerant();
@@ -214,7 +215,7 @@ The results can be passed to L</catpath()> to get back a path equivalent to
=item splitdir
X<splitdir> X<split, dir>
-The opposite of L</catdir()>.
+The opposite of L</catdir>.
@dirs = File::Spec->splitdir( $directories );
@@ -289,7 +290,7 @@ On systems that have a grammar that indicates filenames, this ignores the
C<$base> filename as well. Otherwise all path components are assumed to be
directories.
-If C<$path> is absolute, it is cleaned up and returned using L</canonpath()>.
+If C<$path> is absolute, it is cleaned up and returned using L</canonpath>.
No checks against the filesystem are made. On VMS, there is
interaction with the working environment, as logicals and
@@ -328,7 +329,7 @@ splitpath(), splitdir(), catpath() and catdir() by Barrie Slaymaker.
=head1 COPYRIGHT
-Copyright (c) 2004 by the Perl 5 Porters. All rights reserved.
+Copyright (c) 2004-2010 by the Perl 5 Porters. All rights reserved.
This program is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
diff --git a/Master/tlpkg/tlperl/lib/File/Spec/Cygwin.pm b/Master/tlpkg/tlperl/lib/File/Spec/Cygwin.pm
index 050a1bb2b77..0709c6fc072 100644
--- a/Master/tlpkg/tlperl/lib/File/Spec/Cygwin.pm
+++ b/Master/tlpkg/tlperl/lib/File/Spec/Cygwin.pm
@@ -4,7 +4,7 @@ use strict;
use vars qw(@ISA $VERSION);
require File::Spec::Unix;
-$VERSION = '3.30';
+$VERSION = '3.33';
$VERSION = eval $VERSION;
@ISA = qw(File::Spec::Unix);
diff --git a/Master/tlpkg/tlperl/lib/File/Spec/Epoc.pm b/Master/tlpkg/tlperl/lib/File/Spec/Epoc.pm
index 54ff667c52f..a3bb62b8656 100644
--- a/Master/tlpkg/tlperl/lib/File/Spec/Epoc.pm
+++ b/Master/tlpkg/tlperl/lib/File/Spec/Epoc.pm
@@ -3,7 +3,7 @@ package File::Spec::Epoc;
use strict;
use vars qw($VERSION @ISA);
-$VERSION = '3.30';
+$VERSION = '3.33';
$VERSION = eval $VERSION;
require File::Spec::Unix;
diff --git a/Master/tlpkg/tlperl/lib/File/Spec/Functions.pm b/Master/tlpkg/tlperl/lib/File/Spec/Functions.pm
index e7becc7cfae..2ee8f5d2c1a 100644
--- a/Master/tlpkg/tlperl/lib/File/Spec/Functions.pm
+++ b/Master/tlpkg/tlperl/lib/File/Spec/Functions.pm
@@ -5,7 +5,7 @@ use strict;
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
-$VERSION = '3.30';
+$VERSION = '3.33';
$VERSION = eval $VERSION;
require Exporter;
diff --git a/Master/tlpkg/tlperl/lib/File/Spec/Mac.pm b/Master/tlpkg/tlperl/lib/File/Spec/Mac.pm
index 8b47470d6b3..f47293cb2de 100644
--- a/Master/tlpkg/tlperl/lib/File/Spec/Mac.pm
+++ b/Master/tlpkg/tlperl/lib/File/Spec/Mac.pm
@@ -4,7 +4,7 @@ use strict;
use vars qw(@ISA $VERSION);
require File::Spec::Unix;
-$VERSION = '3.30';
+$VERSION = '3.34';
$VERSION = eval $VERSION;
@ISA = qw(File::Spec::Unix);
@@ -740,7 +740,7 @@ sub rel2abs {
# Split up paths
- # igonore $path's volume
+ # ignore $path's volume
my ( $path_dirs, $path_file ) = ($self->splitpath($path))[1,2] ;
# ignore $base's file part
diff --git a/Master/tlpkg/tlperl/lib/File/Spec/OS2.pm b/Master/tlpkg/tlperl/lib/File/Spec/OS2.pm
index a8fa63e3c16..a380dd719b7 100644
--- a/Master/tlpkg/tlperl/lib/File/Spec/OS2.pm
+++ b/Master/tlpkg/tlperl/lib/File/Spec/OS2.pm
@@ -4,7 +4,7 @@ use strict;
use vars qw(@ISA $VERSION);
require File::Spec::Unix;
-$VERSION = '3.30';
+$VERSION = '3.33';
$VERSION = eval $VERSION;
@ISA = qw(File::Spec::Unix);
diff --git a/Master/tlpkg/tlperl/lib/File/Spec/Unix.pm b/Master/tlpkg/tlperl/lib/File/Spec/Unix.pm
index 8fd2320a392..b276b213920 100644
--- a/Master/tlpkg/tlperl/lib/File/Spec/Unix.pm
+++ b/Master/tlpkg/tlperl/lib/File/Spec/Unix.pm
@@ -3,7 +3,7 @@ package File::Spec::Unix;
use strict;
use vars qw($VERSION);
-$VERSION = '3.30';
+$VERSION = '3.33';
$VERSION = eval $VERSION;
=head1 NAME
diff --git a/Master/tlpkg/tlperl/lib/File/Spec/VMS.pm b/Master/tlpkg/tlperl/lib/File/Spec/VMS.pm
index 6135fc54635..120575a3e0f 100644
--- a/Master/tlpkg/tlperl/lib/File/Spec/VMS.pm
+++ b/Master/tlpkg/tlperl/lib/File/Spec/VMS.pm
@@ -4,7 +4,7 @@ use strict;
use vars qw(@ISA $VERSION);
require File::Spec::Unix;
-$VERSION = '3.30';
+$VERSION = '3.34';
$VERSION = eval $VERSION;
@ISA = qw(File::Spec::Unix);
@@ -204,7 +204,7 @@ sub catdir {
if ($unix_mode) {
- # Fix up mixed syntax imput as good as possible - GIGO
+ # Fix up mixed syntax input as good as possible - GIGO
$path = unixify($path) if $path_vms;
$dir = unixify($dir) if $dir_vms;
@@ -216,7 +216,7 @@ sub catdir {
return $self->SUPER::canonpath($rslt);
} else {
- #with <> posible instead of [.
+ #with <> possible instead of [.
# Normalize the brackets
# Fixme - need to not switch when preceded by ^.
$path =~ s/</\[/g;
@@ -224,7 +224,7 @@ sub catdir {
$dir =~ s/</\[/g;
$dir =~ s/>/\]/g;
- # Fix up mixed syntax imput as good as possible - GIGO
+ # Fix up mixed syntax input as good as possible - GIGO
$path = vmsify($path) if $path_unix;
$dir = vmsify($dir) if $dir_unix;
@@ -413,7 +413,7 @@ sub catfile {
# Assume VMS mode
if (($spath_unix == $spath_vms) &&
($file_unix == $file_vms)) {
- # Ambigous, so if in $unix_rpt mode then assume UNIX.
+ # Ambiguous, so if in $unix_rpt mode then assume UNIX.
$unix_mode = 1 if $unix_rpt;
} else {
$unix_mode = 1
@@ -433,7 +433,7 @@ sub catfile {
$rslt = $spath;
$file = unixify($file) if ($file_vms);
- # Unix merge may need a directory delimitor.
+ # Unix merge may need a directory delimiter.
# A null path indicates root on Unix.
$rslt .= '/' unless ($rslt =~ m#/$#);
}
@@ -469,7 +469,7 @@ sub catfile {
}
return $self->canonpath($rslt) unless $unix_rpt;
- # In Unix report mode, do not strip off redundent path information.
+ # In Unix report mode, do not strip off redundant path information.
return $rslt;
}
diff --git a/Master/tlpkg/tlperl/lib/File/Spec/Win32.pm b/Master/tlpkg/tlperl/lib/File/Spec/Win32.pm
index 93301ac7357..28d8510ccf6 100644
--- a/Master/tlpkg/tlperl/lib/File/Spec/Win32.pm
+++ b/Master/tlpkg/tlperl/lib/File/Spec/Win32.pm
@@ -5,7 +5,7 @@ use strict;
use vars qw(@ISA $VERSION);
require File::Spec::Unix;
-$VERSION = '3.30';
+$VERSION = '3.33';
$VERSION = eval $VERSION;
@ISA = qw(File::Spec::Unix);
diff --git a/Master/tlpkg/tlperl/lib/File/Which.pm b/Master/tlpkg/tlperl/lib/File/Which.pm
deleted file mode 100644
index 69e336b03bd..00000000000
--- a/Master/tlpkg/tlperl/lib/File/Which.pm
+++ /dev/null
@@ -1,254 +0,0 @@
-package File::Which;
-
-use 5.004;
-use strict;
-use Exporter ();
-use File::Spec ();
-
-use vars qw{$VERSION @ISA @EXPORT @EXPORT_OK};
-BEGIN {
- $VERSION = '1.09';
- @ISA = 'Exporter';
- @EXPORT = 'which';
- @EXPORT_OK = 'where';
-}
-
-use constant IS_VMS => ($^O eq 'VMS');
-use constant IS_MAC => ($^O eq 'MacOS');
-use constant IS_DOS => ($^O eq 'MSWin32' or $^O eq 'dos' or $^O eq 'os2');
-
-# For Win32 systems, stores the extensions used for
-# executable files
-# For others, the empty string is used
-# because 'perl' . '' eq 'perl' => easier
-my @PATHEXT = ('');
-if ( IS_DOS ) {
- # WinNT. PATHEXT might be set on Cygwin, but not used.
- if ( $ENV{PATHEXT} ) {
- push @PATHEXT, split ';', $ENV{PATHEXT};
- } else {
- # Win9X or other: doesn't have PATHEXT, so needs hardcoded.
- push @PATHEXT, qw{.com .exe .bat};
- }
-} elsif ( IS_VMS ) {
- push @PATHEXT, qw{.exe .com};
-}
-
-sub which {
- my ($exec) = @_;
-
- return undef unless $exec;
-
- my $all = wantarray;
- my @results = ();
-
- # check for aliases first
- if ( IS_VMS ) {
- my $symbol = `SHOW SYMBOL $exec`;
- chomp($symbol);
- unless ( $? ) {
- return $symbol unless $all;
- push @results, $symbol;
- }
- }
- if ( IS_MAC ) {
- my @aliases = split /\,/, $ENV{Aliases};
- foreach my $alias ( @aliases ) {
- # This has not been tested!!
- # PPT which says MPW-Perl cannot resolve `Alias $alias`,
- # let's just hope it's fixed
- if ( lc($alias) eq lc($exec) ) {
- chomp(my $file = `Alias $alias`);
- last unless $file; # if it failed, just go on the normal way
- return $file unless $all;
- push @results, $file;
- # we can stop this loop as if it finds more aliases matching,
- # it'll just be the same result anyway
- last;
- }
- }
- }
-
- my @path = File::Spec->path;
- if ( IS_DOS or IS_VMS or IS_MAC ) {
- unshift @path, File::Spec->curdir;
- }
-
- foreach my $base ( map { File::Spec->catfile($_, $exec) } @path ) {
- for my $ext ( @PATHEXT ) {
- my $file = $base.$ext;
-
- # We don't want dirs (as they are -x)
- next if -d $file;
-
- if (
- # Executable, normal case
- -x _
- or (
- # MacOS doesn't mark as executable so we check -e
- IS_MAC
- ||
- (
- IS_DOS
- and
- grep {
- $file =~ /$_\z/i
- } @PATHEXT[1..$#PATHEXT]
- )
- # DOSish systems don't pass -x on
- # non-exe/bat/com files. so we check -e.
- # However, we don't want to pass -e on files
- # that aren't in PATHEXT, like README.
- and -e _
- )
- ) {
- return $file unless $all;
- push @results, $file;
- }
- }
- }
-
- if ( $all ) {
- return @results;
- } else {
- return undef;
- }
-}
-
-sub where {
- # force wantarray
- my @res = which($_[0]);
- return @res;
-}
-
-1;
-
-__END__
-
-=pod
-
-=head1 NAME
-
-File::Which - Portable implementation of the `which' utility
-
-=head1 SYNOPSIS
-
- use File::Which; # exports which()
- use File::Which qw(which where); # exports which() and where()
-
- my $exe_path = which('perldoc');
-
- my @paths = where('perl');
- - Or -
- my @paths = which('perl'); # an array forces search for all of them
-
-=head1 DESCRIPTION
-
-C<File::Which> was created to be able to get the paths to executable programs
-on systems under which the `which' program wasn't implemented in the shell.
-
-C<File::Which> searches the directories of the user's C<PATH> (as returned by
-C<File::Spec-E<gt>path()>), looking for executable files having the name
-specified as a parameter to C<which()>. Under Win32 systems, which do not have a
-notion of directly executable files, but uses special extensions such as C<.exe>
-and C<.bat> to identify them, C<File::Which> takes extra steps to assure that
-you will find the correct file (so for example, you might be searching for
-C<perl>, it'll try F<perl.exe>, F<perl.bat>, etc.)
-
-=head1 Steps Used on Win32, DOS, OS2 and VMS
-
-=head2 Windows NT
-
-Windows NT has a special environment variable called C<PATHEXT>, which is used
-by the shell to look for executable files. Usually, it will contain a list in
-the form C<.EXE;.BAT;.COM;.JS;.VBS> etc. If C<File::Which> finds such an
-environment variable, it parses the list and uses it as the different
-extensions.
-
-=head2 Windows 9x and other ancient Win/DOS/OS2
-
-This set of operating systems don't have the C<PATHEXT> variable, and usually
-you will find executable files there with the extensions C<.exe>, C<.bat> and
-(less likely) C<.com>. C<File::Which> uses this hardcoded list if it's running
-under Win32 but does not find a C<PATHEXT> variable.
-
-=head2 VMS
-
-Same case as Windows 9x: uses C<.exe> and C<.com> (in that order).
-
-=head1 Functions
-
-=head2 which($short_exe_name)
-
-Exported by default.
-
-C<$short_exe_name> is the name used in the shell to call the program (for
-example, C<perl>).
-
-If it finds an executable with the name you specified, C<which()> will return
-the absolute path leading to this executable (for example, F</usr/bin/perl> or
-F<C:\Perl\Bin\perl.exe>).
-
-If it does I<not> find the executable, it returns C<undef>.
-
-If C<which()> is called in list context, it will return I<all> the
-matches.
-
-=head2 where($short_exe_name)
-
-Not exported by default.
-
-Same as C<which($short_exe_name)> in array context. Same as the
-C<`where'> utility, will return an array containing all the path names
-matching C<$short_exe_name>.
-
-=head1 BUGS AND CAVEATS
-
-Not tested on VMS or MacOS, although there is platform specific code
-for those. Anyone who haves a second would be very kind to send me a
-report of how it went.
-
-File::Spec adds the current directory to the front of PATH if on
-Win32, VMS or MacOS. I have no knowledge of those so don't know if the
-current directory is searced first or not. Could someone please tell
-me?
-
-=head1 SUPPORT
-
-Bugs should be reported via the CPAN bug tracker at
-
-L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=File-Which>
-
-For other issues, contact the maintainer.
-
-=head1 AUTHOR
-
-Adam Kennedy E<lt>adamk@cpan.orgE<gt>
-
-Per Einar Ellefsen E<lt>pereinar@cpan.orgE<gt>
-
-Originated in F<modperl-2.0/lib/Apache/Build.pm>. Changed for use in DocSet
-(for the mod_perl site) and Win32-awareness by me, with slight modifications
-by Stas Bekman, then extracted to create C<File::Which>.
-
-Version 0.04 had some significant platform-related changes, taken from
-the Perl Power Tools C<`which'> implementation by Abigail with
-enhancements from Peter Prymmer. See
-L<http://www.perl.com/language/ppt/src/which/index.html> for more
-information.
-
-=head1 COPYRIGHT
-
-Copyright 2002 Per Einar Ellefsen.
-
-Some parts copyright 2009 Adam Kennedy.
-
-This program is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
-
-=head1 SEE ALSO
-
-L<File::Spec>, L<which(1)>, Perl Power Tools:
-L<http://www.perl.com/language/ppt/index.html>.
-
-=cut
diff --git a/Master/tlpkg/tlperl/lib/File/stat.pm b/Master/tlpkg/tlperl/lib/File/stat.pm
index bdf3aad52a2..69cc44af1d9 100644
--- a/Master/tlpkg/tlperl/lib/File/stat.pm
+++ b/Master/tlpkg/tlperl/lib/File/stat.pm
@@ -10,7 +10,7 @@ BEGIN { *warnif = \&warnings::warnif }
our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS);
-our $VERSION = '1.02';
+our $VERSION = '1.05';
my @fields;
BEGIN {
@@ -45,9 +45,6 @@ BEGIN {
# from doio.c
sub _ingroup {
-
- $^O eq "MacOS" and return 1;
-
my ($gid, $eff) = @_;
# I am assuming that since VMS doesn't have getgroups(2), $) will
@@ -87,7 +84,9 @@ else {
my ($s, $mode, $eff) = @_;
my $uid = $eff ? $> : $<;
- $^O ne "VMS" and $uid == 0 and return 1;
+ # If we're root on unix and we are not testing for executable
+ # status, then all file tests are true.
+ $^O ne "VMS" and $uid == 0 and !($mode & 0111) and return 1;
my ($stmode, $stuid, $stgid) = @$s[2,4,5];