From: Jos I. Boumans <kane@dwim.org>
Date: Fri, 10 Oct 2008 15:14:27 +0000 (+0200)
Subject: Update File::Fetch to 0.16
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=6e654618055194991b39907dc47c36d18381f582;p=p5sagit%2Fp5-mst-13.2.git

Update File::Fetch to 0.16
From: "Jos I. Boumans" <jos@dwim.org>
Message-Id: <84818689-C970-47A1-9FE7-969C2B74183D@dwim.org>

p4raw-id: //depot/perl@34472
---

diff --git a/lib/File/Fetch.pm b/lib/File/Fetch.pm
index 8c8b3f9..4293fb9 100644
--- a/lib/File/Fetch.pm
+++ b/lib/File/Fetch.pm
@@ -2,6 +2,7 @@ package File::Fetch;
 
 use strict;
 use FileHandle;
+use File::Temp;
 use File::Copy;
 use File::Spec;
 use File::Spec::Unix;
@@ -23,7 +24,7 @@ use vars    qw[ $VERBOSE $PREFER_BIN $FROM_EMAIL $USER_AGENT
 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';
@@ -37,9 +38,9 @@ $WARN           = 1;
 
 ### 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| ]
 };
 
@@ -626,11 +627,14 @@ sub _wget_fetch {
         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 +657,81 @@ sub _wget_fetch {
     }
 }
 
+### /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 +796,33 @@ sub _lynx_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(
@@ -732,9 +838,14 @@ sub _lynx_fetch {
         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 +940,7 @@ sub _curl_fetch {
     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 +953,15 @@ sub _curl_fetch {
 
         ### 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 +1075,14 @@ sub _rsync_fetch {
         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 +1150,9 @@ external programs and modules.
 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 +1268,7 @@ the $BLACKLIST, $METHOD_FAIL and other internal functions.
     ftp         => ftp
     curl        => curl
     rsync       => rsync
+    lftp        => lftp
 
 =head1 FREQUENTLY ASKED QUESTIONS
 
diff --git a/lib/File/Fetch/t/01_File-Fetch.t b/lib/File/Fetch/t/01_File-Fetch.t
index 4f814cb..af41f98 100644
--- a/lib/File/Fetch/t/01_File-Fetch.t
+++ b/lib/File/Fetch/t/01_File-Fetch.t
@@ -22,7 +22,7 @@ unless( $ENV{PERL_CORE} ) {
 
 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.
 
 ###########################################################
@@ -148,14 +148,14 @@ for my $entry (@map) {
     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 +167,10 @@ for my $entry (@map) {
 
 ### 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 +207,11 @@ sub _fetch_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" );