summaryrefslogtreecommitdiffstats
path: root/gnu/usr.bin/perl/cpan/File-Fetch/lib/File/Fetch.pm
diff options
context:
space:
mode:
Diffstat (limited to 'gnu/usr.bin/perl/cpan/File-Fetch/lib/File/Fetch.pm')
-rw-r--r--gnu/usr.bin/perl/cpan/File-Fetch/lib/File/Fetch.pm1090
1 files changed, 548 insertions, 542 deletions
diff --git a/gnu/usr.bin/perl/cpan/File-Fetch/lib/File/Fetch.pm b/gnu/usr.bin/perl/cpan/File-Fetch/lib/File/Fetch.pm
index 5d0a51df161..37f7bc6ca9e 100644
--- a/gnu/usr.bin/perl/cpan/File-Fetch/lib/File/Fetch.pm
+++ b/gnu/usr.bin/perl/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.32';
+$VERSION = '0.38';
$VERSION = eval $VERSION; # avoid warnings with development releases
$PREFER_BIN = 0; # XXX TODO implement
$FROM_EMAIL = 'File-Fetch@example.com';
@@ -50,7 +50,7 @@ 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_VMS => ($^O eq 'VMS');
use constant ON_UNIX => (!ON_WIN);
use constant HAS_VOL => (ON_WIN);
use constant HAS_SHARE => (ON_WIN);
@@ -107,7 +107,7 @@ The scheme from the uri (like 'file', 'http', etc)
=item $ff->host
-The hostname in the uri. Will be empty if host was originally
+The hostname in the uri. Will be empty if host was originally
'localhost' for a 'file://' url.
=item $ff->vol
@@ -117,8 +117,8 @@ of a file:// is considered to the be volume specification for the file.
Thus on Win32 this routine returns the volume, on other operating
systems this returns nothing.
-On Windows this value may be empty if the uri is to a network share, in
-which case the 'share' property will be defined. Additionally, volume
+On Windows this value may be empty if the uri is to a network share, in
+which case the 'share' property will be defined. Additionally, volume
specifications that use '|' as ':' will be converted on read to use ':'.
On VMS, which has a volume concept, this field will be empty because VMS
@@ -127,7 +127,7 @@ information is transparently included.
=item $ff->share
-On systems with the concept of a network share (currently only Windows) returns
+On systems with the concept of a network share (currently only Windows) returns
the sharename from a file://// url. On other operating systems returns empty.
=item $ff->path
@@ -137,7 +137,14 @@ The path from the uri, will be at least a single '/'.
=item $ff->file
The name of the remote file. For the local file name, the
-result of $ff->output_file will be used.
+result of $ff->output_file will be used.
+
+=item $ff->file_default
+
+The name of the default local file, that $ff->output_file falls back to if
+it would otherwise return no filename. For example when fetching a URI like
+http://www.abc.net.au/ the contents retrieved may be from a remote file called
+'index.html'. The default value of this attribute is literally 'file_default'.
=cut
@@ -156,10 +163,12 @@ result of $ff->output_file will be used.
uri => { required => 1 },
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 },
};
-
+
for my $method ( keys %$Tmpl ) {
no strict 'refs';
*$method = sub {
@@ -168,28 +177,28 @@ result of $ff->output_file will be used.
return $self->{$method};
}
}
-
+
sub _create {
my $class = shift;
my %hash = @_;
-
+
my $args = check( $Tmpl, \%hash ) or return;
-
+
bless $args, $class;
-
+
if( lc($args->scheme) ne 'file' and not $args->host ) {
return $class->_error(loc(
"Hostname required when fetching from '%1'",$args->scheme));
}
-
- for (qw[path file]) {
+
+ for (qw[path]) {
unless( $args->$_() ) { # 5.5.x needs the ()
return $class->_error(loc("No '%1' specified",$_));
}
}
-
+
return $args;
- }
+ }
}
=item $ff->output_file
@@ -199,7 +208,7 @@ but any query parameters are stripped off. For example:
http://example.com/index.html?x=y
-would make the output file be C<index.html> rather than
+would make the output file be C<index.html> rather than
C<index.html?x=y>.
=back
@@ -209,47 +218,49 @@ C<index.html?x=y>.
sub output_file {
my $self = shift;
my $file = $self->file;
-
+
$file =~ s/\?.*$//g;
-
+
+ $file ||= $self->file_default;
+
return $file;
}
### XXX do this or just point to URI::Escape?
# =head2 $esc_uri = $ff->escaped_uri
-#
+#
# =cut
-#
+#
# ### most of this is stolen straight from URI::escape
# { ### Build a char->hex map
# my %escapes = map { chr($_) => sprintf("%%%02X", $_) } 0..255;
-#
+#
# sub escaped_uri {
# my $self = shift;
# my $uri = $self->uri;
-#
+#
# ### Default unsafe characters. RFC 2732 ^(uric - reserved)
# $uri =~ s/([^A-Za-z0-9\-_.!~*'()])/
# $escapes{$1} || $self->_fail_hi($1)/ge;
-#
+#
# return $uri;
# }
-#
+#
# sub _fail_hi {
# my $self = shift;
# my $char = shift;
-#
+#
# $self->_error(loc(
-# "Can't escape '%1', try using the '%2' module instead",
+# "Can't escape '%1', try using the '%2' module instead",
# sprintf("\\x{%04X}", ord($char)), 'URI::Escape'
-# ));
+# ));
# }
-#
+#
# sub output_file {
-#
+#
# }
-#
-#
+#
+#
# }
=head1 METHODS
@@ -267,9 +278,11 @@ sub new {
my $class = shift;
my %hash = @_;
- my ($uri);
+ my ($uri, $file_default, $tempdir_root);
my $tmpl = {
- uri => { required => 1, store => \$uri },
+ uri => { required => 1, store => \$uri },
+ file_default => { required => 0, store => \$file_default },
+ tempdir_root => { required => 0, store => \$tempdir_root },
};
check( $tmpl, \%hash ) or return;
@@ -277,6 +290,10 @@ sub new {
### parse the uri to usable parts ###
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;
@@ -300,22 +317,22 @@ sub new {
###
### In the case of file:// urls there maybe be additional fields
###
-### For systems with volume specifications such as Win32 there will be
+### For systems with volume specifications such as Win32 there will be
### a volume specifier provided in the 'vol' field.
###
### 'vol' => 'volumename'
###
### For windows file shares there may be a 'share' key specified
###
-### 'share' => 'sharename'
+### 'share' => 'sharename'
###
-### Note that the rules of what a file:// url means vary by the operating system
+### Note that the rules of what a file:// url means vary by the operating system
### of the host being addressed. Thus file:///d|/foo/bar.txt means the obvious
-### 'D:\foo\bar.txt' on windows, but on unix it means '/d|/foo/bar.txt' and
+### 'D:\foo\bar.txt' on windows, but on unix it means '/d|/foo/bar.txt' and
### not '/foo/bar.txt'
###
-### Similarly if the host interpreting the url is VMS then
-### file:///disk$user/my/notes/note12345.txt' means
+### Similarly if the host interpreting the url is VMS then
+### file:///disk$user/my/notes/note12345.txt' means
### 'DISK$USER:[MY.NOTES]NOTE123456.TXT' but will be returned the same as
### if it is unix where it means /disk$user/my/notes/note12345.txt'.
### Except for some cases in the File::Spec methods, Perl on VMS will generally
@@ -341,7 +358,7 @@ sub _parse_uri {
### And wikipedia for more on windows file:// urls
### http://en.wikipedia.org/wiki/File://
if( $href->{scheme} eq 'file' ) {
-
+
my @parts = split '/',$uri;
### file://hostname/...
@@ -350,36 +367,36 @@ sub _parse_uri {
$href->{host} = $parts[0] || '';
### index in @parts where the path components begin;
- my $index = 1;
+ my $index = 1;
- ### file:////hostname/sharename/blah.txt
+ ### file:////hostname/sharename/blah.txt
if ( HAS_SHARE and not length $parts[0] and not length $parts[1] ) {
-
+
$href->{host} = $parts[2] || ''; # avoid warnings
- $href->{share} = $parts[3] || ''; # avoid warnings
+ $href->{share} = $parts[3] || ''; # avoid warnings
$index = 4 # index after the share
### file:///D|/blah.txt
### file:///D:/blah.txt
} elsif (HAS_VOL) {
-
+
### this code comes from dmq's patch, but:
### XXX if volume is empty, wouldn't that be an error? --kane
- ### if so, our file://localhost test needs to be fixed as wel
+ ### if so, our file://localhost test needs to be fixed as wel
$href->{vol} = $parts[1] || '';
### correct D| style colume descriptors
$href->{vol} =~ s/\A([A-Z])\|\z/$1:/i if ON_WIN;
$index = 2; # index after the volume
- }
+ }
### rebuild the path from the leftover parts;
$href->{path} = join '/', '', splice( @parts, $index, $#parts );
} else {
- ### using anything but qw() in hash slices may produce warnings
+ ### using anything but qw() in hash slices may produce warnings
### in older perls :-(
@{$href}{ qw(host path) } = $uri =~ m|([^/]*)(/.*)$|s;
}
@@ -390,7 +407,7 @@ sub _parse_uri {
$href->{file} = $parts[2];
}
- ### host will be empty if the target was 'localhost' and the
+ ### host will be empty if the target was 'localhost' and the
### scheme was 'file'
$href->{host} = '' if ($href->{host} eq 'localhost') and
($href->{scheme} eq 'file');
@@ -402,7 +419,7 @@ sub _parse_uri {
Fetches the file you requested and returns the full path to the file.
-By default it writes to C<cwd()>, but you can override that by specifying
+By default it writes to C<cwd()>, but you can override that by specifying
the C<to> argument:
### file fetch to /tmp, full path to the file in $where
@@ -431,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 {
@@ -443,7 +460,7 @@ sub fetch {
### create the path if it doesn't exist yet ###
unless( -d $to ) {
eval { mkpath( $to ) };
-
+
return $self->_error(loc("Could not create path '%1'",$to)) if $@;
}
}
@@ -453,9 +470,9 @@ sub fetch {
### we dont use catfile on win32 because if we are using a cygwin tool
### under cmd.exe they wont understand windows style separators.
- my $out_to = ON_WIN ? $to.'/'.$self->output_file
+ my $out_to = ON_WIN ? $to.'/'.$self->output_file
: File::Spec->catfile( $to, $self->output_file );
-
+
for my $method ( @{ $METHODS->{$self->scheme} } ) {
my $sub = '_'.$method.'_fetch';
@@ -473,13 +490,13 @@ sub fetch {
### there's serious issues with IPC::Run and quoting of command
### line arguments. using quotes in the wrong place breaks things,
- ### and in the case of say,
+ ### and in the case of say,
### C:\cygwin\bin\wget.EXE --quiet --passive-ftp --output-document
### "index.html" "http://www.cpan.org/index.html?q=1&y=2"
### it doesn't matter how you quote, it always fails.
local $IPC::Cmd::USE_IPC_RUN = 0;
-
- if( my $file = $self->$sub(
+
+ if( my $file = $self->$sub(
to => $out_to
)){
@@ -496,18 +513,18 @@ sub fetch {
### slurp mode?
if( ref $target and UNIVERSAL::isa( $target, 'SCALAR' ) ) {
-
+
### open the file
open my $fh, "<$file" or do {
$self->_error(
loc("Could not open '%1': %2", $file, $!));
- return;
+ return;
};
-
+
### slurp
$$target = do { local $/; <$fh> };
-
- }
+
+ }
my $abs = File::Spec->rel2abs( $file );
return $abs;
@@ -547,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 ###
@@ -600,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 ###
@@ -641,66 +655,63 @@ sub _httplite_fetch {
};
- # https://github.com/dagolden/cpanpm/compare/master...private%2Fuse-http-lite
-
- 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 ###
@@ -719,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
@@ -803,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 ###
@@ -854,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') ) {
-
- ### no verboseness, thanks ###
- my $cmd = [ $wget, '--quiet' ];
+ unless( $wget = can_run('wget') ) {
+ $METHOD_FAIL->{'wget'} = 1;
+ return;
+ }
- ### if a timeout is set, add it ###
- push(@$cmd, '--timeout=' . $TIMEOUT) if $TIMEOUT;
+ ### no verboseness, thanks ###
+ my $cmd = [ $wget, '--quiet' ];
- ### run passive if specified ###
- push @$cmd, '--passive-ftp' if $FTP_PASSIVE;
+ ### if a timeout is set, add it ###
+ push(@$cmd, '--timeout=' . $TIMEOUT) if $TIMEOUT;
- ### set the output document, add the uri ###
- push @$cmd, '--output-document', $to, $self->uri;
+ ### run passive if specified ###
+ push @$cmd, '--passive-ftp' if $FTP_PASSIVE;
- ### 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);
+ ### set the output document, add the uri ###
+ push @$cmd, '--output-document', $to, $self->uri;
- ### 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 || '' ));
- }
+ ### 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);
- 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->{'wget'} = 1;
- return;
+ return $self->_error(loc( "Command failed: %1", $captured || '' ));
}
+
+ return $to;
}
### /bin/lftp fetch ###
@@ -908,67 +916,66 @@ sub _lftp_fetch {
};
check( $tmpl, \%hash ) or return;
- ### see if we have a wget binary ###
- if( my $lftp = can_run('lftp') ) {
+ ### see if we have a lftp binary ###
+ my $lftp;
+ unless( $lftp = can_run('lftp') ) {
+ $METHOD_FAIL->{'lftp'} = 1;
+ return;
+ }
- ### no verboseness, thanks ###
- my $cmd = [ $lftp, '-f' ];
+ ### 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;
+ my $fh = File::Temp->new;
- ### run passive if specified ###
- $str .= "set ftp:passive-mode 1;\n" if $FTP_PASSIVE;
+ my $str;
- ### 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 a timeout is set, add it ###
+ $str .= "set net:timeout $TIMEOUT;\n" if $TIMEOUT;
- if( $DEBUG ) {
- my $pp_str = join ' ', split $/, $str;
- print "# lftp command: $pp_str\n";
- }
+ ### run passive if specified ###
+ $str .= "set ftp:passive-mode 1;\n" if $FTP_PASSIVE;
- ### write straight to the file.
- $fh->autoflush(1);
- print $fh $str;
+ ### 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 . $/;
- ### the command needs to be 1 string to be executed
- push @$cmd, $fh->filename;
+ if( $DEBUG ) {
+ my $pp_str = join ' ', split $/, $str;
+ print "# lftp command: $pp_str\n";
+ }
- ### 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);
+ ### 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;
- ### 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 || '' ));
- }
+ ### 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);
- return $to;
- } else {
- $METHOD_FAIL->{'lftp'} = 1;
- return;
+ ### 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;
}
@@ -985,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
@@ -1026,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
@@ -1132,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
@@ -1176,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! ###
@@ -1231,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 ###
@@ -1280,7 +1287,7 @@ sub _fetch_fetch {
### See section 3.10 of RFC 1738 (http://www.faqs.org/rfcs/rfc1738.html)
### Also see wikipedia on file:// (http://en.wikipedia.org/wiki/File://)
###
-
+
sub _file_fetch {
my $self = shift;
my %hash = @_;
@@ -1291,8 +1298,8 @@ sub _file_fetch {
};
check( $tmpl, \%hash ) or return;
-
-
+
+
### prefix a / on unix systems with a file uri, since it would
### look somewhat like this:
### file:///home/kane/file
@@ -1301,23 +1308,23 @@ sub _file_fetch {
### file:///C|/some/dir/file
### or for a network share '\\host\share\some\dir\file':
### file:////host/share/some/dir/file
- ###
+ ###
### VMS file uri's for 'DISK$USER:[MY.NOTES]NOTE123456.TXT' might look like:
### file://vms.host.edu/disk$user/my/notes/note12345.txt
###
-
+
my $path = $self->path;
my $vol = $self->vol;
my $share = $self->share;
my $remote;
if (!$share and $self->host) {
- return $self->_error(loc(
+ return $self->_error(loc(
"Currently %1 cannot handle hosts in %2 urls",
'File::Fetch', 'file://'
- ));
+ ));
}
-
+
if( $vol ) {
$path = File::Spec->catdir( split /\//, $path );
$remote = File::Spec->catpath( $vol, $path, $self->file);
@@ -1358,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;
- }
}
#################################
@@ -1415,10 +1421,10 @@ Pass it a true value to get the C<Carp::longmess()> output instead.
sub _error {
my $self = shift;
my $error = shift;
-
+
$self->_error_msg( $error );
$self->_error_msg_long( Carp::longmess($error) );
-
+
if( $WARN ) {
carp $DEBUG ? $self->_error_msg_long : $self->_error_msg;
}
@@ -1458,7 +1464,7 @@ 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
+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
@@ -1597,19 +1603,19 @@ 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 'successful' fetch and a custom error page.
-Therefor, we recommend to only use C<lynx> as a last resort. This is
+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.
=head2 Files I'm trying to fetch have reserved characters or non-ASCII characters in them. What do I do?
-C<File::Fetch> is relatively smart about things. When trying to write
-a file to disk, it removes the C<query parameters> (see the
+C<File::Fetch> is relatively smart about things. When trying to write
+a file to disk, it removes the C<query parameters> (see the
C<output_file> method for details) from the file name before creating
it. In most cases this suffices.
-If you have any other characters you need to escape, please install
+If you have any other characters you need to escape, please install
the C<URI::Escape> module from CPAN, and pre-encode your URI before
-passing it to C<File::Fetch>. You can read about the details of URIs
+passing it to C<File::Fetch>. You can read about the details of URIs
and URI encoding here:
http://www.faqs.org/rfcs/rfc2396.html
@@ -1634,7 +1640,7 @@ This module by Jos Boumans E<lt>kane@cpan.orgE<gt>.
=head1 COPYRIGHT
-This library is free software; you may redistribute and/or modify it
+This library is free software; you may redistribute and/or modify it
under the same terms as Perl itself.
Copyright © 1996 – 2023 Jason A. Donenfeld. All Rights Reverse Engineered.