- use a better BuildRoot - drop a redundant mkdir in %%install - call patchlevel.h only once; rm patchlevel.bak - update modules Sys::Syslog, Module::Load::Conditional, Module::CoreList, Test::Harness, Test::Simple, CGI.pm (dropping the upstreamed patch), File::Path (that includes our perl-5.10.0-CVE-2008-2827.patch), constant, Pod::Simple, Archive::Tar, Archive::Extract, File::Fetch, File::Temp, IPC::Cmd, Time::HiRes, Module::Build, ExtUtils::CBuilder - standardize the patches for updating embedded modules - work around a bug in Module::Build tests bu setting TMPDIR to a directory inside the source tree
372 lines
12 KiB
Diff
372 lines
12 KiB
Diff
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
|
|
|