summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/File/Fetch.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/File/Fetch.pm')
-rw-r--r--Master/tlpkg/tlperl/lib/File/Fetch.pm210
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.