File-Fetch-0.18
diff -urN perl-5.10.0.orig/lib/File/Fetch/t/01_File-Fetch.t perl-5.10.0/lib/File/Fetch/t/01_File-Fetch.t
--- perl-5.10.0.orig/lib/File/Fetch/t/01_File-Fetch.t 2007-12-18 11:47:07.000000000 +0100
+++ perl-5.10.0/lib/File/Fetch/t/01_File-Fetch.t 2009-03-10 14:28:48.000000000 +0100
@@ -22,7 +22,7 @@
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.
###########################################################
@@ -115,6 +115,13 @@
) if &File::Fetch::ON_WIN;
+### sanity tests
+{ like( $File::Fetch::USER_AGENT, qr/$File::Fetch::VERSION/,
+ "User agent contains version" );
+ like( $File::Fetch::FROM_EMAIL, qr/@/,
+ q[Email contains '@'] );
+}
+
### parse uri tests ###
for my $entry (@map ) {
my $uri = $entry->{'uri'};
@@ -148,14 +155,14 @@
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
@@ -167,9 +174,10 @@
### 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, $_ );
}
}
@@ -206,6 +214,11 @@
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" );
diff -urN perl-5.10.0.orig/lib/File/Fetch.pm perl-5.10.0/lib/File/Fetch.pm
--- perl-5.10.0.orig/lib/File/Fetch.pm 2007-12-18 11:47:07.000000000 +0100
+++ perl-5.10.0/lib/File/Fetch.pm 2009-03-10 14:29:10.000000000 +0100
@@ -2,6 +2,7 @@
use strict;
use FileHandle;
+use File::Temp;
use File::Copy;
use File::Spec;
use File::Spec::Unix;
@@ -9,7 +10,7 @@
use Cwd qw[cwd];
use Carp qw[carp];
-use IPC::Cmd qw[can_run run];
+use IPC::Cmd qw[can_run run QUOTE];
use File::Path qw[mkpath];
use Params::Check qw[check];
use Module::Load::Conditional qw[can_load];
@@ -20,14 +21,11 @@
$FTP_PASSIVE $TIMEOUT $DEBUG $WARN
];
-use constant QUOTE => do { $^O eq 'MSWin32' ? q["] : q['] };
-
-
-$VERSION = '0.14';
+$VERSION = '0.18';
$VERSION = eval $VERSION; # avoid warnings with development releases
$PREFER_BIN = 0; # XXX TODO implement
$FROM_EMAIL = 'File-Fetch@example.com';
-$USER_AGENT = 'File::Fetch/$VERSION';
+$USER_AGENT = "File::Fetch/$VERSION";
$BLACKLIST = [qw|ftp|];
$METHOD_FAIL = { };
$FTP_PASSIVE = 1;
@@ -37,9 +35,9 @@
### 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| ]
};
@@ -50,11 +48,13 @@
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_UNIX => (!ON_WIN);
-use constant HAS_VOL => (ON_WIN);
-use constant HAS_SHARE => (ON_WIN);
+use constant ON_WIN => ($^O eq 'MSWin32');
+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);
+
+
=pod
=head1 NAME
@@ -146,7 +146,7 @@
##########################
{
- ### template for new() and autogenerated accessors ###
+ ### template for autogenerated accessors ###
my $Tmpl = {
scheme => { default => 'http' },
host => { default => 'localhost' },
@@ -626,11 +626,14 @@
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;
@@ -653,6 +656,81 @@
}
}
+### /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 {
@@ -717,6 +795,33 @@
'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(
@@ -732,9 +837,14 @@
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 ###
@@ -829,7 +939,7 @@
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;
@@ -842,11 +952,15 @@
### 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,
@@ -960,9 +1074,14 @@
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,
@@ -1030,9 +1149,9 @@
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
@@ -1148,6 +1267,7 @@
ftp => ftp
curl => curl
rsync => rsync
+ lftp => lftp
=head1 FREQUENTLY ASKED QUESTIONS