From a304a107e9a9f49c5f7a0af40fd022f98bc96028 Mon Sep 17 00:00:00 2001 From: Chris 'BinGOs' Williams Date: Fri, 11 Jan 2013 08:13:59 +0000 Subject: Update File-Fetch to CPAN version 0.38 [DELTA] Changes for 0.38 Thu Jan 10 20:52:53 2013 ================================================= * Add support for an optional tempdir_root parameter (Kent Fredric) --- cpan/File-Fetch/lib/File/Fetch.pm | 919 +++++++++++++++++++------------------- 1 file changed, 457 insertions(+), 462 deletions(-) (limited to 'cpan/File-Fetch') diff --git a/cpan/File-Fetch/lib/File/Fetch.pm b/cpan/File-Fetch/lib/File/Fetch.pm index 99f1f795fe..37f7bc6ca9 100644 --- a/cpan/File-Fetch/lib/File/Fetch.pm +++ b/cpan/File-Fetch/lib/File/Fetch.pm @@ -22,7 +22,7 @@ use vars qw[ $VERBOSE $PREFER_BIN $FROM_EMAIL $USER_AGENT $FTP_PASSIVE $TIMEOUT $DEBUG $WARN ]; -$VERSION = '0.36'; +$VERSION = '0.38'; $VERSION = eval $VERSION; # avoid warnings with development releases $PREFER_BIN = 0; # XXX TODO implement $FROM_EMAIL = 'File-Fetch@example.com'; @@ -164,6 +164,7 @@ http://www.abc.net.au/ the contents retrieved may be from a remote file called vol => { default => '' }, # windows for file:// uris share => { default => '' }, # windows for file:// uris file_default => { default => 'file_default' }, + tempdir_root => { required => 1 }, # Should be lazy-set at ->new() _error_msg => { no_override => 1 }, _error_msg_long => { no_override => 1 }, }; @@ -277,10 +278,11 @@ sub new { my $class = shift; my %hash = @_; - my ($uri, $file_default); + my ($uri, $file_default, $tempdir_root); my $tmpl = { uri => { required => 1, store => \$uri }, file_default => { required => 0, store => \$file_default }, + tempdir_root => { required => 0, store => \$tempdir_root }, }; check( $tmpl, \%hash ) or return; @@ -289,6 +291,8 @@ sub new { my $href = $class->_parse_uri( $uri ) or return; $href->{file_default} = $file_default if $file_default; + $href->{tempdir_root} = File::Spec->rel2abs( $tempdir_root ) if $tempdir_root; + $href->{tempdir_root} = File::Spec->rel2abs( Cwd::cwd ) if not $href->{tempdir_root}; ### make it into a FFI object ### my $ff = $class->_create( %$href ) or return; @@ -444,7 +448,7 @@ sub fetch { my ($to, $fh); ### you want us to slurp the contents if( ref $target and UNIVERSAL::isa( $target, 'SCALAR' ) ) { - $to = tempdir( 'FileFetch.XXXXXX', CLEANUP => 1 ); + $to = tempdir( 'FileFetch.XXXXXX', DIR => $self->tempdir_root, CLEANUP => 1 ); ### plain old fetch } else { @@ -560,41 +564,40 @@ sub _lwp_fetch { }; - if( can_load(modules => $use_list) ) { - - ### setup the uri object - my $uri = URI->new( File::Spec::Unix->catfile( - $self->path, $self->file - ) ); + unless( can_load( modules => $use_list ) ) { + $METHOD_FAIL->{'lwp'} = 1; + return; + } - ### special rules apply for file:// uris ### - $uri->scheme( $self->scheme ); - $uri->host( $self->scheme eq 'file' ? '' : $self->host ); - $uri->userinfo("anonymous:$FROM_EMAIL") if $self->scheme ne 'file'; + ### setup the uri object + my $uri = URI->new( File::Spec::Unix->catfile( + $self->path, $self->file + ) ); - ### set up the useragent object - my $ua = LWP::UserAgent->new(); - $ua->timeout( $TIMEOUT ) if $TIMEOUT; - $ua->agent( $USER_AGENT ); - $ua->from( $FROM_EMAIL ); - $ua->env_proxy; + ### special rules apply for file:// uris ### + $uri->scheme( $self->scheme ); + $uri->host( $self->scheme eq 'file' ? '' : $self->host ); + $uri->userinfo("anonymous:$FROM_EMAIL") if $self->scheme ne 'file'; - my $res = $ua->mirror($uri, $to) or return; + ### set up the useragent object + my $ua = LWP::UserAgent->new(); + $ua->timeout( $TIMEOUT ) if $TIMEOUT; + $ua->agent( $USER_AGENT ); + $ua->from( $FROM_EMAIL ); + $ua->env_proxy; - ### uptodate or fetched ok ### - if ( $res->code == 304 or $res->code == 200 ) { - return $to; + my $res = $ua->mirror($uri, $to) or return; - } else { - return $self->_error(loc("Fetch failed! HTTP response: %1 %2 [%3]", - $res->code, HTTP::Status::status_message($res->code), - $res->status_line)); - } + ### uptodate or fetched ok ### + if ( $res->code == 304 or $res->code == 200 ) { + return $to; } else { - $METHOD_FAIL->{'lwp'} = 1; - return; + return $self->_error(loc("Fetch failed! HTTP response: %1 %2 [%3]", + $res->code, HTTP::Status::status_message($res->code), + $res->status_line)); } + } ### HTTP::Tiny fetching ### @@ -613,28 +616,26 @@ sub _httptiny_fetch { }; - if( can_load(modules => $use_list) ) { + unless( can_load(modules => $use_list) ) { + $METHOD_FAIL->{'httptiny'} = 1; + return; + } - my $uri = $self->uri; + my $uri = $self->uri; - my $http = HTTP::Tiny->new( ( $TIMEOUT ? ( timeout => $TIMEOUT ) : () ) ); + my $http = HTTP::Tiny->new( ( $TIMEOUT ? ( timeout => $TIMEOUT ) : () ) ); - my $rc = $http->mirror( $uri, $to ); + my $rc = $http->mirror( $uri, $to ); - unless ( $rc->{success} ) { + unless ( $rc->{success} ) { - return $self->_error(loc( "Fetch failed! HTTP response: %1 [%2]", - $rc->{status}, $rc->{reason} ) ); + return $self->_error(loc( "Fetch failed! HTTP response: %1 [%2]", + $rc->{status}, $rc->{reason} ) ); - } + } - return $to; + return $to; - } - else { - $METHOD_FAIL->{'httptiny'} = 1; - return; - } } ### HTTP::Lite fetching ### @@ -654,64 +655,63 @@ sub _httplite_fetch { }; - if( can_load(modules => $use_list) ) { + unless( can_load(modules => $use_list) ) { + $METHOD_FAIL->{'httplite'} = 1; + return; + } - my $uri = $self->uri; - my $retries = 0; + my $uri = $self->uri; + my $retries = 0; - RETRIES: while ( $retries++ < 5 ) { + 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 $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; + my $fh = FileHandle->new; - unless ( $fh->open($to,'>') ) { - return $self->_error(loc( - "Could not open '%1' for writing: %2",$to,$!)); - } + unless ( $fh->open($to,'>') ) { + return $self->_error(loc( + "Could not open '%1' for writing: %2",$to,$!)); + } - $fh->autoflush(1); + $fh->autoflush(1); - binmode $fh; + binmode $fh; - my $rc = $http->request( $uri, sub { my ($self,$dref,$cbargs) = @_; local $\; print {$cbargs} $$dref }, $fh ); + my $rc = $http->request( $uri, sub { my ($self,$dref,$cbargs) = @_; local $\; print {$cbargs} $$dref }, $fh ); - close $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; + if ( $rc == 301 || $rc == 302 ) { + my $loc; + HEADERS: for ($http->headers_array) { + /Location: (\S+)/ and $loc = $1, last HEADERS; } - elsif ( $rc == 200 ) { - return $to; + #$loc or last; # Think we should squeal here. + if ($loc =~ m!^/!) { + $uri =~ s{^(\w+?://[^/]+)/.*$}{$1}; + $uri .= $loc; } else { - return $self->_error(loc("Fetch failed! HTTP response: %1 [%2]", - $rc, $http->status_message)); + $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. + } # Loop for 5 retries. - return $self->_error("Fetch failed! Gave up after 5 tries"); + return $self->_error("Fetch failed! Gave up after 5 tries"); - } else { - $METHOD_FAIL->{'httplite'} = 1; - return; - } } ### Simple IO::Socket::INET fetching ### @@ -730,74 +730,73 @@ sub _iosock_fetch { 'IO::Select' => '0.0', }; - if( can_load(modules => $use_list) ) { - my $sock = IO::Socket::INET->new( - PeerHost => $self->host, - ( $self->host =~ /:/ ? () : ( PeerPort => 80 ) ), - ); + unless( can_load(modules => $use_list) ) { + $METHOD_FAIL->{'iosock'} = 1; + return; + } - unless ( $sock ) { - return $self->_error(loc("Could not open socket to '%1', '%2'",$self->host,$!)); - } + my $sock = IO::Socket::INET->new( + PeerHost => $self->host, + ( $self->host =~ /:/ ? () : ( PeerPort => 80 ) ), + ); - my $fh = FileHandle->new; + unless ( $sock ) { + return $self->_error(loc("Could not open socket to '%1', '%2'",$self->host,$!)); + } - # Check open() + my $fh = FileHandle->new; - unless ( $fh->open($to,'>') ) { - return $self->_error(loc( - "Could not open '%1' for writing: %2",$to,$!)); - } + # Check open() - $fh->autoflush(1); - binmode $fh; + unless ( $fh->open($to,'>') ) { + return $self->_error(loc( + "Could not open '%1' for writing: %2",$to,$!)); + } - 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 ); + $fh->autoflush(1); + binmode $fh; - my $select = IO::Select->new( $sock ); + 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 $resp = ''; - my $normal = 0; - while ( $select->can_read( $TIMEOUT || 60 ) ) { - my $ret = $sock->sysread( $resp, 4096, length($resp) ); - if ( !defined $ret or $ret == 0 ) { - $select->remove( $sock ); - $normal++; - } - } - close $sock; + my $select = IO::Select->new( $sock ); - unless ( $normal ) { - return $self->_error(loc("Socket timed out after '%1' seconds", ( $TIMEOUT || 60 ))); - } + my $resp = ''; + my $normal = 0; + while ( $select->can_read( $TIMEOUT || 60 ) ) { + my $ret = $sock->sysread( $resp, 4096, length($resp) ); + if ( !defined $ret or $ret == 0 ) { + $select->remove( $sock ); + $normal++; + } + } + close $sock; - # 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)); - } + unless ( $normal ) { + return $self->_error(loc("Socket timed out after '%1' seconds", ( $TIMEOUT || 60 ))); + } - # 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)); - } + # 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)); + } - { - local $\; - print $fh +($resp =~ m/\x0d\x0a\x0d\x0a(.*)$/s )[0]; - } - close $fh; - return $to; + # 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)); + } - } else { - $METHOD_FAIL->{'iosock'} = 1; - return; + { + local $\; + print $fh +($resp =~ m/\x0d\x0a\x0d\x0a(.*)$/s )[0]; } + close $fh; + return $to; } ### Net::FTP fetching @@ -814,44 +813,43 @@ sub _netftp_fetch { ### required modules ### my $use_list = { 'Net::FTP' => 0 }; - if( can_load( modules => $use_list ) ) { + unless( can_load( modules => $use_list ) ) { + $METHOD_FAIL->{'netftp'} = 1; + return; + } - ### make connection ### - my $ftp; - my @options = ($self->host); - push(@options, Timeout => $TIMEOUT) if $TIMEOUT; - unless( $ftp = Net::FTP->new( @options ) ) { - return $self->_error(loc("Ftp creation failed: %1",$@)); - } + ### make connection ### + my $ftp; + my @options = ($self->host); + push(@options, Timeout => $TIMEOUT) if $TIMEOUT; + unless( $ftp = Net::FTP->new( @options ) ) { + return $self->_error(loc("Ftp creation failed: %1",$@)); + } - ### login ### - unless( $ftp->login( anonymous => $FROM_EMAIL ) ) { - return $self->_error(loc("Could not login to '%1'",$self->host)); - } + ### login ### + unless( $ftp->login( anonymous => $FROM_EMAIL ) ) { + return $self->_error(loc("Could not login to '%1'",$self->host)); + } - ### set binary mode, just in case ### - $ftp->binary; + ### set binary mode, just in case ### + $ftp->binary; - ### create the remote path - ### remember remote paths are unix paths! [#11483] - my $remote = File::Spec::Unix->catfile( $self->path, $self->file ); + ### create the remote path + ### remember remote paths are unix paths! [#11483] + my $remote = File::Spec::Unix->catfile( $self->path, $self->file ); - ### fetch the file ### - my $target; - unless( $target = $ftp->get( $remote, $to ) ) { - return $self->_error(loc("Could not fetch '%1' from '%2'", - $remote, $self->host)); - } + ### fetch the file ### + my $target; + unless( $target = $ftp->get( $remote, $to ) ) { + return $self->_error(loc("Could not fetch '%1' from '%2'", + $remote, $self->host)); + } - ### log out ### - $ftp->quit; + ### log out ### + $ftp->quit; - return $target; + return $target; - } else { - $METHOD_FAIL->{'netftp'} = 1; - return; - } } ### /bin/wget fetch ### @@ -865,47 +863,46 @@ sub _wget_fetch { }; check( $tmpl, \%hash ) or return; + my $wget; ### see if we have a wget binary ### - if( my $wget = can_run('wget') ) { + unless( $wget = can_run('wget') ) { + $METHOD_FAIL->{'wget'} = 1; + return; + } - ### no verboseness, thanks ### - my $cmd = [ $wget, '--quiet' ]; + ### no verboseness, thanks ### + my $cmd = [ $wget, '--quiet' ]; - ### if a timeout is set, add it ### - push(@$cmd, '--timeout=' . $TIMEOUT) if $TIMEOUT; + ### if a timeout is set, add it ### + push(@$cmd, '--timeout=' . $TIMEOUT) if $TIMEOUT; - ### run passive if specified ### - push @$cmd, '--passive-ftp' if $FTP_PASSIVE; + ### run passive if specified ### + push @$cmd, '--passive-ftp' if $FTP_PASSIVE; - ### set the output document, add the uri ### - push @$cmd, '--output-document', $to, $self->uri; + ### set the output document, add the uri ### + 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); + ### 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 || '' )); - } + ### 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 $to; - - } else { - $METHOD_FAIL->{'wget'} = 1; - return; + return $self->_error(loc( "Command failed: %1", $captured || '' )); } + + return $to; } ### /bin/lftp fetch ### @@ -919,67 +916,66 @@ sub _lftp_fetch { }; 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' ]; + ### see if we have a lftp binary ### + my $lftp; + unless( $lftp = can_run('lftp') ) { + $METHOD_FAIL->{'lftp'} = 1; + return; + } - my $fh = File::Temp->new; + ### no verboseness, thanks ### + my $cmd = [ $lftp, '-f' ]; - my $str; + my $fh = File::Temp->new; - ### if a timeout is set, add it ### - $str .= "set net:timeout $TIMEOUT;\n" if $TIMEOUT; + my $str; - ### run passive if specified ### - $str .= "set ftp:passive-mode 1;\n" if $FTP_PASSIVE; + ### if a timeout is set, add it ### + $str .= "set net:timeout $TIMEOUT;\n" if $TIMEOUT; - ### 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 . $/; + ### run passive if specified ### + $str .= "set ftp:passive-mode 1;\n" if $FTP_PASSIVE; - if( $DEBUG ) { - my $pp_str = join ' ', split $/, $str; - print "# lftp command: $pp_str\n"; - } + ### 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 . $/; - ### write straight to the file. - $fh->autoflush(1); - print $fh $str; + if( $DEBUG ) { + my $pp_str = join ' ', split $/, $str; + print "# lftp command: $pp_str\n"; + } - ### the command needs to be 1 string to be executed - push @$cmd, $fh->filename; + ### write straight to the file. + $fh->autoflush(1); + print $fh $str; - ### 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); + ### 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; + ### 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; - } else { - $METHOD_FAIL->{'lftp'} = 1; - return; + return $self->_error(loc( "Command failed: %1", $captured || '' )); } + + return $to; } @@ -996,32 +992,35 @@ sub _ftp_fetch { check( $tmpl, \%hash ) or return; ### see if we have a ftp binary ### - if( my $ftp = can_run('ftp') ) { + my $ftp; + unless( $ftp = can_run('ftp') ) { + $METHOD_FAIL->{'ftp'} = 1; + return; + } - my $fh = FileHandle->new; + my $fh = FileHandle->new; - local $SIG{CHLD} = 'IGNORE'; + local $SIG{CHLD} = 'IGNORE'; - unless ($fh->open("|$ftp -n")) { - return $self->_error(loc("%1 creation failed: %2", $ftp, $!)); - } + unless ($fh->open("$ftp -n", '|-')) { + return $self->_error(loc("%1 creation failed: %2", $ftp, $!)); + } - my @dialog = ( - "lcd " . dirname($to), - "open " . $self->host, - "user anonymous $FROM_EMAIL", - "cd /", - "cd " . $self->path, - "binary", - "get " . $self->file . " " . $self->output_file, - "quit", - ); + my @dialog = ( + "lcd " . dirname($to), + "open " . $self->host, + "user anonymous $FROM_EMAIL", + "cd /", + "cd " . $self->path, + "binary", + "get " . $self->file . " " . $self->output_file, + "quit", + ); - foreach (@dialog) { $fh->print($_, "\n") } - $fh->close or return; + foreach (@dialog) { $fh->print($_, "\n") } + $fh->close or return; - return $to; - } + return $to; } ### lynx is stupid - it decompresses any .gz file it finds to be text @@ -1037,94 +1036,93 @@ sub _lynx_fetch { check( $tmpl, \%hash ) or return; ### see if we have a lynx binary ### - if( my $lynx = can_run('lynx') ) { - - unless( IPC::Cmd->can_capture_buffer ) { - $METHOD_FAIL->{'lynx'} = 1; - - return $self->_error(loc( - "Can not capture buffers. Can not use '%1' to fetch files", - '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 || '')); - } + my $lynx; + unless ( $lynx = can_run('lynx') ){ + $METHOD_FAIL->{'lynx'} = 1; + return; + } - unless($head =~ /^HTTP\/\d+\.\d+ 200\b/) { - return $self->_error(loc("Command failed: %1", $head || '')); - } - } + unless( IPC::Cmd->can_capture_buffer ) { + $METHOD_FAIL->{'lynx'} = 1; - ### write to the output file ourselves, since lynx ass_u_mes to much - my $local = FileHandle->new(">$to") - or return $self->_error(loc( - "Could not open '%1' for writing: %2",$to,$!)); + return $self->_error(loc( + "Can not capture buffers. Can not use '%1' to fetch files", + 'lynx' )); + } - ### dump to stdout ### + ### 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; - ### DO NOT quote things for IPC::Run, it breaks stuff. 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 ### - my $captured; + my $head; unless(run( command => $cmd, - buffer => \$captured, + buffer => \$head, verbose => $DEBUG ) ) { - return $self->_error(loc("Command failed: %1", $captured || '')); + return $self->_error(loc("Command failed: %1", $head || '')); } - ### print to local file ### - ### XXX on a 404 with a special error page, $captured will actually - ### hold the contents of that page, and make it *appear* like the - ### request was a success, when really it wasn't :( - ### there doesn't seem to be an option for lynx to change the exit - ### code based on a 4XX status or so. - ### the closest we can come is using --error_file and parsing that, - ### which is very unreliable ;( - $local->print( $captured ); - $local->close or return; - - return $to; + unless($head =~ /^HTTP\/\d+\.\d+ 200\b/) { + return $self->_error(loc("Command failed: %1", $head || '')); + } + } - } else { - $METHOD_FAIL->{'lynx'} = 1; - return; + ### write to the output file ourselves, since lynx ass_u_mes to much + my $local = FileHandle->new( $to, 'w' ) + or return $self->_error(loc( + "Could not open '%1' for writing: %2",$to,$!)); + + ### dump to stdout ### + my $cmd = [ + $lynx, + '-source', + "-auth=anonymous:$FROM_EMAIL", + ]; + + push @$cmd, "-connect_timeout=$TIMEOUT" if $TIMEOUT; + + ### DO NOT quote things for IPC::Run, it breaks stuff. + 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 ### + my $captured; + unless(run( command => $cmd, + buffer => \$captured, + verbose => $DEBUG ) + ) { + return $self->_error(loc("Command failed: %1", $captured || '')); } + + ### print to local file ### + ### XXX on a 404 with a special error page, $captured will actually + ### hold the contents of that page, and make it *appear* like the + ### request was a success, when really it wasn't :( + ### there doesn't seem to be an option for lynx to change the exit + ### code based on a 4XX status or so. + ### the closest we can come is using --error_file and parsing that, + ### which is very unreliable ;( + $local->print( $captured ); + $local->close or return; + + return $to; } ### use /bin/ncftp to fetch files @@ -1143,38 +1141,38 @@ sub _ncftp_fetch { return if $FTP_PASSIVE; ### see if we have a ncftp binary ### - if( my $ncftp = can_run('ncftp') ) { - - my $cmd = [ - $ncftp, - '-V', # do not be verbose - '-p', $FROM_EMAIL, # email as password - $self->host, # hostname - dirname($to), # local dir for the file - # remote path to the file - ### DO NOT quote things for IPC::Run, it breaks stuff. - $IPC::Cmd::USE_IPC_RUN - ? File::Spec::Unix->catdir( $self->path, $self->file ) - : QUOTE. File::Spec::Unix->catdir( - $self->path, $self->file ) .QUOTE - - ]; - - ### shell out ### - my $captured; - unless(run( command => $cmd, - buffer => \$captured, - verbose => $DEBUG ) - ) { - return $self->_error(loc("Command failed: %1", $captured || '')); - } - - return $to; - - } else { + my $ncftp; + unless( $ncftp = can_run('ncftp') ) { $METHOD_FAIL->{'ncftp'} = 1; return; } + + my $cmd = [ + $ncftp, + '-V', # do not be verbose + '-p', $FROM_EMAIL, # email as password + $self->host, # hostname + dirname($to), # local dir for the file + # remote path to the file + ### DO NOT quote things for IPC::Run, it breaks stuff. + $IPC::Cmd::USE_IPC_RUN + ? File::Spec::Unix->catdir( $self->path, $self->file ) + : QUOTE. File::Spec::Unix->catdir( + $self->path, $self->file ) .QUOTE + + ]; + + ### shell out ### + my $captured; + unless(run( command => $cmd, + buffer => \$captured, + verbose => $DEBUG ) + ) { + return $self->_error(loc("Command failed: %1", $captured || '')); + } + + return $to; + } ### use /bin/curl to fetch files @@ -1187,48 +1185,47 @@ sub _curl_fetch { to => { required => 1, store => \$to } }; check( $tmpl, \%hash ) or return; + my $curl; + unless ( $curl = can_run('curl') ) { + $METHOD_FAIL->{'curl'} = 1; + return; + } - if (my $curl = can_run('curl')) { - - ### these long opts are self explanatory - I like that -jmb - my $cmd = [ $curl, '-q' ]; + ### these long opts are self explanatory - I like that -jmb + my $cmd = [ $curl, '-q' ]; - push(@$cmd, '--connect-timeout', $TIMEOUT) if $TIMEOUT; + push(@$cmd, '--connect-timeout', $TIMEOUT) if $TIMEOUT; - push(@$cmd, '--silent') unless $DEBUG; + push(@$cmd, '--silent') unless $DEBUG; - ### curl does the right thing with passive, regardless ### - if ($self->scheme eq 'ftp') { - push(@$cmd, '--user', "anonymous:$FROM_EMAIL"); - } + ### curl does the right thing with passive, regardless ### + if ($self->scheme eq 'ftp') { + push(@$cmd, '--user', "anonymous:$FROM_EMAIL"); + } - ### curl doesn't follow 302 (temporarily moved) etc automatically - ### so we add --location to enable that. - push @$cmd, '--fail', '--location', '--output', $to, $self->uri; + ### curl doesn't follow 302 (temporarily moved) etc automatically + ### so we add --location to enable that. + 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); + ### 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, - buffer => \$captured, - verbose => $DEBUG ) - ) { + my $captured; + unless(run( command => $cmd, + buffer => \$captured, + verbose => $DEBUG ) + ) { - return $self->_error(loc("Command failed: %1", $captured || '')); - } + return $self->_error(loc("Command failed: %1", $captured || '')); + } - return $to; + return $to; - } else { - $METHOD_FAIL->{'curl'} = 1; - return; - } } ### /usr/bin/fetch fetch! ### @@ -1242,48 +1239,47 @@ sub _fetch_fetch { }; 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; + ### see if we have a fetch binary ### + my $fetch; + unless( HAS_FETCH and $fetch = can_run('fetch') ) { + $METHOD_FAIL->{'fetch'} = 1; return; } + + ### 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; } ### use File::Copy for fetching file:// urls ### @@ -1369,42 +1365,41 @@ sub _rsync_fetch { to => { required => 1, store => \$to } }; check( $tmpl, \%hash ) or return; + my $rsync; + unless ( $rsync = can_run('rsync') ) { + $METHOD_FAIL->{'rsync'} = 1; + return; + } - if (my $rsync = can_run('rsync')) { - - my $cmd = [ $rsync ]; + my $cmd = [ $rsync ]; - ### XXX: rsync has no I/O timeouts at all, by default - push(@$cmd, '--timeout=' . $TIMEOUT) if $TIMEOUT; + ### XXX: rsync has no I/O timeouts at all, by default + push(@$cmd, '--timeout=' . $TIMEOUT) if $TIMEOUT; - push(@$cmd, '--quiet') unless $DEBUG; + push(@$cmd, '--quiet') unless $DEBUG; - ### DO NOT quote things for IPC::Run, it breaks stuff. - push @$cmd, $self->uri, $to; + ### DO NOT quote things for IPC::Run, it breaks stuff. + 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); + ### 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, - buffer => \$captured, - verbose => $DEBUG ) - ) { + my $captured; + unless(run( command => $cmd, + buffer => \$captured, + verbose => $DEBUG ) + ) { - return $self->_error(loc("Command %1 failed: %2", - "@$cmd" || '', $captured || '')); - } + return $self->_error(loc("Command %1 failed: %2", + "@$cmd" || '', $captured || '')); + } - return $to; + return $to; - } else { - $METHOD_FAIL->{'rsync'} = 1; - return; - } } ################################# -- cgit v1.2.1