This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Fix failing Test::Simple test
[perl5.git] / lib / File / Fetch.pm
CommitLineData
79fd8837
JB
1package File::Fetch;
2
3use strict;
4use FileHandle;
5use File::Copy;
6use File::Spec;
7use File::Spec::Unix;
79fd8837
JB
8use File::Basename qw[dirname];
9
10use Cwd qw[cwd];
11use Carp qw[carp];
12use IPC::Cmd qw[can_run run];
13use File::Path qw[mkpath];
14use Params::Check qw[check];
15use Module::Load::Conditional qw[can_load];
16use Locale::Maketext::Simple Style => 'gettext';
17
18use vars qw[ $VERBOSE $PREFER_BIN $FROM_EMAIL $USER_AGENT
19 $BLACKLIST $METHOD_FAIL $VERSION $METHODS
20 $FTP_PASSIVE $TIMEOUT $DEBUG $WARN
21 ];
22
d4b3706f
RGS
23use constant QUOTE => do { $^O eq 'MSWin32' ? q["] : q['] };
24
25
26$VERSION = '0.10';
79fd8837
JB
27$PREFER_BIN = 0; # XXX TODO implement
28$FROM_EMAIL = 'File-Fetch@example.com';
29$USER_AGENT = 'File::Fetch/$VERSION';
30$BLACKLIST = [qw|ftp|];
31$METHOD_FAIL = { };
32$FTP_PASSIVE = 1;
33$TIMEOUT = 0;
34$DEBUG = 0;
35$WARN = 1;
36
37### methods available to fetch the file depending on the scheme
38$METHODS = {
39 http => [ qw|lwp wget curl lynx| ],
40 ftp => [ qw|lwp netftp wget curl ncftp ftp| ],
41 file => [ qw|lwp file| ],
42 rsync => [ qw|rsync| ]
43};
44
45### silly warnings ###
46local $Params::Check::VERBOSE = 1;
47local $Params::Check::VERBOSE = 1;
48local $Module::Load::Conditional::VERBOSE = 0;
49local $Module::Load::Conditional::VERBOSE = 0;
50
51### see what OS we are on, important for file:// uris ###
52use constant ON_UNIX => ($^O ne 'MSWin32' and
53 $^O ne 'MacOS' and
54 $^O ne 'VMS');
55
56=pod
57
58=head1 NAME
59
60File::Fetch - A generic file fetching mechanism
61
62=head1 SYNOPSIS
63
64 use File::Fetch;
65
66 ### build a File::Fetch object ###
67 my $ff = File::Fetch->new(uri => 'http://some.where.com/dir/a.txt');
68
69 ### fetch the uri to cwd() ###
70 my $where = $ff->fetch() or die $ff->error;
71
72 ### fetch the uri to /tmp ###
73 my $where = $ff->fetch( to => '/tmp' );
74
75 ### parsed bits from the uri ###
76 $ff->uri;
77 $ff->scheme;
78 $ff->host;
79 $ff->path;
80 $ff->file;
81
82=head1 DESCRIPTION
83
84File::Fetch is a generic file fetching mechanism.
85
86It allows you to fetch any file pointed to by a C<ftp>, C<http>,
87C<file>, or C<rsync> uri by a number of different means.
88
89See the C<HOW IT WORKS> section further down for details.
90
d4b3706f
RGS
91=head1 ACCESSORS
92
93A C<File::Fetch> object has the following accessors
94
95=over 4
96
97=item $ff->uri
98
99The uri you passed to the constructor
100
101=item $ff->scheme
102
103The scheme from the uri (like 'file', 'http', etc)
104
105=item $ff->host
106
107The hostname in the uri, will be empty for a 'file' scheme.
108
109=item $ff->path
110
111The path from the uri, will be at least a single '/'.
112
113=item $ff->file
114
115The name of the remote file. For the local file name, the
116result of $ff->output_file will be used.
117
118=cut
119
120
121##########################
122### Object & Accessors ###
123##########################
124
125{
126 ### template for new() and autogenerated accessors ###
127 my $Tmpl = {
128 scheme => { default => 'http' },
129 host => { default => 'localhost' },
130 path => { default => '/' },
131 file => { required => 1 },
132 uri => { required => 1 },
133 _error_msg => { no_override => 1 },
134 _error_msg_long => { no_override => 1 },
135 };
136
137 for my $method ( keys %$Tmpl ) {
138 no strict 'refs';
139 *$method = sub {
140 my $self = shift;
141 $self->{$method} = $_[0] if @_;
142 return $self->{$method};
143 }
144 }
145
146 sub _create {
147 my $class = shift;
148 my %hash = @_;
149
150 my $args = check( $Tmpl, \%hash ) or return;
151
152 bless $args, $class;
153
154 if( lc($args->scheme) ne 'file' and not $args->host ) {
155 return File::Fetch->_error(loc(
156 "Hostname required when fetching from '%1'",$args->scheme));
157 }
158
159 for (qw[path file]) {
160 unless( $args->$_ ) {
161 return File::Fetch->_error(loc("No '%1' specified",$_));
162 }
163 }
164
165 return $args;
166 }
167}
168
169=item $ff->output_file
170
171The name of the output file. This is the same as $ff->file,
172but any query parameters are stripped off. For example:
173
174 http://example.com/index.html?x=y
175
176would make the output file be C<index.html> rather than
177C<index.html?x=y>.
178
179=back
180
181=cut
182
183sub output_file {
184 my $self = shift;
185 my $file = $self->file;
186
187 $file =~ s/\?.*$//g;
188
189 return $file;
190}
191
192### XXX do this or just point to URI::Escape?
193# =head2 $esc_uri = $ff->escaped_uri
194#
195# =cut
196#
197# ### most of this is stolen straight from URI::escape
198# { ### Build a char->hex map
199# my %escapes = map { chr($_) => sprintf("%%%02X", $_) } 0..255;
200#
201# sub escaped_uri {
202# my $self = shift;
203# my $uri = $self->uri;
204#
205# ### Default unsafe characters. RFC 2732 ^(uric - reserved)
206# $uri =~ s/([^A-Za-z0-9\-_.!~*'()])/
207# $escapes{$1} || $self->_fail_hi($1)/ge;
208#
209# return $uri;
210# }
211#
212# sub _fail_hi {
213# my $self = shift;
214# my $char = shift;
215#
216# $self->_error(loc(
217# "Can't escape '%1', try using the '%2' module instead",
218# sprintf("\\x{%04X}", ord($char)), 'URI::Escape'
219# ));
220# }
221#
222# sub output_file {
223#
224# }
225#
226#
227# }
228
79fd8837
JB
229=head1 METHODS
230
231=head2 $ff = File::Fetch->new( uri => 'http://some.where.com/dir/file.txt' );
232
233Parses the uri and creates a corresponding File::Fetch::Item object,
234that is ready to be C<fetch>ed and returns it.
235
236Returns false on failure.
237
238=cut
239
240sub new {
241 my $class = shift;
242 my %hash = @_;
243
244 my ($uri);
245 my $tmpl = {
246 uri => { required => 1, store => \$uri },
247 };
248
249 check( $tmpl, \%hash ) or return;
250
251 ### parse the uri to usable parts ###
252 my $href = __PACKAGE__->_parse_uri( $uri ) or return;
253
254 ### make it into a FFI object ###
d4b3706f 255 my $ff = File::Fetch->_create( %$href ) or return;
79fd8837
JB
256
257
258 ### return the object ###
d4b3706f 259 return $ff;
79fd8837
JB
260}
261
262### parses an uri to a hash structure:
263###
264### $class->_parse_uri( 'ftp://ftp.cpan.org/pub/mirror/index.txt' )
265###
266### becomes:
267###
268### $href = {
269### scheme => 'ftp',
270### host => 'ftp.cpan.org',
271### path => '/pub/mirror',
272### file => 'index.html'
273### };
274###
275sub _parse_uri {
276 my $self = shift;
277 my $uri = shift or return;
278
279 my $href = { uri => $uri };
280
281 ### find the scheme ###
282 $uri =~ s|^(\w+)://||;
283 $href->{scheme} = $1;
284
285 ### file:// paths have no host ###
286 if( $href->{scheme} eq 'file' ) {
287 $href->{path} = $uri;
288 $href->{host} = '';
289
290 } else {
291 @{$href}{qw|host path|} = $uri =~ m|([^/]*)(/.*)$|s;
292 }
293
294 ### split the path into file + dir ###
295 { my @parts = File::Spec::Unix->splitpath( delete $href->{path} );
296 $href->{path} = $parts[1];
297 $href->{file} = $parts[2];
298 }
299
300
301 return $href;
302}
303
304=head2 $ff->fetch( [to => /my/output/dir/] )
305
306Fetches the file you requested. By default it writes to C<cwd()>,
307but you can override that by specifying the C<to> argument.
308
309Returns the full path to the downloaded file on success, and false
310on failure.
311
312=cut
313
314sub fetch {
315 my $self = shift or return;
316 my %hash = @_;
317
318 my $to;
319 my $tmpl = {
320 to => { default => cwd(), store => \$to },
321 };
322
323 check( $tmpl, \%hash ) or return;
324
325 ### create the path if it doesn't exist yet ###
326 unless( -d $to ) {
327 eval { mkpath( $to ) };
328
329 return $self->_error(loc("Could not create path '%1'",$to)) if $@;
330 }
331
332 ### set passive ftp if required ###
333 local $ENV{FTP_PASSIVE} = $FTP_PASSIVE;
334
335 ###
336 for my $method ( @{ $METHODS->{$self->scheme} } ) {
337 my $sub = '_'.$method.'_fetch';
338
339 unless( __PACKAGE__->can($sub) ) {
340 $self->_error(loc("Cannot call method for '%1' -- WEIRD!",
341 $method));
342 next;
343 }
344
345 ### method is blacklisted ###
346 next if grep { lc $_ eq $method } @$BLACKLIST;
347
348 ### method is known to fail ###
349 next if $METHOD_FAIL->{$method};
350
d4b3706f
RGS
351 ### there's serious issues with IPC::Run and quoting of command
352 ### line arguments. using quotes in the wrong place breaks things,
353 ### and in the case of say,
354 ### C:\cygwin\bin\wget.EXE --quiet --passive-ftp --output-document
355 ### "index.html" "http://www.cpan.org/index.html?q=1&y=2"
356 ### it doesn't matter how you quote, it always fails.
357 local $IPC::Cmd::USE_IPC_RUN = 0;
358
359 if( my $file = $self->$sub(
360 to => File::Spec->catfile( $to, $self->output_file )
361 )){
79fd8837
JB
362
363 unless( -e $file && -s _ ) {
364 $self->_error(loc("'%1' said it fetched '%2', ".
365 "but it was not created",$method,$file));
366
367 ### mark the failure ###
368 $METHOD_FAIL->{$method} = 1;
369
370 next;
371
372 } else {
373
374 my $abs = File::Spec->rel2abs( $file );
375 return $abs;
376 }
377 }
378 }
379
380
381 ### if we got here, we looped over all methods, but we weren't able
382 ### to fetch it.
383 return;
384}
385
79fd8837
JB
386########################
387### _*_fetch methods ###
388########################
389
390### LWP fetching ###
391sub _lwp_fetch {
392 my $self = shift;
393 my %hash = @_;
394
395 my ($to);
396 my $tmpl = {
397 to => { required => 1, store => \$to }
398 };
399 check( $tmpl, \%hash ) or return;
400
401 ### modules required to download with lwp ###
402 my $use_list = {
403 LWP => '0.0',
404 'LWP::UserAgent' => '0.0',
405 'HTTP::Request' => '0.0',
406 'HTTP::Status' => '0.0',
407 URI => '0.0',
408
409 };
410
411 if( can_load(modules => $use_list) ) {
412
413 ### setup the uri object
414 my $uri = URI->new( File::Spec::Unix->catfile(
415 $self->path, $self->file
416 ) );
417
418 ### special rules apply for file:// uris ###
419 $uri->scheme( $self->scheme );
420 $uri->host( $self->scheme eq 'file' ? '' : $self->host );
421 $uri->userinfo("anonymous:$FROM_EMAIL") if $self->scheme ne 'file';
422
423 ### set up the useragent object
424 my $ua = LWP::UserAgent->new();
425 $ua->timeout( $TIMEOUT ) if $TIMEOUT;
426 $ua->agent( $USER_AGENT );
427 $ua->from( $FROM_EMAIL );
428 $ua->env_proxy;
429
430 my $res = $ua->mirror($uri, $to) or return;
431
432 ### uptodate or fetched ok ###
433 if ( $res->code == 304 or $res->code == 200 ) {
434 return $to;
435
436 } else {
437 return $self->_error(loc("Fetch failed! HTTP response: %1 %2 [%3]",
438 $res->code, HTTP::Status::status_message($res->code),
439 $res->status_line));
440 }
441
442 } else {
443 $METHOD_FAIL->{'lwp'} = 1;
444 return;
445 }
446}
447
448### Net::FTP fetching
449sub _netftp_fetch {
450 my $self = shift;
451 my %hash = @_;
452
453 my ($to);
454 my $tmpl = {
455 to => { required => 1, store => \$to }
456 };
457 check( $tmpl, \%hash ) or return;
458
459 ### required modules ###
460 my $use_list = { 'Net::FTP' => 0 };
461
462 if( can_load( modules => $use_list ) ) {
463
464 ### make connection ###
465 my $ftp;
466 my @options = ($self->host);
467 push(@options, Timeout => $TIMEOUT) if $TIMEOUT;
468 unless( $ftp = Net::FTP->new( @options ) ) {
469 return $self->_error(loc("Ftp creation failed: %1",$@));
470 }
471
472 ### login ###
473 unless( $ftp->login( anonymous => $FROM_EMAIL ) ) {
474 return $self->_error(loc("Could not login to '%1'",$self->host));
475 }
476
477 ### set binary mode, just in case ###
478 $ftp->binary;
479
480 ### create the remote path
481 ### remember remote paths are unix paths! [#11483]
482 my $remote = File::Spec::Unix->catfile( $self->path, $self->file );
483
484 ### fetch the file ###
485 my $target;
486 unless( $target = $ftp->get( $remote, $to ) ) {
487 return $self->_error(loc("Could not fetch '%1' from '%2'",
488 $remote, $self->host));
489 }
490
491 ### log out ###
492 $ftp->quit;
493
494 return $target;
495
496 } else {
497 $METHOD_FAIL->{'netftp'} = 1;
498 return;
499 }
500}
501
502### /bin/wget fetch ###
503sub _wget_fetch {
504 my $self = shift;
505 my %hash = @_;
506
507 my ($to);
508 my $tmpl = {
509 to => { required => 1, store => \$to }
510 };
511 check( $tmpl, \%hash ) or return;
512
513 ### see if we have a wget binary ###
514 if( my $wget = can_run('wget') ) {
515
516 ### no verboseness, thanks ###
517 my $cmd = [ $wget, '--quiet' ];
518
519 ### if a timeout is set, add it ###
520 push(@$cmd, '--timeout=' . $TIMEOUT) if $TIMEOUT;
521
522 ### run passive if specified ###
523 push @$cmd, '--passive-ftp' if $FTP_PASSIVE;
524
525 ### set the output document, add the uri ###
d4b3706f
RGS
526 push @$cmd, '--output-document',
527 ### DO NOT quote things for IPC::Run, it breaks stuff.
528 $IPC::Cmd::USE_IPC_RUN
529 ? ($to, $self->uri)
530 : (QUOTE. $to .QUOTE, QUOTE. $self->uri .QUOTE);
79fd8837
JB
531
532 ### shell out ###
533 my $captured;
d4b3706f
RGS
534 unless(run( command => $cmd,
535 buffer => \$captured,
536 verbose => $DEBUG
537 )) {
79fd8837
JB
538 ### wget creates the output document always, even if the fetch
539 ### fails.. so unlink it in that case
540 1 while unlink $to;
541
542 return $self->_error(loc( "Command failed: %1", $captured || '' ));
543 }
544
545 return $to;
546
547 } else {
548 $METHOD_FAIL->{'wget'} = 1;
549 return;
550 }
551}
552
553
554### /bin/ftp fetch ###
555sub _ftp_fetch {
556 my $self = shift;
557 my %hash = @_;
558
559 my ($to);
560 my $tmpl = {
561 to => { required => 1, store => \$to }
562 };
563 check( $tmpl, \%hash ) or return;
564
d4b3706f 565 ### see if we have a ftp binary ###
79fd8837
JB
566 if( my $ftp = can_run('ftp') ) {
567
568 my $fh = FileHandle->new;
569
570 local $SIG{CHLD} = 'IGNORE';
571
572 unless ($fh->open("|$ftp -n")) {
573 return $self->_error(loc("%1 creation failed: %2", $ftp, $!));
574 }
575
576 my @dialog = (
577 "lcd " . dirname($to),
578 "open " . $self->host,
579 "user anonymous $FROM_EMAIL",
580 "cd /",
581 "cd " . $self->path,
582 "binary",
d4b3706f 583 "get " . $self->file . " " . $self->output_file,
79fd8837
JB
584 "quit",
585 );
586
587 foreach (@dialog) { $fh->print($_, "\n") }
588 $fh->close or return;
589
590 return $to;
591 }
592}
593
594### lynx is stupid - it decompresses any .gz file it finds to be text
595### use /bin/lynx to fetch files
596sub _lynx_fetch {
597 my $self = shift;
598 my %hash = @_;
599
600 my ($to);
601 my $tmpl = {
602 to => { required => 1, store => \$to }
603 };
604 check( $tmpl, \%hash ) or return;
605
d4b3706f 606 ### see if we have a lynx binary ###
79fd8837
JB
607 if( my $lynx = can_run('lynx') ) {
608
d4b3706f
RGS
609 unless( IPC::Cmd->can_capture_buffer ) {
610 $METHOD_FAIL->{'lynx'} = 1;
611
612 return $self->_error(loc(
613 "Can not capture buffers. Can not use '%1' to fetch files",
614 'lynx' ));
615 }
79fd8837
JB
616
617 ### write to the output file ourselves, since lynx ass_u_mes to much
618 my $local = FileHandle->new(">$to")
619 or return $self->_error(loc(
620 "Could not open '%1' for writing: %2",$to,$!));
621
622 ### dump to stdout ###
623 my $cmd = [
624 $lynx,
625 '-source',
626 "-auth=anonymous:$FROM_EMAIL",
627 ];
628
629 push @$cmd, "-connect_timeout=$TIMEOUT" if $TIMEOUT;
630
d4b3706f
RGS
631 ### DO NOT quote things for IPC::Run, it breaks stuff.
632 push @$cmd, $IPC::Cmd::USE_IPC_RUN
633 ? $self->uri
634 : QUOTE. $self->uri .QUOTE;
635
79fd8837
JB
636
637 ### shell out ###
638 my $captured;
639 unless(run( command => $cmd,
640 buffer => \$captured,
641 verbose => $DEBUG )
642 ) {
643 return $self->_error(loc("Command failed: %1", $captured || ''));
644 }
645
646 ### print to local file ###
647 ### XXX on a 404 with a special error page, $captured will actually
648 ### hold the contents of that page, and make it *appear* like the
649 ### request was a success, when really it wasn't :(
650 ### there doesn't seem to be an option for lynx to change the exit
651 ### code based on a 4XX status or so.
652 ### the closest we can come is using --error_file and parsing that,
653 ### which is very unreliable ;(
654 $local->print( $captured );
655 $local->close or return;
656
657 return $to;
658
659 } else {
660 $METHOD_FAIL->{'lynx'} = 1;
661 return;
662 }
663}
664
665### use /bin/ncftp to fetch files
666sub _ncftp_fetch {
667 my $self = shift;
668 my %hash = @_;
669
670 my ($to);
671 my $tmpl = {
672 to => { required => 1, store => \$to }
673 };
674 check( $tmpl, \%hash ) or return;
675
676 ### we can only set passive mode in interactive sesssions, so bail out
677 ### if $FTP_PASSIVE is set
678 return if $FTP_PASSIVE;
679
d4b3706f 680 ### see if we have a ncftp binary ###
79fd8837
JB
681 if( my $ncftp = can_run('ncftp') ) {
682
683 my $cmd = [
684 $ncftp,
685 '-V', # do not be verbose
686 '-p', $FROM_EMAIL, # email as password
687 $self->host, # hostname
688 dirname($to), # local dir for the file
689 # remote path to the file
d4b3706f
RGS
690 ### DO NOT quote things for IPC::Run, it breaks stuff.
691 $IPC::Cmd::USE_IPC_RUN
692 ? File::Spec::Unix->catdir( $self->path, $self->file )
693 : QUOTE. File::Spec::Unix->catdir(
694 $self->path, $self->file ) .QUOTE
695
79fd8837
JB
696 ];
697
698 ### shell out ###
699 my $captured;
700 unless(run( command => $cmd,
701 buffer => \$captured,
702 verbose => $DEBUG )
703 ) {
704 return $self->_error(loc("Command failed: %1", $captured || ''));
705 }
706
707 return $to;
708
709 } else {
710 $METHOD_FAIL->{'ncftp'} = 1;
711 return;
712 }
713}
714
715### use /bin/curl to fetch files
716sub _curl_fetch {
717 my $self = shift;
718 my %hash = @_;
719
720 my ($to);
721 my $tmpl = {
722 to => { required => 1, store => \$to }
723 };
724 check( $tmpl, \%hash ) or return;
725
726 if (my $curl = can_run('curl')) {
727
728 ### these long opts are self explanatory - I like that -jmb
729 my $cmd = [ $curl ];
730
731 push(@$cmd, '--connect-timeout', $TIMEOUT) if $TIMEOUT;
732
733 push(@$cmd, '--silent') unless $DEBUG;
734
735 ### curl does the right thing with passive, regardless ###
736 if ($self->scheme eq 'ftp') {
737 push(@$cmd, '--user', "anonymous:$FROM_EMAIL");
738 }
739
740 ### curl doesn't follow 302 (temporarily moved) etc automatically
741 ### so we add --location to enable that.
d4b3706f
RGS
742 push @$cmd, '--fail', '--location', '--output',
743 ### DO NOT quote things for IPC::Run, it breaks stuff.
744 $IPC::Cmd::USE_IPC_RUN
745 ? ($to, $self->uri)
746 : (QUOTE. $to .QUOTE, QUOTE. $self->uri .QUOTE);
79fd8837
JB
747
748 my $captured;
749 unless(run( command => $cmd,
750 buffer => \$captured,
751 verbose => $DEBUG )
752 ) {
753
754 return $self->_error(loc("Command failed: %1", $captured || ''));
755 }
756
757 return $to;
758
759 } else {
760 $METHOD_FAIL->{'curl'} = 1;
761 return;
762 }
763}
764
765
766### use File::Copy for fetching file:// urls ###
767### XXX file:// uri to local path conversion is just too weird...
768### depend on LWP to do it for us
769sub _file_fetch {
770 my $self = shift;
771 my %hash = @_;
772
773 my ($to);
774 my $tmpl = {
775 to => { required => 1, store => \$to }
776 };
777 check( $tmpl, \%hash ) or return;
778
779 ### prefix a / on unix systems with a file uri, since it would
780 ### look somewhat like this:
781 ### file://home/kane/file
782 ### wheras windows file uris might look like:
783 ### file://C:/home/kane/file
784 my $path = ON_UNIX ? '/'. $self->path : $self->path;
785
786 my $remote = File::Spec->catfile( $path, $self->file );
787
788 ### File::Copy is littered with 'die' statements :( ###
789 my $rv = eval { File::Copy::copy( $remote, $to ) };
790
791 ### something went wrong ###
792 if( !$rv or $@ ) {
793 return $self->_error(loc("Could not copy '%1' to '%2': %3 %4",
794 $remote, $to, $!, $@));
795 }
796
797 return $to;
798}
799
800### use /usr/bin/rsync to fetch files
801sub _rsync_fetch {
802 my $self = shift;
803 my %hash = @_;
804
805 my ($to);
806 my $tmpl = {
807 to => { required => 1, store => \$to }
808 };
809 check( $tmpl, \%hash ) or return;
810
811 if (my $rsync = can_run('rsync')) {
812
813 my $cmd = [ $rsync ];
814
815 ### XXX: rsync has no I/O timeouts at all, by default
816 push(@$cmd, '--timeout=' . $TIMEOUT) if $TIMEOUT;
817
818 push(@$cmd, '--quiet') unless $DEBUG;
819
d4b3706f
RGS
820 ### DO NOT quote things for IPC::Run, it breaks stuff.
821 push @$cmd, $IPC::Cmd::USE_IPC_RUN
822 ? ($self->uri, $to)
823 : (QUOTE. $self->uri .QUOTE, QUOTE. $to .QUOTE);
79fd8837
JB
824
825 my $captured;
826 unless(run( command => $cmd,
827 buffer => \$captured,
828 verbose => $DEBUG )
829 ) {
830
831 return $self->_error(loc("Command failed: %1", $captured || ''));
832 }
833
834 return $to;
835
836 } else {
837 $METHOD_FAIL->{'rsync'} = 1;
838 return;
839 }
840}
841
842#################################
843#
844# Error code
845#
846#################################
847
848=pod
849
850=head2 $ff->error([BOOL])
851
852Returns the last encountered error as string.
853Pass it a true value to get the C<Carp::longmess()> output instead.
854
855=cut
856
d4b3706f
RGS
857### error handling the way Archive::Extract does it
858sub _error {
859 my $self = shift;
860 my $error = shift;
861
862 $self->_error_msg( $error );
863 $self->_error_msg_long( Carp::longmess($error) );
864
865 if( $WARN ) {
866 carp $DEBUG ? $self->_error_msg_long : $self->_error_msg;
79fd8837
JB
867 }
868
d4b3706f 869 return;
79fd8837
JB
870}
871
d4b3706f
RGS
872sub error {
873 my $self = shift;
874 return shift() ? $self->_error_msg_long : $self->_error_msg;
875}
79fd8837
JB
876
877
8781;
879
880=pod
881
882=head1 HOW IT WORKS
883
884File::Fetch is able to fetch a variety of uris, by using several
885external programs and modules.
886
887Below is a mapping of what utilities will be used in what order
888for what schemes, if available:
889
890 file => LWP, file
891 http => LWP, wget, curl, lynx
892 ftp => LWP, Net::FTP, wget, curl, ncftp, ftp
893 rsync => rsync
894
895If you'd like to disable the use of one or more of these utilities
896and/or modules, see the C<$BLACKLIST> variable further down.
897
898If a utility or module isn't available, it will be marked in a cache
899(see the C<$METHOD_FAIL> variable further down), so it will not be
900tried again. The C<fetch> method will only fail when all options are
901exhausted, and it was not able to retrieve the file.
902
903A special note about fetching files from an ftp uri:
904
905By default, all ftp connections are done in passive mode. To change
906that, see the C<$FTP_PASSIVE> variable further down.
907
908Furthermore, ftp uris only support anonymous connections, so no
909named user/password pair can be passed along.
910
911C</bin/ftp> is blacklisted by default; see the C<$BLACKLIST> variable
912further down.
913
914=head1 GLOBAL VARIABLES
915
916The behaviour of File::Fetch can be altered by changing the following
917global variables:
918
919=head2 $File::Fetch::FROM_EMAIL
920
921This is the email address that will be sent as your anonymous ftp
922password.
923
924Default is C<File-Fetch@example.com>.
925
926=head2 $File::Fetch::USER_AGENT
927
928This is the useragent as C<LWP> will report it.
929
930Default is C<File::Fetch/$VERSION>.
931
932=head2 $File::Fetch::FTP_PASSIVE
933
934This variable controls whether the environment variable C<FTP_PASSIVE>
935and any passive switches to commandline tools will be set to true.
936
937Default value is 1.
938
939Note: When $FTP_PASSIVE is true, C<ncftp> will not be used to fetch
940files, since passive mode can only be set interactively for this binary
941
942=head2 $File::Fetch::TIMEOUT
943
944When set, controls the network timeout (counted in seconds).
945
946Default value is 0.
947
948=head2 $File::Fetch::WARN
949
950This variable controls whether errors encountered internally by
951C<File::Fetch> should be C<carp>'d or not.
952
953Set to false to silence warnings. Inspect the output of the C<error()>
954method manually to see what went wrong.
955
956Defaults to C<true>.
957
958=head2 $File::Fetch::DEBUG
959
960This enables debugging output when calling commandline utilities to
961fetch files.
962This also enables C<Carp::longmess> errors, instead of the regular
963C<carp> errors.
964
965Good for tracking down why things don't work with your particular
966setup.
967
968Default is 0.
969
970=head2 $File::Fetch::BLACKLIST
971
972This is an array ref holding blacklisted modules/utilities for fetching
973files with.
974
975To disallow the use of, for example, C<LWP> and C<Net::FTP>, you could
976set $File::Fetch::BLACKLIST to:
977
978 $File::Fetch::BLACKLIST = [qw|lwp netftp|]
979
980The default blacklist is [qw|ftp|], as C</bin/ftp> is rather unreliable.
981
982See the note on C<MAPPING> below.
983
984=head2 $File::Fetch::METHOD_FAIL
985
986This is a hashref registering what modules/utilities were known to fail
987for fetching files (mostly because they weren't installed).
988
989You can reset this cache by assigning an empty hashref to it, or
990individually remove keys.
991
992See the note on C<MAPPING> below.
993
994=head1 MAPPING
995
996
997Here's a quick mapping for the utilities/modules, and their names for
998the $BLACKLIST, $METHOD_FAIL and other internal functions.
999
1000 LWP => lwp
1001 Net::FTP => netftp
1002 wget => wget
1003 lynx => lynx
1004 ncftp => ncftp
1005 ftp => ftp
1006 curl => curl
1007 rsync => rsync
1008
1009=head1 FREQUENTLY ASKED QUESTIONS
1010
1011=head2 So how do I use a proxy with File::Fetch?
1012
1013C<File::Fetch> currently only supports proxies with LWP::UserAgent.
1014You will need to set your environment variables accordingly. For
1015example, to use an ftp proxy:
1016
1017 $ENV{ftp_proxy} = 'foo.com';
1018
1019Refer to the LWP::UserAgent manpage for more details.
1020
1021=head2 I used 'lynx' to fetch a file, but its contents is all wrong!
1022
1023C<lynx> can only fetch remote files by dumping its contents to C<STDOUT>,
1024which we in turn capture. If that content is a 'custom' error file
1025(like, say, a C<404 handler>), you will get that contents instead.
1026
1027Sadly, C<lynx> doesn't support any options to return a different exit
1028code on non-C<200 OK> status, giving us no way to tell the difference
1029between a 'successfull' fetch and a custom error page.
1030
1031Therefor, we recommend to only use C<lynx> as a last resort. This is
1032why it is at the back of our list of methods to try as well.
1033
d4b3706f
RGS
1034=head2 Files I'm trying to fetch have reserved characters or non-ASCII characters in them. What do I do?
1035
1036C<File::Fetch> is relatively smart about things. When trying to write
1037a file to disk, it removes the C<query parameters> (see the
1038C<output_file> method for details) from the file name before creating
1039it. In most cases this suffices.
1040
1041If you have any other characters you need to escape, please install
1042the C<URI::Escape> module from CPAN, and pre-encode your URI before
1043passing it to C<File::Fetch>. You can read about the details of URIs
1044and URI encoding here:
1045
1046 http://www.faqs.org/rfcs/rfc2396.html
1047
79fd8837
JB
1048=head1 TODO
1049
1050=over 4
1051
1052=item Implement $PREFER_BIN
1053
1054To indicate to rather use commandline tools than modules
1055
1056=head1 AUTHORS
1057
d4b3706f 1058This module by Jos Boumans E<lt>kane@cpan.orgE<gt>.
79fd8837
JB
1059
1060=head1 COPYRIGHT
1061
d4b3706f
RGS
1062This module is copyright (c) 2003-2007 Jos Boumans
1063E<lt>kane@cpan.orgE<gt>. All rights reserved.
79fd8837
JB
1064
1065This library is free software;
1066you may redistribute and/or modify it under the same
1067terms as Perl itself.
1068
1069=cut
1070
1071# Local variables:
1072# c-indentation-style: bsd
1073# c-basic-offset: 4
1074# indent-tabs-mode: nil
1075# End:
1076# vim: expandtab shiftwidth=4:
1077
1078
1079
1080