diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/File')
| -rw-r--r-- | Master/tlpkg/tlperl/lib/File/CheckTree.pm | 4 | ||||
| -rw-r--r-- | Master/tlpkg/tlperl/lib/File/Copy.pm | 30 | ||||
| -rw-r--r-- | Master/tlpkg/tlperl/lib/File/DosGlob.pm | 34 | ||||
| -rw-r--r-- | Master/tlpkg/tlperl/lib/File/Fetch.pm | 1090 | ||||
| -rw-r--r-- | Master/tlpkg/tlperl/lib/File/Find.pm | 14 | ||||
| -rw-r--r-- | Master/tlpkg/tlperl/lib/File/Glob.pm | 36 | ||||
| -rw-r--r-- | Master/tlpkg/tlperl/lib/File/Path.pm | 12 | ||||
| -rw-r--r-- | Master/tlpkg/tlperl/lib/File/Spec.pm | 4 | ||||
| -rw-r--r-- | Master/tlpkg/tlperl/lib/File/Spec/Cygwin.pm | 2 | ||||
| -rw-r--r-- | Master/tlpkg/tlperl/lib/File/Spec/Epoc.pm | 2 | ||||
| -rw-r--r-- | Master/tlpkg/tlperl/lib/File/Spec/Functions.pm | 2 | ||||
| -rw-r--r-- | Master/tlpkg/tlperl/lib/File/Spec/Mac.pm | 2 | ||||
| -rw-r--r-- | Master/tlpkg/tlperl/lib/File/Spec/OS2.pm | 2 | ||||
| -rw-r--r-- | Master/tlpkg/tlperl/lib/File/Spec/Unix.pm | 76 | ||||
| -rw-r--r-- | Master/tlpkg/tlperl/lib/File/Spec/VMS.pm | 2 | ||||
| -rw-r--r-- | Master/tlpkg/tlperl/lib/File/Spec/Win32.pm | 2 | ||||
| -rw-r--r-- | Master/tlpkg/tlperl/lib/File/Temp.pm | 223 | ||||
| -rw-r--r-- | Master/tlpkg/tlperl/lib/File/stat.pm | 27 |
18 files changed, 852 insertions, 712 deletions
diff --git a/Master/tlpkg/tlperl/lib/File/CheckTree.pm b/Master/tlpkg/tlperl/lib/File/CheckTree.pm index 4d53c5254dd..8107c7ac689 100644 --- a/Master/tlpkg/tlperl/lib/File/CheckTree.pm +++ b/Master/tlpkg/tlperl/lib/File/CheckTree.pm @@ -7,7 +7,9 @@ use File::Spec; use warnings; use strict; -our $VERSION = '4.41'; +use if $] > 5.017, 'deprecate'; + +our $VERSION = '4.42'; our @ISA = qw(Exporter); our @EXPORT = qw(validate); diff --git a/Master/tlpkg/tlperl/lib/File/Copy.pm b/Master/tlpkg/tlperl/lib/File/Copy.pm index cb246d645fb..19a5838c0a8 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.23'; +$VERSION = '2.26'; require Exporter; @ISA = qw(Exporter); @@ -128,9 +128,11 @@ sub copy { if (_eq($from, $to)) { # works for references, too carp("'$from' and '$to' are identical (not copied)"); - # The "copy" was a success as the source and destination contain - # the same data. - return 1; + return 0; + } + + if (!$from_a_handle && !$to_a_handle && -d $to && ! -d $from) { + $to = _catname($from, $to); } if ((($Config{d_symlink} && $Config{d_readlink}) || $Config{d_link}) && @@ -144,15 +146,14 @@ sub copy { } } } - - if (!$from_a_handle && !$to_a_handle && -d $to && ! -d $from) { - $to = _catname($from, $to); + elsif (_eq($from, $to)) { + carp("'$from' and '$to' are identical (not copied)"); + return 0; } if (defined &syscopy && !$Syscopy_is_copy && !$to_a_handle && !($from_a_handle && $^O eq 'os2' ) # OS/2 cannot handle handles - && !($from_a_handle && $^O eq 'mpeix') # and neither can MPE/iX. && !($from_a_handle && $^O eq 'MSWin32') && !($from_a_handle && $^O eq 'NetWare') ) @@ -410,13 +411,6 @@ sub mv { _move(@_,\&cp); } unless (defined &syscopy) { if ($^O eq 'VMS') { *syscopy = \&rmscopy; - } elsif ($^O eq 'mpeix') { - *syscopy = sub { - return 0 unless @_ == 2; - # Use the MPE cp program in order to - # preserve MPE file attributes. - return system('/bin/cp', '-f', $_[0], $_[1]) == 0; - }; } elsif ($^O eq 'MSWin32' && defined &DynaLoader::boot_DynaLoader) { # Win32::CopyFile() fill only work if we can load Win32.xs *syscopy = sub { @@ -468,7 +462,7 @@ glob. Obviously, if the first argument is a filehandle of some sort, it will be read from, and if it is a file I<name> it will be opened for reading. Likewise, the second argument will be written to (and created if need be). Trying to copy a file on top -of itself is a fatal error. +of itself is an error. If the destination (second argument) already exists and is a directory, and the source (first argument) is not a filehandle, then the source @@ -492,7 +486,7 @@ upon the file, but will generally be the whole file (up to 2MB), or You may use the syntax C<use File::Copy "cp"> to get at the C<cp> alias for this function. The syntax is I<exactly> the same. The -behavior is nearly the same as well: as of version 2.15, <cp> will +behavior is nearly the same as well: as of version 2.15, C<cp> will preserve the source file's permission bits like the shell utility C<cp(1)> would do, while C<copy> uses the default permissions for the target file (which may depend on the process' C<umask>, file @@ -515,7 +509,7 @@ during this copy-and-delete process, you may be left with a (possibly partial) copy of the file under the destination name. You may use the C<mv> alias for this function in the same way that -you may use the <cp> alias for C<copy>. +you may use the C<cp> alias for C<copy>. =item syscopy X<syscopy> diff --git a/Master/tlpkg/tlperl/lib/File/DosGlob.pm b/Master/tlpkg/tlperl/lib/File/DosGlob.pm index 7e57175ca3f..c90bebb2780 100644 --- a/Master/tlpkg/tlperl/lib/File/DosGlob.pm +++ b/Master/tlpkg/tlperl/lib/File/DosGlob.pm @@ -1,23 +1,22 @@ #!perl -w -# use strict fails -#Can't use string ("main::glob") as a symbol ref while "strict refs" in use at /usr/lib/perl5/5.005/File/DosGlob.pm line 191. - # # Documentation at the __END__ # package File::DosGlob; -our $VERSION = '1.06'; +our $VERSION = '1.10'; use strict; use warnings; +require XSLoader; +XSLoader::load(); + sub doglob { my $cond = shift; my @retval = (); my $fix_drive_relative_paths; - #print "doglob: ", join('|', @_), "\n"; OUTER: for my $pat (@_) { my @matched = (); @@ -41,7 +40,6 @@ sub doglob { } if ($pat =~ m|^(.*)([\\/])([^\\/]*)\z|s) { ($head, $sepchr, $tail) = ($1,$2,$3); - #print "div: |$head|$sepchr|$tail|\n"; push (@retval, $pat), next OUTER if $tail eq ''; if ($head =~ /[*?]/) { @globdirs = doglob('d', $head); @@ -64,6 +62,13 @@ sub doglob { opendir(D, $head) or next OUTER; my @leaves = readdir D; closedir D; + + # VMS-format filespecs, especially if they contain extended characters, + # are unlikely to match patterns correctly, so Unixify them. + if ($^O eq 'VMS') { + require VMS::Filespec; + @leaves = map {$_ =~ s/\.$//; VMS::Filespec::unixify($_)} @leaves; + } $head = '' if $head eq '.'; $head .= $sepchr unless $head eq '' or substr($head,-1) eq $sepchr; @@ -73,7 +78,6 @@ sub doglob { $pat =~ s/\*/.*/g; $pat =~ s/\?/.?/g; - #print "regex: '$pat', head: '$head'\n"; my $matchsub = sub { $_[0] =~ m|^$pat\z|is }; INNER: for my $e (@leaves) { @@ -106,18 +110,15 @@ sub doglob { # # context (keyed by second cxix arg provided by core) -my %entries; +our %entries; sub glob { - my($pat,$cxix) = @_; + my($pat,$cxix) = ($_[0], _callsite()); my @pat; # glob without args defaults to $_ $pat = $_ unless defined $pat; - # assume global context if not provided one - $cxix = '_G_' unless defined $cxix; - # if we're just beginning, do it all first if (!$entries{$cxix}) { # extract patterns @@ -142,7 +143,6 @@ sub glob { #print "Got: \n\t$start\n\t$match\n\t$end\n"; my $tmp = "$start$match$end"; while ( $tmp =~ s/^(.*?)(?<!\\)\{(?:.*(?<!\\)\,)?(.*\Q$match\E.*?)(?:(?<!\\)\,.*)?(?<!\\)\}(.*)$/$1$2$3/ ) { - #print "Striped: $tmp\n"; # these expansions will be performed by the original, # when we call REHASH. } @@ -160,7 +160,6 @@ sub glob { } if ( $#appendpat != -1 ) { - #print "LOOP\n"; #FIXME: Max loop, no way! :") for ( @appendpat ) { push @pat, $_; @@ -169,11 +168,8 @@ sub glob { } } for ( @pat ) { - s/\\{/{/g; - s/\\}/}/g; - s/\\,/,/g; + s/\\([{},])/$1/g; } - #print join ("\n", @pat). "\n"; $entries{$cxix} = [doglob(1,@pat)]; } @@ -236,7 +232,7 @@ It is largely compatible with perlglob.exe (the M$ setargv.obj version) in all but one respect--it understands wildcards in directory components. -For example, C<<..\\l*b\\file/*glob.p?>> will work as expected (in +For example, C<< <..\\l*b\\file/*glob.p?> >> will work as expected (in that it will find something like '..\lib\File/DosGlob.pm' alright). Note that all path components are case-insensitive, and that backslashes and forward slashes are both accepted, and preserved. diff --git a/Master/tlpkg/tlperl/lib/File/Fetch.pm b/Master/tlpkg/tlperl/lib/File/Fetch.pm index 5d0a51df161..37f7bc6ca9e 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.32'; +$VERSION = '0.38'; $VERSION = eval $VERSION; # avoid warnings with development releases $PREFER_BIN = 0; # XXX TODO implement $FROM_EMAIL = 'File-Fetch@example.com'; @@ -50,7 +50,7 @@ local $Module::Load::Conditional::VERBOSE = 0; ### see what OS we are on, important for file:// uris ### use constant ON_WIN => ($^O eq 'MSWin32'); -use constant ON_VMS => ($^O eq 'VMS'); +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); @@ -107,7 +107,7 @@ The scheme from the uri (like 'file', 'http', etc) =item $ff->host -The hostname in the uri. Will be empty if host was originally +The hostname in the uri. Will be empty if host was originally 'localhost' for a 'file://' url. =item $ff->vol @@ -117,8 +117,8 @@ of a file:// is considered to the be volume specification for the file. Thus on Win32 this routine returns the volume, on other operating systems this returns nothing. -On Windows this value may be empty if the uri is to a network share, in -which case the 'share' property will be defined. Additionally, volume +On Windows this value may be empty if the uri is to a network share, in +which case the 'share' property will be defined. Additionally, volume specifications that use '|' as ':' will be converted on read to use ':'. On VMS, which has a volume concept, this field will be empty because VMS @@ -127,7 +127,7 @@ information is transparently included. =item $ff->share -On systems with the concept of a network share (currently only Windows) returns +On systems with the concept of a network share (currently only Windows) returns the sharename from a file://// url. On other operating systems returns empty. =item $ff->path @@ -137,7 +137,14 @@ The path from the uri, will be at least a single '/'. =item $ff->file The name of the remote file. For the local file name, the -result of $ff->output_file will be used. +result of $ff->output_file will be used. + +=item $ff->file_default + +The name of the default local file, that $ff->output_file falls back to if +it would otherwise return no filename. For example when fetching a URI like +http://www.abc.net.au/ the contents retrieved may be from a remote file called +'index.html'. The default value of this attribute is literally 'file_default'. =cut @@ -156,10 +163,12 @@ result of $ff->output_file will be used. uri => { required => 1 }, vol => { default => '' }, # windows for file:// uris share => { default => '' }, # windows for file:// uris + file_default => { default => 'file_default' }, + tempdir_root => { required => 1 }, # Should be lazy-set at ->new() _error_msg => { no_override => 1 }, _error_msg_long => { no_override => 1 }, }; - + for my $method ( keys %$Tmpl ) { no strict 'refs'; *$method = sub { @@ -168,28 +177,28 @@ result of $ff->output_file will be used. return $self->{$method}; } } - + sub _create { my $class = shift; my %hash = @_; - + my $args = check( $Tmpl, \%hash ) or return; - + bless $args, $class; - + if( lc($args->scheme) ne 'file' and not $args->host ) { return $class->_error(loc( "Hostname required when fetching from '%1'",$args->scheme)); } - - for (qw[path file]) { + + for (qw[path]) { unless( $args->$_() ) { # 5.5.x needs the () return $class->_error(loc("No '%1' specified",$_)); } } - + return $args; - } + } } =item $ff->output_file @@ -199,7 +208,7 @@ but any query parameters are stripped off. For example: http://example.com/index.html?x=y -would make the output file be C<index.html> rather than +would make the output file be C<index.html> rather than C<index.html?x=y>. =back @@ -209,47 +218,49 @@ C<index.html?x=y>. sub output_file { my $self = shift; my $file = $self->file; - + $file =~ s/\?.*$//g; - + + $file ||= $self->file_default; + return $file; } ### XXX do this or just point to URI::Escape? # =head2 $esc_uri = $ff->escaped_uri -# +# # =cut -# +# # ### most of this is stolen straight from URI::escape # { ### Build a char->hex map # my %escapes = map { chr($_) => sprintf("%%%02X", $_) } 0..255; -# +# # sub escaped_uri { # my $self = shift; # my $uri = $self->uri; -# +# # ### Default unsafe characters. RFC 2732 ^(uric - reserved) # $uri =~ s/([^A-Za-z0-9\-_.!~*'()])/ # $escapes{$1} || $self->_fail_hi($1)/ge; -# +# # return $uri; # } -# +# # sub _fail_hi { # my $self = shift; # my $char = shift; -# +# # $self->_error(loc( -# "Can't escape '%1', try using the '%2' module instead", +# "Can't escape '%1', try using the '%2' module instead", # sprintf("\\x{%04X}", ord($char)), 'URI::Escape' -# )); +# )); # } -# +# # sub output_file { -# +# # } -# -# +# +# # } =head1 METHODS @@ -267,9 +278,11 @@ sub new { my $class = shift; my %hash = @_; - my ($uri); + my ($uri, $file_default, $tempdir_root); my $tmpl = { - uri => { required => 1, store => \$uri }, + uri => { required => 1, store => \$uri }, + file_default => { required => 0, store => \$file_default }, + tempdir_root => { required => 0, store => \$tempdir_root }, }; check( $tmpl, \%hash ) or return; @@ -277,6 +290,10 @@ sub new { ### parse the uri to usable parts ### my $href = $class->_parse_uri( $uri ) or return; + $href->{file_default} = $file_default if $file_default; + $href->{tempdir_root} = File::Spec->rel2abs( $tempdir_root ) if $tempdir_root; + $href->{tempdir_root} = File::Spec->rel2abs( Cwd::cwd ) if not $href->{tempdir_root}; + ### make it into a FFI object ### my $ff = $class->_create( %$href ) or return; @@ -300,22 +317,22 @@ sub new { ### ### In the case of file:// urls there maybe be additional fields ### -### For systems with volume specifications such as Win32 there will be +### For systems with volume specifications such as Win32 there will be ### a volume specifier provided in the 'vol' field. ### ### 'vol' => 'volumename' ### ### For windows file shares there may be a 'share' key specified ### -### 'share' => 'sharename' +### 'share' => 'sharename' ### -### Note that the rules of what a file:// url means vary by the operating system +### Note that the rules of what a file:// url means vary by the operating system ### of the host being addressed. Thus file:///d|/foo/bar.txt means the obvious -### 'D:\foo\bar.txt' on windows, but on unix it means '/d|/foo/bar.txt' and +### 'D:\foo\bar.txt' on windows, but on unix it means '/d|/foo/bar.txt' and ### not '/foo/bar.txt' ### -### Similarly if the host interpreting the url is VMS then -### file:///disk$user/my/notes/note12345.txt' means +### Similarly if the host interpreting the url is VMS then +### file:///disk$user/my/notes/note12345.txt' means ### 'DISK$USER:[MY.NOTES]NOTE123456.TXT' but will be returned the same as ### if it is unix where it means /disk$user/my/notes/note12345.txt'. ### Except for some cases in the File::Spec methods, Perl on VMS will generally @@ -341,7 +358,7 @@ sub _parse_uri { ### And wikipedia for more on windows file:// urls ### http://en.wikipedia.org/wiki/File:// if( $href->{scheme} eq 'file' ) { - + my @parts = split '/',$uri; ### file://hostname/... @@ -350,36 +367,36 @@ sub _parse_uri { $href->{host} = $parts[0] || ''; ### index in @parts where the path components begin; - my $index = 1; + my $index = 1; - ### file:////hostname/sharename/blah.txt + ### file:////hostname/sharename/blah.txt if ( HAS_SHARE and not length $parts[0] and not length $parts[1] ) { - + $href->{host} = $parts[2] || ''; # avoid warnings - $href->{share} = $parts[3] || ''; # avoid warnings + $href->{share} = $parts[3] || ''; # avoid warnings $index = 4 # index after the share ### file:///D|/blah.txt ### file:///D:/blah.txt } elsif (HAS_VOL) { - + ### this code comes from dmq's patch, but: ### XXX if volume is empty, wouldn't that be an error? --kane - ### if so, our file://localhost test needs to be fixed as wel + ### if so, our file://localhost test needs to be fixed as wel $href->{vol} = $parts[1] || ''; ### correct D| style colume descriptors $href->{vol} =~ s/\A([A-Z])\|\z/$1:/i if ON_WIN; $index = 2; # index after the volume - } + } ### rebuild the path from the leftover parts; $href->{path} = join '/', '', splice( @parts, $index, $#parts ); } else { - ### using anything but qw() in hash slices may produce warnings + ### using anything but qw() in hash slices may produce warnings ### in older perls :-( @{$href}{ qw(host path) } = $uri =~ m|([^/]*)(/.*)$|s; } @@ -390,7 +407,7 @@ sub _parse_uri { $href->{file} = $parts[2]; } - ### host will be empty if the target was 'localhost' and the + ### host will be empty if the target was 'localhost' and the ### scheme was 'file' $href->{host} = '' if ($href->{host} eq 'localhost') and ($href->{scheme} eq 'file'); @@ -402,7 +419,7 @@ sub _parse_uri { Fetches the file you requested and returns the full path to the file. -By default it writes to C<cwd()>, but you can override that by specifying +By default it writes to C<cwd()>, but you can override that by specifying the C<to> argument: ### file fetch to /tmp, full path to the file in $where @@ -431,7 +448,7 @@ sub fetch { my ($to, $fh); ### you want us to slurp the contents if( ref $target and UNIVERSAL::isa( $target, 'SCALAR' ) ) { - $to = tempdir( 'FileFetch.XXXXXX', CLEANUP => 1 ); + $to = tempdir( 'FileFetch.XXXXXX', DIR => $self->tempdir_root, CLEANUP => 1 ); ### plain old fetch } else { @@ -443,7 +460,7 @@ sub fetch { ### create the path if it doesn't exist yet ### unless( -d $to ) { eval { mkpath( $to ) }; - + return $self->_error(loc("Could not create path '%1'",$to)) if $@; } } @@ -453,9 +470,9 @@ sub fetch { ### we dont use catfile on win32 because if we are using a cygwin tool ### under cmd.exe they wont understand windows style separators. - my $out_to = ON_WIN ? $to.'/'.$self->output_file + my $out_to = ON_WIN ? $to.'/'.$self->output_file : File::Spec->catfile( $to, $self->output_file ); - + for my $method ( @{ $METHODS->{$self->scheme} } ) { my $sub = '_'.$method.'_fetch'; @@ -473,13 +490,13 @@ sub fetch { ### there's serious issues with IPC::Run and quoting of command ### line arguments. using quotes in the wrong place breaks things, - ### and in the case of say, + ### and in the case of say, ### C:\cygwin\bin\wget.EXE --quiet --passive-ftp --output-document ### "index.html" "http://www.cpan.org/index.html?q=1&y=2" ### it doesn't matter how you quote, it always fails. local $IPC::Cmd::USE_IPC_RUN = 0; - - if( my $file = $self->$sub( + + if( my $file = $self->$sub( to => $out_to )){ @@ -496,18 +513,18 @@ sub fetch { ### slurp mode? if( ref $target and UNIVERSAL::isa( $target, 'SCALAR' ) ) { - + ### open the file open my $fh, "<$file" or do { $self->_error( loc("Could not open '%1': %2", $file, $!)); - return; + return; }; - + ### slurp $$target = do { local $/; <$fh> }; - - } + + } my $abs = File::Spec->rel2abs( $file ); return $abs; @@ -547,41 +564,40 @@ sub _lwp_fetch { }; - if( can_load(modules => $use_list) ) { - - ### setup the uri object - my $uri = URI->new( File::Spec::Unix->catfile( - $self->path, $self->file - ) ); + unless( can_load( modules => $use_list ) ) { + $METHOD_FAIL->{'lwp'} = 1; + return; + } - ### special rules apply for file:// uris ### - $uri->scheme( $self->scheme ); - $uri->host( $self->scheme eq 'file' ? '' : $self->host ); - $uri->userinfo("anonymous:$FROM_EMAIL") if $self->scheme ne 'file'; + ### setup the uri object + my $uri = URI->new( File::Spec::Unix->catfile( + $self->path, $self->file + ) ); - ### set up the useragent object - my $ua = LWP::UserAgent->new(); - $ua->timeout( $TIMEOUT ) if $TIMEOUT; - $ua->agent( $USER_AGENT ); - $ua->from( $FROM_EMAIL ); - $ua->env_proxy; + ### special rules apply for file:// uris ### + $uri->scheme( $self->scheme ); + $uri->host( $self->scheme eq 'file' ? '' : $self->host ); + $uri->userinfo("anonymous:$FROM_EMAIL") if $self->scheme ne 'file'; - my $res = $ua->mirror($uri, $to) or return; + ### set up the useragent object + my $ua = LWP::UserAgent->new(); + $ua->timeout( $TIMEOUT ) if $TIMEOUT; + $ua->agent( $USER_AGENT ); + $ua->from( $FROM_EMAIL ); + $ua->env_proxy; - ### uptodate or fetched ok ### - if ( $res->code == 304 or $res->code == 200 ) { - return $to; + my $res = $ua->mirror($uri, $to) or return; - } else { - return $self->_error(loc("Fetch failed! HTTP response: %1 %2 [%3]", - $res->code, HTTP::Status::status_message($res->code), - $res->status_line)); - } + ### uptodate or fetched ok ### + if ( $res->code == 304 or $res->code == 200 ) { + return $to; } else { - $METHOD_FAIL->{'lwp'} = 1; - return; + return $self->_error(loc("Fetch failed! HTTP response: %1 %2 [%3]", + $res->code, HTTP::Status::status_message($res->code), + $res->status_line)); } + } ### HTTP::Tiny fetching ### @@ -600,28 +616,26 @@ sub _httptiny_fetch { }; - if( can_load(modules => $use_list) ) { + unless( can_load(modules => $use_list) ) { + $METHOD_FAIL->{'httptiny'} = 1; + return; + } - my $uri = $self->uri; + my $uri = $self->uri; - my $http = HTTP::Tiny->new( ( $TIMEOUT ? ( timeout => $TIMEOUT ) : () ) ); + my $http = HTTP::Tiny->new( ( $TIMEOUT ? ( timeout => $TIMEOUT ) : () ) ); - my $rc = $http->mirror( $uri, $to ); + my $rc = $http->mirror( $uri, $to ); - unless ( $rc->{success} ) { + unless ( $rc->{success} ) { - return $self->_error(loc( "Fetch failed! HTTP response: %1 [%2]", - $rc->{status}, $rc->{reason} ) ); + return $self->_error(loc( "Fetch failed! HTTP response: %1 [%2]", + $rc->{status}, $rc->{reason} ) ); - } + } - return $to; + return $to; - } - else { - $METHOD_FAIL->{'httptiny'} = 1; - return; - } } ### HTTP::Lite fetching ### @@ -641,66 +655,63 @@ sub _httplite_fetch { }; - # https://github.com/dagolden/cpanpm/compare/master...private%2Fuse-http-lite - - if( can_load(modules => $use_list) ) { + unless( can_load(modules => $use_list) ) { + $METHOD_FAIL->{'httplite'} = 1; + return; + } - my $uri = $self->uri; - my $retries = 0; + my $uri = $self->uri; + my $retries = 0; - RETRIES: while ( $retries++ < 5 ) { + 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 $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; + my $fh = FileHandle->new; - unless ( $fh->open($to,'>') ) { - return $self->_error(loc( - "Could not open '%1' for writing: %2",$to,$!)); - } + unless ( $fh->open($to,'>') ) { + return $self->_error(loc( + "Could not open '%1' for writing: %2",$to,$!)); + } - $fh->autoflush(1); + $fh->autoflush(1); - binmode $fh; + binmode $fh; - my $rc = $http->request( $uri, sub { my ($self,$dref,$cbargs) = @_; local $\; print {$cbargs} $$dref }, $fh ); + my $rc = $http->request( $uri, sub { my ($self,$dref,$cbargs) = @_; local $\; print {$cbargs} $$dref }, $fh ); - close $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; + if ( $rc == 301 || $rc == 302 ) { + my $loc; + HEADERS: for ($http->headers_array) { + /Location: (\S+)/ and $loc = $1, last HEADERS; } - elsif ( $rc == 200 ) { - return $to; + #$loc or last; # Think we should squeal here. + if ($loc =~ m!^/!) { + $uri =~ s{^(\w+?://[^/]+)/.*$}{$1}; + $uri .= $loc; } else { - return $self->_error(loc("Fetch failed! HTTP response: %1 [%2]", - $rc, $http->status_message)); + $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. + } # Loop for 5 retries. - return $self->_error("Fetch failed! Gave up after 5 tries"); + return $self->_error("Fetch failed! Gave up after 5 tries"); - } else { - $METHOD_FAIL->{'httplite'} = 1; - return; - } } ### Simple IO::Socket::INET fetching ### @@ -719,74 +730,73 @@ sub _iosock_fetch { 'IO::Select' => '0.0', }; - if( can_load(modules => $use_list) ) { - my $sock = IO::Socket::INET->new( - PeerHost => $self->host, - ( $self->host =~ /:/ ? () : ( PeerPort => 80 ) ), - ); + unless( can_load(modules => $use_list) ) { + $METHOD_FAIL->{'iosock'} = 1; + return; + } - unless ( $sock ) { - return $self->_error(loc("Could not open socket to '%1', '%2'",$self->host,$!)); - } + my $sock = IO::Socket::INET->new( + PeerHost => $self->host, + ( $self->host =~ /:/ ? () : ( PeerPort => 80 ) ), + ); - my $fh = FileHandle->new; + unless ( $sock ) { + return $self->_error(loc("Could not open socket to '%1', '%2'",$self->host,$!)); + } - # Check open() + my $fh = FileHandle->new; - unless ( $fh->open($to,'>') ) { - return $self->_error(loc( - "Could not open '%1' for writing: %2",$to,$!)); - } + # Check open() - $fh->autoflush(1); - binmode $fh; + unless ( $fh->open($to,'>') ) { + return $self->_error(loc( + "Could not open '%1' for writing: %2",$to,$!)); + } - 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 ); + $fh->autoflush(1); + binmode $fh; - my $select = IO::Select->new( $sock ); + 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 ); - my $resp = ''; - my $normal = 0; - while ( $select->can_read( $TIMEOUT || 60 ) ) { - my $ret = $sock->sysread( $resp, 4096, length($resp) ); - if ( !defined $ret or $ret == 0 ) { - $select->remove( $sock ); - $normal++; - } - } - close $sock; + my $select = IO::Select->new( $sock ); - unless ( $normal ) { - return $self->_error(loc("Socket timed out after '%1' seconds", ( $TIMEOUT || 60 ))); - } + my $resp = ''; + my $normal = 0; + while ( $select->can_read( $TIMEOUT || 60 ) ) { + my $ret = $sock->sysread( $resp, 4096, length($resp) ); + if ( !defined $ret or $ret == 0 ) { + $select->remove( $sock ); + $normal++; + } + } + close $sock; - # Check the "response" - # 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 ) { - return $self->_error(loc("Did not get a HTTP response from '%1'",$self->host)); - } + unless ( $normal ) { + return $self->_error(loc("Socket timed out after '%1' seconds", ( $TIMEOUT || 60 ))); + } - # Check for OK - my ($code) = $resp =~ m!^HTTP/\d+\.\d+\s+(\d+)!i; - unless ( $code eq '200' ) { - return $self->_error(loc("Got a '%1' from '%2' expected '200'",$code,$self->host)); - } + # Check the "response" + # 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 ) { + return $self->_error(loc("Did not get a HTTP response from '%1'",$self->host)); + } - { - local $\; - print $fh +($resp =~ m/\x0d\x0a\x0d\x0a(.*)$/s )[0]; - } - close $fh; - return $to; + # Check for OK + my ($code) = $resp =~ m!^HTTP/\d+\.\d+\s+(\d+)!i; + unless ( $code eq '200' ) { + return $self->_error(loc("Got a '%1' from '%2' expected '200'",$code,$self->host)); + } - } else { - $METHOD_FAIL->{'iosock'} = 1; - return; + { + local $\; + print $fh +($resp =~ m/\x0d\x0a\x0d\x0a(.*)$/s )[0]; } + close $fh; + return $to; } ### Net::FTP fetching @@ -803,44 +813,43 @@ sub _netftp_fetch { ### required modules ### my $use_list = { 'Net::FTP' => 0 }; - if( can_load( modules => $use_list ) ) { + unless( can_load( modules => $use_list ) ) { + $METHOD_FAIL->{'netftp'} = 1; + return; + } - ### make connection ### - my $ftp; - my @options = ($self->host); - push(@options, Timeout => $TIMEOUT) if $TIMEOUT; - unless( $ftp = Net::FTP->new( @options ) ) { - return $self->_error(loc("Ftp creation failed: %1",$@)); - } + ### make connection ### + my $ftp; + my @options = ($self->host); + push(@options, Timeout => $TIMEOUT) if $TIMEOUT; + unless( $ftp = Net::FTP->new( @options ) ) { + return $self->_error(loc("Ftp creation failed: %1",$@)); + } - ### login ### - unless( $ftp->login( anonymous => $FROM_EMAIL ) ) { - return $self->_error(loc("Could not login to '%1'",$self->host)); - } + ### login ### + unless( $ftp->login( anonymous => $FROM_EMAIL ) ) { + return $self->_error(loc("Could not login to '%1'",$self->host)); + } - ### set binary mode, just in case ### - $ftp->binary; + ### set binary mode, just in case ### + $ftp->binary; - ### create the remote path - ### remember remote paths are unix paths! [#11483] - my $remote = File::Spec::Unix->catfile( $self->path, $self->file ); + ### create the remote path + ### remember remote paths are unix paths! [#11483] + my $remote = File::Spec::Unix->catfile( $self->path, $self->file ); - ### fetch the file ### - my $target; - unless( $target = $ftp->get( $remote, $to ) ) { - return $self->_error(loc("Could not fetch '%1' from '%2'", - $remote, $self->host)); - } + ### fetch the file ### + my $target; + unless( $target = $ftp->get( $remote, $to ) ) { + return $self->_error(loc("Could not fetch '%1' from '%2'", + $remote, $self->host)); + } - ### log out ### - $ftp->quit; + ### log out ### + $ftp->quit; - return $target; + return $target; - } else { - $METHOD_FAIL->{'netftp'} = 1; - return; - } } ### /bin/wget fetch ### @@ -854,47 +863,46 @@ sub _wget_fetch { }; check( $tmpl, \%hash ) or return; + my $wget; ### see if we have a wget binary ### - if( my $wget = can_run('wget') ) { - - ### no verboseness, thanks ### - my $cmd = [ $wget, '--quiet' ]; + unless( $wget = can_run('wget') ) { + $METHOD_FAIL->{'wget'} = 1; + return; + } - ### if a timeout is set, add it ### - push(@$cmd, '--timeout=' . $TIMEOUT) if $TIMEOUT; + ### no verboseness, thanks ### + my $cmd = [ $wget, '--quiet' ]; - ### run passive if specified ### - push @$cmd, '--passive-ftp' if $FTP_PASSIVE; + ### if a timeout is set, add it ### + push(@$cmd, '--timeout=' . $TIMEOUT) if $TIMEOUT; - ### set the output document, add the uri ### - push @$cmd, '--output-document', $to, $self->uri; + ### run passive if specified ### + push @$cmd, '--passive-ftp' if $FTP_PASSIVE; - ### 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); + ### set the output document, add the uri ### + push @$cmd, '--output-document', $to, $self->uri; - ### 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 || '' )); - } + ### 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); - return $to; + ### 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; - } else { - $METHOD_FAIL->{'wget'} = 1; - return; + return $self->_error(loc( "Command failed: %1", $captured || '' )); } + + return $to; } ### /bin/lftp fetch ### @@ -908,67 +916,66 @@ sub _lftp_fetch { }; check( $tmpl, \%hash ) or return; - ### see if we have a wget binary ### - if( my $lftp = can_run('lftp') ) { + ### see if we have a lftp binary ### + my $lftp; + unless( $lftp = can_run('lftp') ) { + $METHOD_FAIL->{'lftp'} = 1; + return; + } - ### no verboseness, thanks ### - my $cmd = [ $lftp, '-f' ]; + ### no verboseness, thanks ### + my $cmd = [ $lftp, '-f' ]; - my $fh = File::Temp->new; - - my $str; - - ### if a timeout is set, add it ### - $str .= "set net:timeout $TIMEOUT;\n" if $TIMEOUT; + my $fh = File::Temp->new; - ### run passive if specified ### - $str .= "set ftp:passive-mode 1;\n" if $FTP_PASSIVE; + my $str; - ### set the output document, add the uri ### - ### quote the URI, because lftp supports certain shell - ### expansions, most notably & for backgrounding. - ### ' quote does nto work, must be " - $str .= q[get ']. $self->uri .q[' -o ]. $to . $/; + ### if a timeout is set, add it ### + $str .= "set net:timeout $TIMEOUT;\n" if $TIMEOUT; - if( $DEBUG ) { - my $pp_str = join ' ', split $/, $str; - print "# lftp command: $pp_str\n"; - } + ### run passive if specified ### + $str .= "set ftp:passive-mode 1;\n" if $FTP_PASSIVE; - ### write straight to the file. - $fh->autoflush(1); - print $fh $str; + ### set the output document, add the uri ### + ### quote the URI, because lftp supports certain shell + ### expansions, most notably & for backgrounding. + ### ' quote does nto work, must be " + $str .= q[get ']. $self->uri .q[' -o ]. $to . $/; - ### the command needs to be 1 string to be executed - push @$cmd, $fh->filename; + if( $DEBUG ) { + my $pp_str = join ' ', split $/, $str; + print "# lftp command: $pp_str\n"; + } - ### 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); + ### write straight to the file. + $fh->autoflush(1); + print $fh $str; + ### the command needs to be 1 string to be executed + push @$cmd, $fh->filename; - ### 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 || '' )); - } + ### 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); - return $to; - } else { - $METHOD_FAIL->{'lftp'} = 1; - return; + ### 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; } @@ -985,32 +992,35 @@ sub _ftp_fetch { check( $tmpl, \%hash ) or return; ### see if we have a ftp binary ### - if( my $ftp = can_run('ftp') ) { + my $ftp; + unless( $ftp = can_run('ftp') ) { + $METHOD_FAIL->{'ftp'} = 1; + return; + } - my $fh = FileHandle->new; + my $fh = FileHandle->new; - local $SIG{CHLD} = 'IGNORE'; + local $SIG{CHLD} = 'IGNORE'; - unless ($fh->open("|$ftp -n")) { - return $self->_error(loc("%1 creation failed: %2", $ftp, $!)); - } + unless ($fh->open("$ftp -n", '|-')) { + return $self->_error(loc("%1 creation failed: %2", $ftp, $!)); + } - my @dialog = ( - "lcd " . dirname($to), - "open " . $self->host, - "user anonymous $FROM_EMAIL", - "cd /", - "cd " . $self->path, - "binary", - "get " . $self->file . " " . $self->output_file, - "quit", - ); + my @dialog = ( + "lcd " . dirname($to), + "open " . $self->host, + "user anonymous $FROM_EMAIL", + "cd /", + "cd " . $self->path, + "binary", + "get " . $self->file . " " . $self->output_file, + "quit", + ); - foreach (@dialog) { $fh->print($_, "\n") } - $fh->close or return; + foreach (@dialog) { $fh->print($_, "\n") } + $fh->close or return; - return $to; - } + return $to; } ### lynx is stupid - it decompresses any .gz file it finds to be text @@ -1026,94 +1036,93 @@ sub _lynx_fetch { check( $tmpl, \%hash ) or return; ### see if we have a lynx binary ### - if( my $lynx = can_run('lynx') ) { - - unless( IPC::Cmd->can_capture_buffer ) { - $METHOD_FAIL->{'lynx'} = 1; - - return $self->_error(loc( - "Can not capture buffers. Can not use '%1' to fetch files", - 'lynx' )); - } - - ### check if the HTTP resource exists ### - if ($self->uri =~ /^https?:\/\//i) { - my $cmd = [ - $lynx, - '-head', - '-source', - "-auth=anonymous:$FROM_EMAIL", - ]; - - push @$cmd, "-connect_timeout=$TIMEOUT" if $TIMEOUT; - - push @$cmd, $self->uri; - - ### shell out ### - my $head; - unless(run( command => $cmd, - buffer => \$head, - verbose => $DEBUG ) - ) { - return $self->_error(loc("Command failed: %1", $head || '')); - } + my $lynx; + unless ( $lynx = can_run('lynx') ){ + $METHOD_FAIL->{'lynx'} = 1; + return; + } - unless($head =~ /^HTTP\/\d+\.\d+ 200\b/) { - return $self->_error(loc("Command failed: %1", $head || '')); - } - } + unless( IPC::Cmd->can_capture_buffer ) { + $METHOD_FAIL->{'lynx'} = 1; - ### write to the output file ourselves, since lynx ass_u_mes to much - my $local = FileHandle->new(">$to") - or return $self->_error(loc( - "Could not open '%1' for writing: %2",$to,$!)); + return $self->_error(loc( + "Can not capture buffers. Can not use '%1' to fetch files", + 'lynx' )); + } - ### dump to stdout ### + ### check if the HTTP resource exists ### + if ($self->uri =~ /^https?:\/\//i) { my $cmd = [ $lynx, + '-head', '-source', "-auth=anonymous:$FROM_EMAIL", ]; push @$cmd, "-connect_timeout=$TIMEOUT" if $TIMEOUT; - ### DO NOT quote things for IPC::Run, it breaks stuff. push @$cmd, $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 - # ? $self->uri - # : QUOTE. $self->uri .QUOTE; - ### shell out ### - my $captured; + my $head; unless(run( command => $cmd, - buffer => \$captured, + buffer => \$head, verbose => $DEBUG ) ) { - return $self->_error(loc("Command failed: %1", $captured || '')); + return $self->_error(loc("Command failed: %1", $head || '')); } - ### print to local file ### - ### XXX on a 404 with a special error page, $captured will actually - ### hold the contents of that page, and make it *appear* like the - ### request was a success, when really it wasn't :( - ### there doesn't seem to be an option for lynx to change the exit - ### code based on a 4XX status or so. - ### the closest we can come is using --error_file and parsing that, - ### which is very unreliable ;( - $local->print( $captured ); - $local->close or return; - - return $to; + unless($head =~ /^HTTP\/\d+\.\d+ 200\b/) { + return $self->_error(loc("Command failed: %1", $head || '')); + } + } - } else { - $METHOD_FAIL->{'lynx'} = 1; - return; + ### write to the output file ourselves, since lynx ass_u_mes to much + my $local = FileHandle->new( $to, 'w' ) + or return $self->_error(loc( + "Could not open '%1' for writing: %2",$to,$!)); + + ### dump to stdout ### + my $cmd = [ + $lynx, + '-source', + "-auth=anonymous:$FROM_EMAIL", + ]; + + push @$cmd, "-connect_timeout=$TIMEOUT" if $TIMEOUT; + + ### DO NOT quote things for IPC::Run, it breaks stuff. + push @$cmd, $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 + # ? $self->uri + # : QUOTE. $self->uri .QUOTE; + + + ### shell out ### + my $captured; + unless(run( command => $cmd, + buffer => \$captured, + verbose => $DEBUG ) + ) { + return $self->_error(loc("Command failed: %1", $captured || '')); } + + ### print to local file ### + ### XXX on a 404 with a special error page, $captured will actually + ### hold the contents of that page, and make it *appear* like the + ### request was a success, when really it wasn't :( + ### there doesn't seem to be an option for lynx to change the exit + ### code based on a 4XX status or so. + ### the closest we can come is using --error_file and parsing that, + ### which is very unreliable ;( + $local->print( $captured ); + $local->close or return; + + return $to; } ### use /bin/ncftp to fetch files @@ -1132,38 +1141,38 @@ sub _ncftp_fetch { return if $FTP_PASSIVE; ### see if we have a ncftp binary ### - if( my $ncftp = can_run('ncftp') ) { - - my $cmd = [ - $ncftp, - '-V', # do not be verbose - '-p', $FROM_EMAIL, # email as password - $self->host, # hostname - dirname($to), # local dir for the file - # remote path to the file - ### DO NOT quote things for IPC::Run, it breaks stuff. - $IPC::Cmd::USE_IPC_RUN - ? File::Spec::Unix->catdir( $self->path, $self->file ) - : QUOTE. File::Spec::Unix->catdir( - $self->path, $self->file ) .QUOTE - - ]; - - ### shell out ### - my $captured; - unless(run( command => $cmd, - buffer => \$captured, - verbose => $DEBUG ) - ) { - return $self->_error(loc("Command failed: %1", $captured || '')); - } - - return $to; - - } else { + my $ncftp; + unless( $ncftp = can_run('ncftp') ) { $METHOD_FAIL->{'ncftp'} = 1; return; } + + my $cmd = [ + $ncftp, + '-V', # do not be verbose + '-p', $FROM_EMAIL, # email as password + $self->host, # hostname + dirname($to), # local dir for the file + # remote path to the file + ### DO NOT quote things for IPC::Run, it breaks stuff. + $IPC::Cmd::USE_IPC_RUN + ? File::Spec::Unix->catdir( $self->path, $self->file ) + : QUOTE. File::Spec::Unix->catdir( + $self->path, $self->file ) .QUOTE + + ]; + + ### shell out ### + my $captured; + unless(run( command => $cmd, + buffer => \$captured, + verbose => $DEBUG ) + ) { + return $self->_error(loc("Command failed: %1", $captured || '')); + } + + return $to; + } ### use /bin/curl to fetch files @@ -1176,48 +1185,47 @@ sub _curl_fetch { to => { required => 1, store => \$to } }; check( $tmpl, \%hash ) or return; + my $curl; + unless ( $curl = can_run('curl') ) { + $METHOD_FAIL->{'curl'} = 1; + return; + } - if (my $curl = can_run('curl')) { - - ### these long opts are self explanatory - I like that -jmb - my $cmd = [ $curl, '-q' ]; + ### these long opts are self explanatory - I like that -jmb + my $cmd = [ $curl, '-q' ]; - push(@$cmd, '--connect-timeout', $TIMEOUT) if $TIMEOUT; + push(@$cmd, '--connect-timeout', $TIMEOUT) if $TIMEOUT; - push(@$cmd, '--silent') unless $DEBUG; + push(@$cmd, '--silent') unless $DEBUG; - ### curl does the right thing with passive, regardless ### - if ($self->scheme eq 'ftp') { - push(@$cmd, '--user', "anonymous:$FROM_EMAIL"); - } + ### curl does the right thing with passive, regardless ### + if ($self->scheme eq 'ftp') { + push(@$cmd, '--user', "anonymous:$FROM_EMAIL"); + } - ### curl doesn't follow 302 (temporarily moved) etc automatically - ### so we add --location to enable that. - push @$cmd, '--fail', '--location', '--output', $to, $self->uri; + ### curl doesn't follow 302 (temporarily moved) etc automatically + ### so we add --location to enable that. + push @$cmd, '--fail', '--location', '--output', $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); + ### 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); - my $captured; - unless(run( command => $cmd, - buffer => \$captured, - verbose => $DEBUG ) - ) { + my $captured; + unless(run( command => $cmd, + buffer => \$captured, + verbose => $DEBUG ) + ) { - return $self->_error(loc("Command failed: %1", $captured || '')); - } + return $self->_error(loc("Command failed: %1", $captured || '')); + } - return $to; + return $to; - } else { - $METHOD_FAIL->{'curl'} = 1; - return; - } } ### /usr/bin/fetch fetch! ### @@ -1231,48 +1239,47 @@ sub _fetch_fetch { }; 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; + ### see if we have a fetch binary ### + my $fetch; + unless( HAS_FETCH and $fetch = can_run('fetch') ) { + $METHOD_FAIL->{'fetch'} = 1; return; } + + ### 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; } ### use File::Copy for fetching file:// urls ### @@ -1280,7 +1287,7 @@ sub _fetch_fetch { ### See section 3.10 of RFC 1738 (http://www.faqs.org/rfcs/rfc1738.html) ### Also see wikipedia on file:// (http://en.wikipedia.org/wiki/File://) ### - + sub _file_fetch { my $self = shift; my %hash = @_; @@ -1291,8 +1298,8 @@ sub _file_fetch { }; check( $tmpl, \%hash ) or return; - - + + ### prefix a / on unix systems with a file uri, since it would ### look somewhat like this: ### file:///home/kane/file @@ -1301,23 +1308,23 @@ sub _file_fetch { ### file:///C|/some/dir/file ### or for a network share '\\host\share\some\dir\file': ### file:////host/share/some/dir/file - ### + ### ### VMS file uri's for 'DISK$USER:[MY.NOTES]NOTE123456.TXT' might look like: ### file://vms.host.edu/disk$user/my/notes/note12345.txt ### - + my $path = $self->path; my $vol = $self->vol; my $share = $self->share; my $remote; if (!$share and $self->host) { - return $self->_error(loc( + return $self->_error(loc( "Currently %1 cannot handle hosts in %2 urls", 'File::Fetch', 'file://' - )); + )); } - + if( $vol ) { $path = File::Spec->catdir( split /\//, $path ); $remote = File::Spec->catpath( $vol, $path, $self->file); @@ -1358,42 +1365,41 @@ sub _rsync_fetch { to => { required => 1, store => \$to } }; check( $tmpl, \%hash ) or return; + my $rsync; + unless ( $rsync = can_run('rsync') ) { + $METHOD_FAIL->{'rsync'} = 1; + return; + } - if (my $rsync = can_run('rsync')) { - - my $cmd = [ $rsync ]; + my $cmd = [ $rsync ]; - ### XXX: rsync has no I/O timeouts at all, by default - push(@$cmd, '--timeout=' . $TIMEOUT) if $TIMEOUT; + ### XXX: rsync has no I/O timeouts at all, by default + push(@$cmd, '--timeout=' . $TIMEOUT) if $TIMEOUT; - push(@$cmd, '--quiet') unless $DEBUG; + push(@$cmd, '--quiet') unless $DEBUG; - ### DO NOT quote things for IPC::Run, it breaks stuff. - push @$cmd, $self->uri, $to; + ### DO NOT quote things for IPC::Run, it breaks stuff. + push @$cmd, $self->uri, $to; - ### 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); + ### 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); - my $captured; - unless(run( command => $cmd, - buffer => \$captured, - verbose => $DEBUG ) - ) { + my $captured; + unless(run( command => $cmd, + buffer => \$captured, + verbose => $DEBUG ) + ) { - return $self->_error(loc("Command %1 failed: %2", - "@$cmd" || '', $captured || '')); - } + return $self->_error(loc("Command %1 failed: %2", + "@$cmd" || '', $captured || '')); + } - return $to; + return $to; - } else { - $METHOD_FAIL->{'rsync'} = 1; - return; - } } ################################# @@ -1415,10 +1421,10 @@ Pass it a true value to get the C<Carp::longmess()> output instead. sub _error { my $self = shift; my $error = shift; - + $self->_error_msg( $error ); $self->_error_msg_long( Carp::longmess($error) ); - + if( $WARN ) { carp $DEBUG ? $self->_error_msg_long : $self->_error_msg; } @@ -1458,7 +1464,7 @@ 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 +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 @@ -1597,19 +1603,19 @@ 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 'successful' fetch and a custom error page. -Therefor, we recommend to only use C<lynx> as a last resort. This is +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. =head2 Files I'm trying to fetch have reserved characters or non-ASCII characters in them. What do I do? -C<File::Fetch> is relatively smart about things. When trying to write -a file to disk, it removes the C<query parameters> (see the +C<File::Fetch> is relatively smart about things. When trying to write +a file to disk, it removes the C<query parameters> (see the C<output_file> method for details) from the file name before creating it. In most cases this suffices. -If you have any other characters you need to escape, please install +If you have any other characters you need to escape, please install the C<URI::Escape> module from CPAN, and pre-encode your URI before -passing it to C<File::Fetch>. You can read about the details of URIs +passing it to C<File::Fetch>. You can read about the details of URIs and URI encoding here: http://www.faqs.org/rfcs/rfc2396.html @@ -1634,7 +1640,7 @@ This module by Jos Boumans E<lt>kane@cpan.orgE<gt>. =head1 COPYRIGHT -This library is free software; you may redistribute and/or modify it +This library is free software; you may redistribute and/or modify it under the same terms as Perl itself. diff --git a/Master/tlpkg/tlperl/lib/File/Find.pm b/Master/tlpkg/tlperl/lib/File/Find.pm index f2fe20b3327..d1dbc522584 100644 --- a/Master/tlpkg/tlperl/lib/File/Find.pm +++ b/Master/tlpkg/tlperl/lib/File/Find.pm @@ -3,7 +3,7 @@ use 5.006; use strict; use warnings; use warnings::register; -our $VERSION = '1.20'; +our $VERSION = '1.23'; require Exporter; require Cwd; @@ -280,6 +280,14 @@ links that don't resolve: -l && !-e && print "bogus link: $File::Find::name\n"; } +Note that you may mix directories and (non-directory) files in the list of +directories to be searched by the C<wanted()> function. + + find(\&wanted, "./foo", "./bar", "./baz/epsilon"); + +In the example above, no file in F<./baz/> other than F<./baz/epsilon> will be +evaluated by C<wanted()>. + See also the script C<pfind> on CPAN for a nice application of this module. @@ -515,6 +523,7 @@ sub _find_opt { Proc_Top_Item: foreach my $TOP (@_) { my $top_item = $TOP; + $top_item = VMS::Filespec::unixify($top_item) if $Is_VMS; ($topdev,$topino,$topmode,$topnlink) = $follow ? stat $top_item : lstat $top_item; @@ -1095,8 +1104,7 @@ $File::Find::current_dir = File::Spec->curdir || '.'; $File::Find::dont_use_nlink = 1 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'; + $^O eq 'interix' || $^O eq 'cygwin' || $^O eq 'qnx' || $^O eq 'nto'; # Set dont_use_nlink in your hint file if your system's stat doesn't # report the number of links in a directory as an indication diff --git a/Master/tlpkg/tlperl/lib/File/Glob.pm b/Master/tlpkg/tlperl/lib/File/Glob.pm index cd15922f32e..f144b5179dc 100644 --- a/Master/tlpkg/tlperl/lib/File/Glob.pm +++ b/Master/tlpkg/tlperl/lib/File/Glob.pm @@ -4,7 +4,6 @@ use strict; our($VERSION, @ISA, @EXPORT_OK, @EXPORT_FAIL, %EXPORT_TAGS, $DEFAULT_FLAGS); require XSLoader; -use feature 'switch'; @ISA = qw(Exporter); @@ -38,26 +37,31 @@ pop @{$EXPORT_TAGS{bsd_glob}}; # no "glob" @EXPORT_OK = (@{$EXPORT_TAGS{'glob'}}, 'csh_glob'); -$VERSION = '1.17'; +$VERSION = '1.20_01'; sub import { require Exporter; 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; - } - if ($_ eq ':bsd_glob') { - no strict; *{caller."::glob"} = \&bsd_glob_override; - } - $passthrough = 1; + my $passthrough; + if ($_ eq ':case') { + $DEFAULT_FLAGS &= ~GLOB_NOCASE() + } + elsif ($_ eq ':nocase') { + $DEFAULT_FLAGS |= GLOB_NOCASE(); + } + elsif ($_ eq ':globally') { + no warnings 'redefine'; + *CORE::GLOBAL::glob = \&File::Glob::csh_glob; } - $passthrough; + elsif ($_ eq ':bsd_glob') { + no strict; *{caller."::glob"} = \&bsd_glob_override; + $passthrough = 1; + } + else { + $passthrough = 1; + } + $passthrough; } @_); } @@ -71,7 +75,7 @@ if ($^O =~ /^(?:MSWin32|VMS|os2|dos|riscos)$/) { # File::Glob::glob() is deprecated because its prototype is different from # CORE::glob() (use bsd_glob() instead) sub glob { - splice @_, 1; # don't pass PL_glob_index as flags! + splice @_, 1; # no flags goto &bsd_glob; } diff --git a/Master/tlpkg/tlperl/lib/File/Path.pm b/Master/tlpkg/tlperl/lib/File/Path.pm index 5a9a88e4020..23751d5fa0a 100644 --- a/Master/tlpkg/tlperl/lib/File/Path.pm +++ b/Master/tlpkg/tlperl/lib/File/Path.pm @@ -17,7 +17,7 @@ BEGIN { use Exporter (); use vars qw($VERSION @ISA @EXPORT @EXPORT_OK); -$VERSION = '2.08_01'; +$VERSION = '2.09'; @ISA = qw(Exporter); @EXPORT = qw(mkpath rmtree); @EXPORT_OK = qw(make_path remove_tree); @@ -455,8 +455,8 @@ File::Path - Create or remove directory trees =head1 VERSION -This document describes version 2.08 of File::Path, released -2009-10-04. +This document describes version 2.09 of File::Path, released +2013-01-17. =head1 SYNOPSIS @@ -953,6 +953,10 @@ Please report all bugs on the RT queue: L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=File-Path> +You can also send pull requests to the Github repository: + +L<https://github.com/dland/File-Path> + =head1 ACKNOWLEDGEMENTS Paul Szabo identified the race condition originally, and Brendan @@ -971,7 +975,7 @@ Tim Bunce and Charles Bailey. Currently maintained by David Landgren =head1 COPYRIGHT This module is copyright (C) Charles Bailey, Tim Bunce and -David Landgren 1995-2009. All rights reserved. +David Landgren 1995-2013. All rights reserved. =head1 LICENSE diff --git a/Master/tlpkg/tlperl/lib/File/Spec.pm b/Master/tlpkg/tlperl/lib/File/Spec.pm index 782e28425b7..6062c015179 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.39_02'; +$VERSION = '3.40'; $VERSION =~ tr/_//; my %module = (MacOS => 'Mac', @@ -331,7 +331,7 @@ splitpath(), splitdir(), catpath() and catdir() by Barrie Slaymaker. =head1 COPYRIGHT -Copyright (c) 2004-2010 by the Perl 5 Porters. All rights reserved. +Copyright (c) 2004-2013 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 b63b85f6cda..b27f7b15f19 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.39_02'; +$VERSION = '3.40'; $VERSION =~ tr/_//; @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 50304ffed06..e7faa16086a 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.39_02'; +$VERSION = '3.40'; $VERSION =~ tr/_//; 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 454a5b30898..f5b9046aa5e 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.39_02'; +$VERSION = '3.40'; $VERSION =~ tr/_//; require Exporter; diff --git a/Master/tlpkg/tlperl/lib/File/Spec/Mac.pm b/Master/tlpkg/tlperl/lib/File/Spec/Mac.pm index 57d1d3efb33..7f42171bc92 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.39_02'; +$VERSION = '3.40'; $VERSION =~ tr/_//; @ISA = qw(File::Spec::Unix); diff --git a/Master/tlpkg/tlperl/lib/File/Spec/OS2.pm b/Master/tlpkg/tlperl/lib/File/Spec/OS2.pm index 5461cf7a701..7f60d68927a 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.39_02'; +$VERSION = '3.40'; $VERSION =~ tr/_//; @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 c150445d776..a1a91b42607 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.39_02'; +$VERSION = '3.40'; $VERSION =~ tr/_//; =head1 NAME @@ -352,9 +352,11 @@ directories. If $path is relative, it is converted to absolute form using L</rel2abs()>. This means that it is taken to be relative to L<cwd()|Cwd>. -No checks against the filesystem are made. On VMS, there is -interaction with the working environment, as logicals and -macros are expanded. +No checks against the filesystem are made, so the result may not be correct if +C<$base> contains symbolic links. (Apply +L<Cwd::abs_path()|Cwd/abs_path> beforehand if that +is a concern.) On VMS, there is interaction with the working environment, as +logicals and macros are expanded. Based on code written by Shigio Yamaguchi. @@ -366,28 +368,32 @@ sub abs2rel { ($path, $base) = map $self->canonpath($_), $path, $base; + my $path_directories; + my $base_directories; + if (grep $self->file_name_is_absolute($_), $path, $base) { ($path, $base) = map $self->rel2abs($_), $path, $base; - } - else { - # save a couple of cwd()s if both paths are relative - ($path, $base) = map $self->catdir('/', $_), $path, $base; - } - my ($path_volume) = $self->splitpath($path, 1); - my ($base_volume) = $self->splitpath($base, 1); + my ($path_volume) = $self->splitpath($path, 1); + my ($base_volume) = $self->splitpath($base, 1); - # Can't relativize across volumes - return $path unless $path_volume eq $base_volume; + # Can't relativize across volumes + return $path unless $path_volume eq $base_volume; - my $path_directories = ($self->splitpath($path, 1))[1]; - my $base_directories = ($self->splitpath($base, 1))[1]; + $path_directories = ($self->splitpath($path, 1))[1]; + $base_directories = ($self->splitpath($base, 1))[1]; - # For UNC paths, the user might give a volume like //foo/bar that - # strictly speaking has no directory portion. Treat it as if it - # had the root directory for that volume. - if (!length($base_directories) and $self->file_name_is_absolute($base)) { - $base_directories = $self->rootdir; + # For UNC paths, the user might give a volume like //foo/bar that + # strictly speaking has no directory portion. Treat it as if it + # had the root directory for that volume. + if (!length($base_directories) and $self->file_name_is_absolute($base)) { + $base_directories = $self->rootdir; + } + } + else { + my $wd= ($self->splitpath($self->_cwd(), 1))[1]; + $path_directories = $self->catdir($wd, $path); + $base_directories = $self->catdir($wd, $base); } # Now, remove all leading components that are the same @@ -395,19 +401,39 @@ sub abs2rel { my @basechunks = $self->splitdir( $base_directories ); if ($base_directories eq $self->rootdir) { + return $self->curdir if $path_directories eq $self->rootdir; shift @pathchunks; return $self->canonpath( $self->catpath('', $self->catdir( @pathchunks ), '') ); } + my @common; while (@pathchunks && @basechunks && $self->_same($pathchunks[0], $basechunks[0])) { - shift @pathchunks ; + push @common, shift @pathchunks ; shift @basechunks ; } return $self->curdir unless @pathchunks || @basechunks; - # $base now contains the directories the resulting relative path - # must ascend out of before it can descend to $path_directory. - my $result_dirs = $self->catdir( ($self->updir) x @basechunks, @pathchunks ); + # @basechunks now contains the directories the resulting relative path + # must ascend out of before it can descend to $path_directory. If there + # are updir components, we must descend into the corresponding directories + # (this only works if they are no symlinks). + my @reverse_base; + while( defined(my $dir= shift @basechunks) ) { + if( $dir ne $self->updir ) { + unshift @reverse_base, $self->updir; + push @common, $dir; + } + elsif( @common ) { + if( @reverse_base && $reverse_base[0] eq $self->updir ) { + shift @reverse_base; + pop @common; + } + else { + unshift @reverse_base, pop @common; + } + } + } + my $result_dirs = $self->catdir( @reverse_base, @pathchunks ); return $self->canonpath( $self->catpath('', $result_dirs, '') ); } @@ -473,6 +499,8 @@ Copyright (c) 2004 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. +Please submit bug reports and patches to perlbug@perl.org. + =head1 SEE ALSO L<File::Spec> diff --git a/Master/tlpkg/tlperl/lib/File/Spec/VMS.pm b/Master/tlpkg/tlperl/lib/File/Spec/VMS.pm index 1ababbf1350..6af1ac0b3d1 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.39_02'; +$VERSION = '3.40'; $VERSION =~ tr/_//; @ISA = qw(File::Spec::Unix); diff --git a/Master/tlpkg/tlperl/lib/File/Spec/Win32.pm b/Master/tlpkg/tlperl/lib/File/Spec/Win32.pm index 39f5a8bb95a..ae74a265931 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.39_02'; +$VERSION = '3.40'; $VERSION =~ tr/_//; @ISA = qw(File::Spec::Unix); diff --git a/Master/tlpkg/tlperl/lib/File/Temp.pm b/Master/tlpkg/tlperl/lib/File/Temp.pm index a2d4ae0759f..ac57c260c8f 100644 --- a/Master/tlpkg/tlperl/lib/File/Temp.pm +++ b/Master/tlpkg/tlperl/lib/File/Temp.pm @@ -30,8 +30,9 @@ C<_can_unlink_opened_file> method should be modified. Are the return values from C<stat> reliable? By default all the return values from C<stat> are compared when unlinking a temporary file using the filename and the handle. Operating systems other than -unix do not always have valid entries in all fields. If C<unlink0> fails -then the C<stat> comparison should be modified accordingly. +unix do not always have valid entries in all fields. If utility function +C<File::Temp::unlink0> fails then the C<stat> comparison should be +modified accordingly. =item * @@ -142,10 +143,12 @@ use 5.004; use strict; use Carp; use File::Spec 0.8; +use Cwd (); use File::Path qw/ rmtree /; use Fcntl 1.03; use IO::Seekable; # For SEEK_* use Errno; +use Scalar::Util 'refaddr'; require VMS::Stdio if $^O eq 'VMS'; # pre-emptively load Carp::Heavy. If we don't when we run out of file @@ -160,7 +163,8 @@ require Symbol if $] < 5.006; ### For the OO interface use base qw/ IO::Handle IO::Seekable /; -use overload '""' => "STRINGIFY", fallback => 1; +use overload '""' => "STRINGIFY", '0+' => "NUMIFY", + fallback => 1; # use 'our' on v5.6.0 use vars qw($VERSION @EXPORT_OK %EXPORT_TAGS $DEBUG $KEEP_ALL); @@ -203,7 +207,7 @@ Exporter::export_tags('POSIX','mktemp','seekable'); # Version number -$VERSION = '0.22'; +$VERSION = '0.23'; # This is a list of characters that can be used in random filenames @@ -635,7 +639,7 @@ sub _replace_XX { } # Internal routine to force a temp file to be writable after -# it is created so that we can unlink it. Windows seems to occassionally +# it is created so that we can unlink it. Windows seems to occasionally # force a file to be readonly when written to certain temp locations sub _force_writable { my $file = shift; @@ -750,7 +754,7 @@ sub _is_verysafe { } # To reach this point either, the _PC_CHOWN_RESTRICTED symbol - # was not avialable or the symbol was there but chown giveaway + # was not available or the symbol was there but chown giveaway # is allowed. Either way, we now have to test the entire tree for # safety. @@ -800,7 +804,7 @@ sub _is_verysafe { sub _can_unlink_opened_file { - if ($^O eq 'MSWin32' || $^O eq 'os2' || $^O eq 'VMS' || $^O eq 'dos' || $^O eq 'MacOS') { + if (grep { $^O eq $_ } qw/MSWin32 os2 VMS dos MacOS haiku/) { return 0; } else { return 1; @@ -841,7 +845,7 @@ sub _can_do_level { # Arguments: # _deferred_unlink( $fh, $fname, $isdir ); # -# - filehandle (so that it can be expclicitly closed if open +# - filehandle (so that it can be explicitly closed if open # - filename (the thing we want to remove) # - isdir (flag to indicate that we are being given a directory) # [and hence no filehandle] @@ -868,12 +872,17 @@ sub _can_do_level { # Set up an end block to use these arrays END { local($., $@, $!, $^E, $?); - cleanup(); + cleanup(at_exit => 1); } - # Cleanup function. Always triggered on END but can be invoked - # manually. + # Cleanup function. Always triggered on END (with at_exit => 1) but + # can be invoked manually. sub cleanup { + my %h = @_; + my $at_exit = delete $h{at_exit}; + $at_exit = 0 if not defined $at_exit; + { my @k = sort keys %h; die "unrecognized parameters: @k" if @k } + if (!$KEEP_ALL) { # Files my @files = (exists $files_to_unlink{$$} ? @@ -893,17 +902,37 @@ sub _can_do_level { # Dirs my @dirs = (exists $dirs_to_unlink{$$} ? @{ $dirs_to_unlink{$$} } : () ); + my ($cwd, $cwd_to_remove); foreach my $dir (@dirs) { if (-d $dir) { # Some versions of rmtree will abort if you attempt to remove - # the directory you are sitting in. We protect that and turn it - # into a warning. We do this because this occurs during - # cleanup and so can not be caught by the user. + # the directory you are sitting in. For automatic cleanup + # at program exit, we avoid this by chdir()ing out of the way + # first. If not at program exit, it's best not to mess with the + # current directory, so just let it fail with a warning. + if ($at_exit) { + $cwd = Cwd::abs_path(File::Spec->curdir) if not defined $cwd; + my $abs = Cwd::abs_path($dir); + if ($abs eq $cwd) { + $cwd_to_remove = $dir; + next; + } + } eval { rmtree($dir, $DEBUG, 0); }; warn $@ if ($@ && $^W); } } + if (defined $cwd_to_remove) { + # We do need to clean up the current directory, and everything + # else is done, so get out of there and remove it. + chdir $cwd_to_remove or die "cannot chdir to $cwd_to_remove: $!"; + my $updir = File::Spec->updir; + chdir $updir or die "cannot chdir to $updir: $!"; + eval { rmtree($cwd_to_remove, $DEBUG, 0); }; + warn $@ if ($@ && $^W); + } + # clear the arrays @{ $files_to_unlink{$$} } = () if exists $files_to_unlink{$$}; @@ -928,6 +957,12 @@ sub _can_do_level { warn "Setting up deferred removal of $fname\n" if $DEBUG; + # make sure we save the absolute path for later cleanup + # OK to untaint because we only ever use this internally + # as a file path, never interpolating into the shell + $fname = Cwd::abs_path($fname); + ($fname) = $fname =~ /^(.*)$/; + # If we have a directory, check that it is a directory if ($isdir) { @@ -964,6 +999,24 @@ sub _can_do_level { } +# normalize argument keys to upper case and do consistent handling +# of leading template vs TEMPLATE +sub _parse_args { + my $leading_template = (scalar(@_) % 2 == 1 ? shift(@_) : '' ); + my %args = @_; + %args = map { uc($_), $args{$_} } keys %args; + + # template (store it in an array so that it will + # disappear from the arg list of tempfile) + my @template = ( + exists $args{TEMPLATE} ? $args{TEMPLATE} : + $leading_template ? $leading_template : () + ); + delete $args{TEMPLATE}; + + return( \@template, \%args ); +} + =head1 OBJECT-ORIENTED INTERFACE This is the primary interface for interacting with @@ -972,12 +1025,18 @@ when the object is constructed and the file can be removed when the object is no longer required. Note that there is no method to obtain the filehandle from the -C<File::Temp> object. The object itself acts as a filehandle. Also, -the object is configured such that it stringifies to the name of the -temporary file, and can be compared to a filename directly. The object +C<File::Temp> object. The object itself acts as a filehandle. The object isa C<IO::Handle> and isa C<IO::Seekable> so all those methods are available. +Also, the object is configured such that it stringifies to the name of the +temporary file and so can be compared to a filename directly. It numifies +to the C<refaddr> the same as other handles and so can be compared to other +handles with C<==>. + + $fh eq $filename # as a string + $fh != \*STDOUT # as a number + =over 4 =item B<new> @@ -1010,24 +1069,17 @@ sub new { my $proto = shift; my $class = ref($proto) || $proto; - # read arguments and convert keys to upper case - my %args = @_; - %args = map { uc($_), $args{$_} } keys %args; + my ($maybe_template, $args) = _parse_args(@_); # see if they are unlinking (defaulting to yes) - my $unlink = (exists $args{UNLINK} ? $args{UNLINK} : 1 ); - delete $args{UNLINK}; - - # template (store it in an array so that it will - # disappear from the arg list of tempfile) - my @template = ( exists $args{TEMPLATE} ? $args{TEMPLATE} : () ); - delete $args{TEMPLATE}; + my $unlink = (exists $args->{UNLINK} ? $args->{UNLINK} : 1 ); + delete $args->{UNLINK}; # Protect OPEN - delete $args{OPEN}; + delete $args->{OPEN}; # Open the file and retain file handle and file name - my ($fh, $path) = tempfile( @template, %args ); + my ($fh, $path) = tempfile( @$maybe_template, %$args ); print "Tmp: $fh - $path\n" if $DEBUG; @@ -1038,7 +1090,7 @@ sub new { $FILES_CREATED_BY_OBJECT{$$}{$path} = 1; # Store unlink information in hash slot (plus other constructor info) - %{*$fh} = %args; + %{*$fh} = %$args; # create the object bless $fh, $class; @@ -1062,26 +1114,29 @@ created with this method default to CLEANUP => 1. $dir = File::Temp->newdir( $template, %options ); +A template may be specified either with a leading template or +with a TEMPLATE argument. + =cut sub newdir { my $self = shift; - # need to handle args as in tempdir because we have to force CLEANUP - # default without passing CLEANUP to tempdir - my $template = (scalar(@_) % 2 == 1 ? shift(@_) : undef ); - my %options = @_; - my $cleanup = (exists $options{CLEANUP} ? $options{CLEANUP} : 1 ); + my ($maybe_template, $args) = _parse_args(@_); - delete $options{CLEANUP}; + # handle CLEANUP without passing CLEANUP to tempdir + my $cleanup = (exists $args->{CLEANUP} ? $args->{CLEANUP} : 1 ); + delete $args->{CLEANUP}; + + my $tempdir = tempdir( @$maybe_template, %$args); + + # get a safe absolute path for cleanup, just like + # happens in _deferred_unlink + my $real_dir = Cwd::abs_path( $tempdir ); + ($real_dir) = $real_dir =~ /^(.*)$/; - my $tempdir; - if (defined $template) { - $tempdir = tempdir( $template, %options ); - } else { - $tempdir = tempdir( %options ); - } return bless { DIRNAME => $tempdir, + REALNAME => $real_dir, CLEANUP => $cleanup, LAUNCHPID => $$, }, "File::Temp::Dir"; @@ -1109,6 +1164,13 @@ sub STRINGIFY { return $self->filename; } +# For reference, can't use '0+'=>\&Scalar::Util::refaddr directly because +# refaddr() demands one parameter only, whereas overload.pm calls with three +# even for unary operations like '0+'. +sub NUMIFY { + return refaddr($_[0]); +} + =item B<dirname> Return the name of the temporary directory associated with this @@ -1140,7 +1202,7 @@ sub unlink_on_destroy { =item B<DESTROY> When the object goes out of scope, the destructor is called. This -destructor will attempt to unlink the file (using C<unlink1>) +destructor will attempt to unlink the file (using L<unlink1|"unlink1">) if the constructor was called with UNLINK set to 1 (the default state if UNLINK is not specified). @@ -1149,9 +1211,12 @@ No error is given if the unlink fails. If the object has been passed to a child process during a fork, the file will be deleted when the object goes out of scope in the parent. -For a temporary directory object the directory will be removed -unless the CLEANUP argument was used in the constructor (and set to -false) or C<unlink_on_destroy> was modified after creation. +For a temporary directory object the directory will be removed unless +the CLEANUP argument was used in the constructor (and set to false) or +C<unlink_on_destroy> was modified after creation. Note that if a temp +directory is your current directory, it cannot be removed - a warning +will be given in this case. C<chdir()> out of the directory before +letting the object go out of scope. If the global variable $KEEP_ALL is true, the file or directory will not be removed. @@ -1293,7 +1358,9 @@ Will croak() if there is an error. =cut sub tempfile { - + if ( @_ && $_[0] eq 'File::Temp' ) { + croak "'tempfile' can't be called as a method"; + } # Can not check for argument count since we can have any # number of args @@ -1308,10 +1375,11 @@ sub tempfile { ); # Check to see whether we have an odd or even number of arguments - my $template = (scalar(@_) % 2 == 1 ? shift(@_) : undef); + my ($maybe_template, $args) = _parse_args(@_); + my $template = @$maybe_template ? $maybe_template->[0] : undef; # Read the options and merge with defaults - %options = (%options, @_) if @_; + %options = (%options, %$args); # First decision is whether or not to open the file if (! $options{"OPEN"}) { @@ -1378,7 +1446,7 @@ sub tempfile { # Create the file my ($fh, $path, $errstr); - croak "Error in tempfile() using $template: $errstr" + croak "Error in tempfile() using template $template: $errstr" unless (($fh, $path) = _gettemp($template, "open" => $options{'OPEN'}, "mkdir"=> 0 , @@ -1484,6 +1552,9 @@ Will croak() if there is an error. # ' sub tempdir { + if ( @_ && $_[0] eq 'File::Temp' ) { + croak "'tempdir' can't be called as a method"; + } # Can not check for argument count since we can have any # number of args @@ -1496,10 +1567,11 @@ sub tempdir { ); # Check to see whether we have an odd or even number of arguments - my $template = (scalar(@_) % 2 == 1 ? shift(@_) : undef ); + my ($maybe_template, $args) = _parse_args(@_); + my $template = @$maybe_template ? $maybe_template->[0] : undef; # Read the options and merge with defaults - %options = (%options, @_) if @_; + %options = (%options, %$args); # Modify or generate the template @@ -1976,15 +2048,14 @@ sub unlink0 { # Make sure that the link count is zero # - Cygwin provides deferred unlinking, however, # on Win9x the link count remains 1 - # On NFS the link count may still be 1 but we cant know that - # we are on NFS - return ( $fh[3] == 0 or $^O eq 'cygwin' ? 1 : 0); + # On NFS the link count may still be 1 but we can't know that + # we are on NFS. Since we can't be sure, we'll defer it - } else { - _deferred_unlink($fh, $path, 0); - return 1; + return 1 if $fh[3] == 0 || $^O eq 'cygwin'; } - + # fall-through if we can't unlink now + _deferred_unlink($fh, $path, 0); + return 1; } =item B<cmpstat> @@ -2135,6 +2206,11 @@ when the process exits but can be triggered manually if the caller is sure that none of the temp files are required. This method can be registered as an Apache callback. +Note that if a temp directory is your current directory, it cannot be +removed. C<chdir()> out of the directory first before calling +C<cleanup()>. (For the cleanup at program exit when the CLEANUP flag +is set, this happens automatically.) + On OSes where temp files are automatically removed when the temp file is closed, calling this function will have no effect other than to remove temporary directories (which may include temporary files). @@ -2230,7 +2306,7 @@ simply examine the return value of C<safe_level>. if (($level != STANDARD) && ($level != MEDIUM) && ($level != HIGH)) { carp "safe_level: Specified level ($level) not STANDARD, MEDIUM or HIGH - ignoring\n" if $^W; } else { - # Dont allow this on perl 5.005 or earlier + # Don't allow this on perl 5.005 or earlier if ($] < 5.006 && $level != STANDARD) { # Cant do MEDIUM or HIGH checks croak "Currently requires perl 5.006 or newer to do the safe checks"; @@ -2316,10 +2392,12 @@ conditions. It's far more secure to use the filehandle alone and dispense with the filename altogether. If you need to pass the handle to something that expects a filename -then, on a unix system, use C<"/dev/fd/" . fileno($fh)> for arbitrary -programs, or more generally C<< "+<=&" . fileno($fh) >> for Perl -programs. You will have to clear the close-on-exec bit on that file -descriptor before passing it to another process. +then on a unix system you can use C<"/dev/fd/" . fileno($fh)> for +arbitrary programs. Perl code that uses the 2-argument version of +C<< open >> can be passed C<< "+<=&" . fileno($fh) >>. Otherwise you +will need to pass the filename. You will have to clear the +close-on-exec bit on that file descriptor before passing it to another +process. use Fcntl qw/F_SETFD F_GETFD/; fcntl($tmpfh, F_SETFD, 0) @@ -2355,6 +2433,11 @@ Note that if you have chdir'ed into the temporary directory and it is subsequently cleaned up (either in the END block or as part of object destruction), then you will get a warning from File::Path::rmtree(). +=head2 Taint mode + +If you need to run code under taint mode, updating to the latest +L<File::Spec> is highly recommended. + =head2 BINMODE The file returned by File::Temp will have been opened in binary mode @@ -2387,7 +2470,7 @@ the C<tempdir> function. Tim Jenness E<lt>tjenness@cpan.orgE<gt> -Copyright (C) 2007-2009 Tim Jenness. +Copyright (C) 2007-2010 Tim Jenness. Copyright (C) 1999-2007 Tim Jenness and the UK Particle Physics and Astronomy Research Council. All Rights Reserved. This program is free software; you can redistribute it and/or modify it under the same @@ -2404,7 +2487,9 @@ package File::Temp::Dir; use File::Path qw/ rmtree /; use strict; -use overload '""' => "STRINGIFY", fallback => 1; +use overload '""' => "STRINGIFY", + '0+' => \&File::Temp::NUMIFY, + fallback => 1; # private class specifically to support tempdir objects # created by File::Temp->newdir @@ -2437,12 +2522,12 @@ sub DESTROY { local($., $@, $!, $^E, $?); if ($self->unlink_on_destroy && $$ == $self->{LAUNCHPID} && !$File::Temp::KEEP_ALL) { - if (-d $self->{DIRNAME}) { + if (-d $self->{REALNAME}) { # Some versions of rmtree will abort if you attempt to remove # the directory you are sitting in. We protect that and turn it # into a warning. We do this because this occurs during object # destruction and so can not be caught by the user. - eval { rmtree($self->{DIRNAME}, $File::Temp::DEBUG, 0); }; + eval { rmtree($self->{REALNAME}, $File::Temp::DEBUG, 0); }; warn $@ if ($@ && $^W); } } @@ -2450,3 +2535,5 @@ sub DESTROY { 1; + +# vim: ts=2 sts=2 sw=2 et: diff --git a/Master/tlpkg/tlperl/lib/File/stat.pm b/Master/tlpkg/tlperl/lib/File/stat.pm index 69cc44af1d9..b631fbf8752 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.05'; +our $VERSION = '1.07'; my @fields; BEGIN { @@ -37,10 +37,14 @@ BEGIN { my $val = eval { &{"Fcntl::S_I\U$_"} }; *{"_$_"} = defined $val ? sub { $_[0] & $val ? 1 : "" } : sub { "" }; } - for (qw(SOCK CHR BLK REG DIR FIFO LNK)) { + for (qw(SOCK CHR BLK REG DIR LNK)) { *{"S_IS$_"} = defined eval { &{"Fcntl::S_IF$_"} } ? \&{"Fcntl::S_IS$_"} : sub { "" }; } + # FIFO flag and macro don't quite follow the S_IF/S_IS pattern above + # RT #111638 + *{"S_ISFIFO"} = defined &Fcntl::S_IFIFO + ? \&Fcntl::S_ISFIFO : sub { "" }; } # from doio.c @@ -83,15 +87,22 @@ else { *cando = sub { my ($s, $mode, $eff) = @_; my $uid = $eff ? $> : $<; - - # 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]; # This code basically assumes that the rwx bits of the mode are # the 0777 bits, but so does Perl_cando. + + if ($uid == 0 && $^O ne "VMS") { + # If we're root on unix + # not testing for executable status => all file tests are true + return 1 if !($mode & 0111); + # testing for executable status => + # for a file, any x bit will do + # for a directory, always true + return 1 if $stmode & 0111 || S_ISDIR($stmode); + return ""; + } + if ($stuid == $uid) { $stmode & $mode and return 1; } @@ -148,7 +159,7 @@ use overload -X => sub { my ($s, $op) = @_; - if (index "rwxRWX", $op) { + if (index("rwxRWX", $op) >= 0) { (caller 0)[8] & HINT_FILETEST_ACCESS and warnif("File::stat ignores use filetest 'access'"); |