diff options
author | Karl Berry <karl@freefriends.org> | 2012-05-21 00:15:27 +0000 |
---|---|---|
committer | Karl Berry <karl@freefriends.org> | 2012-05-21 00:15:27 +0000 |
commit | a4c42bfb2337d37da89d789cb8cc226367994e32 (patch) | |
tree | c3eabdef5d565a4e515d2be0d9d4d0540bde0250 /Master/tlpkg/tlperl/lib/File | |
parent | 8274475057f024d35332ac47c2e2f23ea156e6ed (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')
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 = \© @@ -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]; |