diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/File/Fetch.pm')
-rw-r--r-- | Master/tlpkg/tlperl/lib/File/Fetch.pm | 210 |
1 files changed, 198 insertions, 12 deletions
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. |