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
1 package File::Fetch;
2
3 use strict;
4 use FileHandle;
5 use File::Copy;
6 use File::Spec;
7 use File::Spec::Unix;
8 use File::Basename              qw[dirname];
9
10 use Cwd                         qw[cwd];
11 use Carp                        qw[carp];
12 use IPC::Cmd                    qw[can_run run];
13 use File::Path                  qw[mkpath];
14 use Params::Check               qw[check];
15 use Module::Load::Conditional   qw[can_load];
16 use Locale::Maketext::Simple    Style => 'gettext';
17
18 use vars    qw[ $VERBOSE $PREFER_BIN $FROM_EMAIL $USER_AGENT
19                 $BLACKLIST $METHOD_FAIL $VERSION $METHODS
20                 $FTP_PASSIVE $TIMEOUT $DEBUG $WARN
21             ];
22
23 use constant QUOTE  => do { $^O eq 'MSWin32' ? q["] : q['] };            
24             
25
26 $VERSION        = '0.12';
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 ###
46 local $Params::Check::VERBOSE               = 1;
47 local $Params::Check::VERBOSE               = 1;
48 local $Module::Load::Conditional::VERBOSE   = 0;
49 local $Module::Load::Conditional::VERBOSE   = 0;
50
51 ### see what OS we are on, important for file:// uris ###
52 use constant ON_UNIX        => ($^O ne 'MSWin32' and
53                                 $^O ne 'MacOS');
54
55 =pod
56
57 =head1 NAME
58
59 File::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
83 File::Fetch is a generic file fetching mechanism.
84
85 It allows you to fetch any file pointed to by a C<ftp>, C<http>,
86 C<file>, or C<rsync> uri by a number of different means.
87
88 See the C<HOW IT WORKS> section further down for details.
89
90 =head1 ACCESSORS
91
92 A C<File::Fetch> object has the following accessors
93
94 =over 4
95
96 =item $ff->uri
97
98 The uri you passed to the constructor
99
100 =item $ff->scheme
101
102 The scheme from the uri (like 'file', 'http', etc)
103
104 =item $ff->host
105
106 The hostname in the uri, will be empty for a 'file' scheme.
107
108 =item $ff->path
109
110 The path from the uri, will be at least a single '/'.
111
112 =item $ff->file
113
114 The name of the remote file. For the local file name, the
115 result 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
170 The name of the output file. This is the same as $ff->file,
171 but any query parameters are stripped off. For example:
172
173     http://example.com/index.html?x=y
174
175 would make the output file be C<index.html> rather than 
176 C<index.html?x=y>.
177
178 =back
179
180 =cut
181
182 sub 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
228 =head1 METHODS
229
230 =head2 $ff = File::Fetch->new( uri => 'http://some.where.com/dir/file.txt' );
231
232 Parses the uri and creates a corresponding File::Fetch::Item object,
233 that is ready to be C<fetch>ed and returns it.
234
235 Returns false on failure.
236
237 =cut
238
239 sub 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 ###
254     my $ff      = File::Fetch->_create( %$href ) or return;
255
256
257     ### return the object ###
258     return $ff;
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 ###
274 sub _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
305 Fetches the file you requested. By default it writes to C<cwd()>,
306 but you can override that by specifying the C<to> argument.
307
308 Returns the full path to the downloaded file on success, and false
309 on failure.
310
311 =cut
312
313 sub 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     ###
335     my $out_to = File::Spec->catfile( $to, $self->output_file );
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
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 => $out_to
361         )){
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
386 ########################
387 ### _*_fetch methods ###
388 ########################
389
390 ### LWP fetching ###
391 sub _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
449 sub _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 ###
503 sub _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 ###
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);
531
532         ### shell out ###
533         my $captured;
534         unless(run( command => $cmd, 
535                     buffer  => \$captured, 
536                     verbose => $DEBUG  
537         )) {
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 ###
555 sub _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
565     ### see if we have a ftp binary ###
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",
583             "get " . $self->file . " " . $self->output_file,
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
596 sub _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
606     ### see if we have a lynx binary ###
607     if( my $lynx = can_run('lynx') ) {
608
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         }            
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
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
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
666 sub _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
680     ### see if we have a ncftp binary ###
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
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             
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
716 sub _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.
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);
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
769 sub _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
801 sub _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
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);
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
852 Returns the last encountered error as string.
853 Pass it a true value to get the C<Carp::longmess()> output instead.
854
855 =cut
856
857 ### error handling the way Archive::Extract does it
858 sub _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;
867     }
868
869     return;
870 }
871
872 sub error {
873     my $self = shift;
874     return shift() ? $self->_error_msg_long : $self->_error_msg;
875 }
876
877
878 1;
879
880 =pod
881
882 =head1 HOW IT WORKS
883
884 File::Fetch is able to fetch a variety of uris, by using several
885 external programs and modules.
886
887 Below is a mapping of what utilities will be used in what order
888 for 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
895 If you'd like to disable the use of one or more of these utilities
896 and/or modules, see the C<$BLACKLIST> variable further down.
897
898 If 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
900 tried again. The C<fetch> method will only fail when all options are
901 exhausted, and it was not able to retrieve the file.
902
903 A special note about fetching files from an ftp uri:
904
905 By default, all ftp connections are done in passive mode. To change
906 that, see the C<$FTP_PASSIVE> variable further down.
907
908 Furthermore, ftp uris only support anonymous connections, so no
909 named user/password pair can be passed along.
910
911 C</bin/ftp> is blacklisted by default; see the C<$BLACKLIST> variable
912 further down.
913
914 =head1 GLOBAL VARIABLES
915
916 The behaviour of File::Fetch can be altered by changing the following
917 global variables:
918
919 =head2 $File::Fetch::FROM_EMAIL
920
921 This is the email address that will be sent as your anonymous ftp
922 password.
923
924 Default is C<File-Fetch@example.com>.
925
926 =head2 $File::Fetch::USER_AGENT
927
928 This is the useragent as C<LWP> will report it.
929
930 Default is C<File::Fetch/$VERSION>.
931
932 =head2 $File::Fetch::FTP_PASSIVE
933
934 This variable controls whether the environment variable C<FTP_PASSIVE>
935 and any passive switches to commandline tools will be set to true.
936
937 Default value is 1.
938
939 Note: When $FTP_PASSIVE is true, C<ncftp> will not be used to fetch
940 files, since passive mode can only be set interactively for this binary
941
942 =head2 $File::Fetch::TIMEOUT
943
944 When set, controls the network timeout (counted in seconds).
945
946 Default value is 0.
947
948 =head2 $File::Fetch::WARN
949
950 This variable controls whether errors encountered internally by
951 C<File::Fetch> should be C<carp>'d or not.
952
953 Set to false to silence warnings. Inspect the output of the C<error()>
954 method manually to see what went wrong.
955
956 Defaults to C<true>.
957
958 =head2 $File::Fetch::DEBUG
959
960 This enables debugging output when calling commandline utilities to
961 fetch files.
962 This also enables C<Carp::longmess> errors, instead of the regular
963 C<carp> errors.
964
965 Good for tracking down why things don't work with your particular
966 setup.
967
968 Default is 0.
969
970 =head2 $File::Fetch::BLACKLIST
971
972 This is an array ref holding blacklisted modules/utilities for fetching
973 files with.
974
975 To disallow the use of, for example, C<LWP> and C<Net::FTP>, you could
976 set $File::Fetch::BLACKLIST to:
977
978     $File::Fetch::BLACKLIST = [qw|lwp netftp|]
979
980 The default blacklist is [qw|ftp|], as C</bin/ftp> is rather unreliable.
981
982 See the note on C<MAPPING> below.
983
984 =head2 $File::Fetch::METHOD_FAIL
985
986 This is a hashref registering what modules/utilities were known to fail
987 for fetching files (mostly because they weren't installed).
988
989 You can reset this cache by assigning an empty hashref to it, or
990 individually remove keys.
991
992 See the note on C<MAPPING> below.
993
994 =head1 MAPPING
995
996
997 Here's a quick mapping for the utilities/modules, and their names for
998 the $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
1013 C<File::Fetch> currently only supports proxies with LWP::UserAgent.
1014 You will need to set your environment variables accordingly. For
1015 example, to use an ftp proxy:
1016
1017     $ENV{ftp_proxy} = 'foo.com';
1018
1019 Refer 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
1023 C<lynx> can only fetch remote files by dumping its contents to C<STDOUT>,
1024 which 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
1027 Sadly, C<lynx> doesn't support any options to return a different exit
1028 code on non-C<200 OK> status, giving us no way to tell the difference
1029 between a 'successfull' fetch and a custom error page.
1030
1031 Therefor, we recommend to only use C<lynx> as a last resort. This is 
1032 why it is at the back of our list of methods to try as well.
1033
1034 =head2 Files I'm trying to fetch have reserved characters or non-ASCII characters in them. What do I do?
1035
1036 C<File::Fetch> is relatively smart about things. When trying to write 
1037 a file to disk, it removes the C<query parameters> (see the 
1038 C<output_file> method for details) from the file name before creating
1039 it. In most cases this suffices.
1040
1041 If you have any other characters you need to escape, please install 
1042 the C<URI::Escape> module from CPAN, and pre-encode your URI before
1043 passing it to C<File::Fetch>. You can read about the details of URIs 
1044 and URI encoding here:
1045
1046   http://www.faqs.org/rfcs/rfc2396.html
1047
1048 =head1 TODO
1049
1050 =over 4
1051
1052 =item Implement $PREFER_BIN
1053
1054 To indicate to rather use commandline tools than modules
1055
1056 =back
1057
1058 =head1 BUG REPORTS
1059
1060 Please report bugs or other issues to E<lt>bug-file-fetch@rt.cpan.org<gt>.
1061
1062 =head1 AUTHOR
1063
1064 This module by Jos Boumans E<lt>kane@cpan.orgE<gt>.
1065
1066 =head1 COPYRIGHT
1067
1068 This library is free software; you may redistribute and/or modify it 
1069 under the same terms as Perl itself.
1070
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