This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Update File::Fetch to 0.12
[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
a0ad4830 26$VERSION = '0.12';
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
a0ad4830 53 $^O ne 'MacOS');
79fd8837
JB
54
55=pod
56
57=head1 NAME
58
59File::Fetch - A generic file fetching mechanism
60
61=head1 SYNOPSIS
62
63 use File::Fetch;
64
65 ### build a File::Fetch object ###
66 my $ff = File::Fetch->new(uri => 'http://some.where.com/dir/a.txt');
67
68 ### fetch the uri to cwd() ###
69 my $where = $ff->fetch() or die $ff->error;
70
71 ### fetch the uri to /tmp ###
72 my $where = $ff->fetch( to => '/tmp' );
73
74 ### parsed bits from the uri ###
75 $ff->uri;
76 $ff->scheme;
77 $ff->host;
78 $ff->path;
79 $ff->file;
80
81=head1 DESCRIPTION
82
83File::Fetch is a generic file fetching mechanism.
84
85It allows you to fetch any file pointed to by a C<ftp>, C<http>,
86C<file>, or C<rsync> uri by a number of different means.
87
88See the C<HOW IT WORKS> section further down for details.
89
d4b3706f
RGS
90=head1 ACCESSORS
91
92A C<File::Fetch> object has the following accessors
93
94=over 4
95
96=item $ff->uri
97
98The uri you passed to the constructor
99
100=item $ff->scheme
101
102The scheme from the uri (like 'file', 'http', etc)
103
104=item $ff->host
105
106The hostname in the uri, will be empty for a 'file' scheme.
107
108=item $ff->path
109
110The path from the uri, will be at least a single '/'.
111
112=item $ff->file
113
114The name of the remote file. For the local file name, the
115result of $ff->output_file will be used.
116
117=cut
118
119
120##########################
121### Object & Accessors ###
122##########################
123
124{
125 ### template for new() and autogenerated accessors ###
126 my $Tmpl = {
127 scheme => { default => 'http' },
128 host => { default => 'localhost' },
129 path => { default => '/' },
130 file => { required => 1 },
131 uri => { required => 1 },
132 _error_msg => { no_override => 1 },
133 _error_msg_long => { no_override => 1 },
134 };
135
136 for my $method ( keys %$Tmpl ) {
137 no strict 'refs';
138 *$method = sub {
139 my $self = shift;
140 $self->{$method} = $_[0] if @_;
141 return $self->{$method};
142 }
143 }
144
145 sub _create {
146 my $class = shift;
147 my %hash = @_;
148
149 my $args = check( $Tmpl, \%hash ) or return;
150
151 bless $args, $class;
152
153 if( lc($args->scheme) ne 'file' and not $args->host ) {
154 return File::Fetch->_error(loc(
155 "Hostname required when fetching from '%1'",$args->scheme));
156 }
157
158 for (qw[path file]) {
159 unless( $args->$_ ) {
160 return File::Fetch->_error(loc("No '%1' specified",$_));
161 }
162 }
163
164 return $args;
165 }
166}
167
168=item $ff->output_file
169
170The name of the output file. This is the same as $ff->file,
171but any query parameters are stripped off. For example:
172
173 http://example.com/index.html?x=y
174
175would make the output file be C<index.html> rather than
176C<index.html?x=y>.
177
178=back
179
180=cut
181
182sub output_file {
183 my $self = shift;
184 my $file = $self->file;
185
186 $file =~ s/\?.*$//g;
187
188 return $file;
189}
190
191### XXX do this or just point to URI::Escape?
192# =head2 $esc_uri = $ff->escaped_uri
193#
194# =cut
195#
196# ### most of this is stolen straight from URI::escape
197# { ### Build a char->hex map
198# my %escapes = map { chr($_) => sprintf("%%%02X", $_) } 0..255;
199#
200# sub escaped_uri {
201# my $self = shift;
202# my $uri = $self->uri;
203#
204# ### Default unsafe characters. RFC 2732 ^(uric - reserved)
205# $uri =~ s/([^A-Za-z0-9\-_.!~*'()])/
206# $escapes{$1} || $self->_fail_hi($1)/ge;
207#
208# return $uri;
209# }
210#
211# sub _fail_hi {
212# my $self = shift;
213# my $char = shift;
214#
215# $self->_error(loc(
216# "Can't escape '%1', try using the '%2' module instead",
217# sprintf("\\x{%04X}", ord($char)), 'URI::Escape'
218# ));
219# }
220#
221# sub output_file {
222#
223# }
224#
225#
226# }
227
79fd8837
JB
228=head1 METHODS
229
230=head2 $ff = File::Fetch->new( uri => 'http://some.where.com/dir/file.txt' );
231
232Parses the uri and creates a corresponding File::Fetch::Item object,
233that is ready to be C<fetch>ed and returns it.
234
235Returns false on failure.
236
237=cut
238
239sub new {
240 my $class = shift;
241 my %hash = @_;
242
243 my ($uri);
244 my $tmpl = {
245 uri => { required => 1, store => \$uri },
246 };
247
248 check( $tmpl, \%hash ) or return;
249
250 ### parse the uri to usable parts ###
251 my $href = __PACKAGE__->_parse_uri( $uri ) or return;
252
253 ### make it into a FFI object ###
d4b3706f 254 my $ff = File::Fetch->_create( %$href ) or return;
79fd8837
JB
255
256
257 ### return the object ###
d4b3706f 258 return $ff;
79fd8837
JB
259}
260
261### parses an uri to a hash structure:
262###
263### $class->_parse_uri( 'ftp://ftp.cpan.org/pub/mirror/index.txt' )
264###
265### becomes:
266###
267### $href = {
268### scheme => 'ftp',
269### host => 'ftp.cpan.org',
270### path => '/pub/mirror',
271### file => 'index.html'
272### };
273###
274sub _parse_uri {
275 my $self = shift;
276 my $uri = shift or return;
277
278 my $href = { uri => $uri };
279
280 ### find the scheme ###
281 $uri =~ s|^(\w+)://||;
282 $href->{scheme} = $1;
283
284 ### file:// paths have no host ###
285 if( $href->{scheme} eq 'file' ) {
286 $href->{path} = $uri;
287 $href->{host} = '';
288
289 } else {
290 @{$href}{qw|host path|} = $uri =~ m|([^/]*)(/.*)$|s;
291 }
292
293 ### split the path into file + dir ###
294 { my @parts = File::Spec::Unix->splitpath( delete $href->{path} );
295 $href->{path} = $parts[1];
296 $href->{file} = $parts[2];
297 }
298
299
300 return $href;
301}
302
303=head2 $ff->fetch( [to => /my/output/dir/] )
304
305Fetches the file you requested. By default it writes to C<cwd()>,
306but you can override that by specifying the C<to> argument.
307
308Returns the full path to the downloaded file on success, and false
309on failure.
310
311=cut
312
313sub fetch {
314 my $self = shift or return;
315 my %hash = @_;
316
317 my $to;
318 my $tmpl = {
319 to => { default => cwd(), store => \$to },
320 };
321
322 check( $tmpl, \%hash ) or return;
323
324 ### create the path if it doesn't exist yet ###
325 unless( -d $to ) {
326 eval { mkpath( $to ) };
327
328 return $self->_error(loc("Could not create path '%1'",$to)) if $@;
329 }
330
331 ### set passive ftp if required ###
332 local $ENV{FTP_PASSIVE} = $FTP_PASSIVE;
333
334 ###
a0ad4830 335 my $out_to = File::Spec->catfile( $to, $self->output_file );
79fd8837
JB
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(
a0ad4830 360 to => $out_to
d4b3706f 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
a0ad4830
JB
1056=back
1057
1058=head1 BUG REPORTS
1059
1060Please report bugs or other issues to E<lt>bug-file-fetch@rt.cpan.org<gt>.
1061
1062=head1 AUTHOR
79fd8837 1063
d4b3706f 1064This module by Jos Boumans E<lt>kane@cpan.orgE<gt>.
79fd8837
JB
1065
1066=head1 COPYRIGHT
1067
a0ad4830
JB
1068This library is free software; you may redistribute and/or modify it
1069under the same terms as Perl itself.
79fd8837 1070
79fd8837
JB
1071
1072=cut
1073
1074# Local variables:
1075# c-indentation-style: bsd
1076# c-basic-offset: 4
1077# indent-tabs-mode: nil
1078# End:
1079# vim: expandtab shiftwidth=4:
1080
1081
1082
1083