This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Fix typos (spelling errors) in cpan/File-Fetch/*.
[perl5.git] / cpan / File-Fetch / lib / File / Fetch.pm
index dfe0484..2223a5e 100644 (file)
@@ -22,7 +22,7 @@ use vars    qw[ $VERBOSE $PREFER_BIN $FROM_EMAIL $USER_AGENT
                 $FTP_PASSIVE $TIMEOUT $DEBUG $WARN
             ];
 
-$VERSION        = '0.21_01';
+$VERSION        = '0.28';
 $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 httplite wget curl lftp fetch 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
 
@@ -178,13 +178,13 @@ result of $ff->output_file will be used.
         bless $args, $class;
     
         if( lc($args->scheme) ne 'file' and not $args->host ) {
-            return File::Fetch->_error(loc(
+            return $class->_error(loc(
                 "Hostname required when fetching from '%1'",$args->scheme));
         }
         
         for (qw[path file]) {
             unless( $args->$_() ) { # 5.5.x needs the ()
-                return File::Fetch->_error(loc("No '%1' specified",$_));
+                return $class->_error(loc("No '%1' specified",$_));
             }
         }
         
@@ -275,10 +275,10 @@ sub new {
     check( $tmpl, \%hash ) or return;
 
     ### parse the uri to usable parts ###
-    my $href    = __PACKAGE__->_parse_uri( $uri ) or return;
+    my $href    = $class->_parse_uri( $uri ) or return;
 
     ### make it into a FFI object ###
-    my $ff      = File::Fetch->_create( %$href ) or return;
+    my $ff      = $class->_create( %$href ) or return;
 
 
     ### return the object ###
@@ -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,85 @@ sub _lwp_fetch {
     }
 }
 
+### 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,7 +698,12 @@ sub _iosock_fetch {
                  "Could not open '%1' for writing: %2",$to,$!));
         }
 
-        $sock->send( "GET $self->path HTTP/1.0\x0d\x0aHost: $self->host\x0d\x0a\x0d\x0a" );
+        $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 );
 
         my $select = IO::Select->new( $sock );
 
@@ -638,7 +722,24 @@ sub _iosock_fetch {
             return $self->_error(loc("Socket timed out after '%1' seconds", ( $TIMEOUT || 60 )));
         }
 
-        print $fh +($resp =~ m/\x0d\x0a\x0d\x0a(.*)$/s )[0];
+        # Check the "response"
+        # 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 ) {
+            return $self->_error(loc("Did not get a HTTP response from '%1'",$self->host));
+        }
+
+        # Check for OK
+        my ($code) = $resp =~ m!^HTTP/\d+\.\d+\s+(\d+)!i;
+        unless ( $code eq '200' ) {
+            return $self->_error(loc("Got a '%1' from '%2' expected '200'",$code,$self->host));
+        }
+
+        {
+          local $\;
+          print $fh +($resp =~ m/\x0d\x0a\x0d\x0a(.*)$/s )[0];
+        }
         close $fh;
         return $to;
 
@@ -986,7 +1087,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;
 
@@ -1079,6 +1180,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 ###
 ###
@@ -1101,7 +1256,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':
@@ -1250,8 +1405,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
@@ -1262,6 +1417,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.
 
@@ -1363,6 +1522,7 @@ 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
     Net::FTP    => netftp
     wget        => wget
     lynx        => lynx
@@ -1371,6 +1531,7 @@ the $BLACKLIST, $METHOD_FAIL and other internal functions.
     curl        => curl
     rsync       => rsync
     lftp        => lftp
+    fetch       => fetch
     IO::Socket  => iosock
 
 =head1 FREQUENTLY ASKED QUESTIONS
@@ -1393,7 +1554,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.