use strict;
use FileHandle;
+use File::Temp;
use File::Copy;
use File::Spec;
use File::Spec::Unix;
use constant QUOTE => do { $^O eq 'MSWin32' ? q["] : q['] };
-$VERSION = '0.14';
+$VERSION = '0.16';
$VERSION = eval $VERSION; # avoid warnings with development releases
$PREFER_BIN = 0; # XXX TODO implement
$FROM_EMAIL = 'File-Fetch@example.com';
### methods available to fetch the file depending on the scheme
$METHODS = {
- http => [ qw|lwp wget curl lynx| ],
- ftp => [ qw|lwp netftp wget curl ncftp ftp| ],
- file => [ qw|lwp file| ],
+ http => [ qw|lwp wget curl lftp lynx| ],
+ ftp => [ qw|lwp netftp wget curl lftp ncftp ftp| ],
+ file => [ qw|lwp lftp file| ],
rsync => [ qw|rsync| ]
};
push @$cmd, '--passive-ftp' if $FTP_PASSIVE;
### set the output document, add the uri ###
- push @$cmd, '--output-document',
- ### 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);
+ push @$cmd, '--output-document', $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;
}
}
+### /bin/lftp fetch ###
+sub _lftp_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( my $lftp = can_run('lftp') ) {
+
+ ### 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;
+
+ ### run passive if specified ###
+ $str .= "set ftp:passive-mode 1;\n" if $FTP_PASSIVE;
+
+ ### 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( $DEBUG ) {
+ my $pp_str = join ' ', split $/, $str;
+ print "# lftp command: $pp_str\n";
+ }
+
+ ### 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;
+
+ ### 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->{'lftp'} = 1;
+ return;
+ }
+}
+
+
### /bin/ftp fetch ###
sub _ftp_fetch {
'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 || ''));
+ }
+
+ unless($head =~ /^HTTP\/\d+\.\d+ 200\b/) {
+ return $self->_error(loc("Command failed: %1", $head || ''));
+ }
+ }
+
### write to the output file ourselves, since lynx ass_u_mes to much
my $local = FileHandle->new(">$to")
or return $self->_error(loc(
push @$cmd, "-connect_timeout=$TIMEOUT" if $TIMEOUT;
### DO NOT quote things for IPC::Run, it breaks stuff.
- push @$cmd, $IPC::Cmd::USE_IPC_RUN
- ? $self->uri
- : QUOTE. $self->uri .QUOTE;
+ 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 ###
if (my $curl = can_run('curl')) {
### these long opts are self explanatory - I like that -jmb
- my $cmd = [ $curl ];
+ my $cmd = [ $curl, '-q' ];
push(@$cmd, '--connect-timeout', $TIMEOUT) if $TIMEOUT;
### curl doesn't follow 302 (temporarily moved) etc automatically
### so we add --location to enable that.
- push @$cmd, '--fail', '--location', '--output',
- ### 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);
+ 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);
+
my $captured;
unless(run( command => $cmd,
push(@$cmd, '--quiet') unless $DEBUG;
### DO NOT quote things for IPC::Run, it breaks stuff.
- push @$cmd, $IPC::Cmd::USE_IPC_RUN
- ? ($self->uri, $to)
- : (QUOTE. $self->uri .QUOTE, QUOTE. $to .QUOTE);
+ 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);
my $captured;
unless(run( command => $cmd,
Below is a mapping of what utilities will be used in what order
for what schemes, if available:
- file => LWP, file
- http => LWP, wget, curl, lynx
- ftp => LWP, Net::FTP, wget, curl, ncftp, ftp
+ file => LWP, lftp, file
+ http => LWP, wget, curl, lftp, lynx
+ ftp => LWP, Net::FTP, wget, curl, lftp, ncftp, ftp
rsync => rsync
If you'd like to disable the use of one or more of these utilities
ftp => ftp
curl => curl
rsync => rsync
+ lftp => lftp
=head1 FREQUENTLY ASKED QUESTIONS
Some of these tests assume you are connected to the
internet. If you are not, or if certain protocols or hosts
-are blocked and/or firewalled, these tests will fail due
+are blocked and/or firewalled, these tests could fail due
to no fault of the module itself.
###########################################################
my $prefix = &File::Fetch::ON_UNIX ? 'file://' : 'file:///';
my $uri = $prefix . cwd() .'/'. basename($0);
- for (qw[lwp file]) {
+ for (qw[lwp lftp file]) {
_fetch_uri( file => $uri, $_ );
}
}
### ftp:// tests ###
{ my $uri = 'ftp://ftp.funet.fi/pub/CPAN/index.html';
- for (qw[lwp netftp wget curl ncftp]) {
+ for (qw[lwp netftp wget curl lftp ncftp]) {
### STUPID STUPID warnings ###
next if $_ eq 'ncftp' and $File::Fetch::FTP_PASSIVE
### http:// tests ###
{ for my $uri ( 'http://www.cpan.org/index.html',
- 'http://www.cpan.org/index.html?q=1&y=2'
+ 'http://www.cpan.org/index.html?q=1',
+ 'http://www.cpan.org/index.html?q=1&y=2',
) {
- for (qw[lwp wget curl lynx]) {
+ for (qw[lwp wget curl lftp lynx]) {
_fetch_uri( http => $uri, $_ );
}
}
skip "You do not have '$method' installed/available", 3
if $File::Fetch::METHOD_FAIL->{$method} &&
$File::Fetch::METHOD_FAIL->{$method};
+
+ ### if the file wasn't fetched, it may be a network/firewall issue
+ skip "Fetch failed; no network connectivity for '$type'?", 3
+ unless $file;
+
ok( $file, " File ($file) fetched with $method ($uri)" );
ok( $file && -s $file,
" File has size" );
projects / p5sagit/p5-mst-13.2.git / commitdiff