This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Move File::Fetch from ext/ to cpan/
[perl5.git] / cpan / File-Fetch / lib / File / Fetch.pm
1 package File::Fetch;
2
3 use strict;
4 use FileHandle;
5 use File::Temp;
6 use File::Copy;
7 use File::Spec;
8 use File::Spec::Unix;
9 use File::Basename              qw[dirname];
10
11 use Cwd                         qw[cwd];
12 use Carp                        qw[carp];
13 use IPC::Cmd                    qw[can_run run QUOTE];
14 use File::Path                  qw[mkpath];
15 use File::Temp                  qw[tempdir];
16 use Params::Check               qw[check];
17 use Module::Load::Conditional   qw[can_load];
18 use Locale::Maketext::Simple    Style => 'gettext';
19
20 use vars    qw[ $VERBOSE $PREFER_BIN $FROM_EMAIL $USER_AGENT
21                 $BLACKLIST $METHOD_FAIL $VERSION $METHODS
22                 $FTP_PASSIVE $TIMEOUT $DEBUG $WARN
23             ];
24
25 $VERSION        = '0.20';
26 $VERSION        = eval $VERSION;    # avoid warnings with development releases
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 lftp lynx| ],
40     ftp     => [ qw|lwp netftp wget curl lftp ncftp ftp| ],
41     file    => [ qw|lwp lftp 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_WIN     => ($^O eq 'MSWin32');
53 use constant ON_VMS     => ($^O eq 'VMS');                                
54 use constant ON_UNIX    => (!ON_WIN);
55 use constant HAS_VOL    => (ON_WIN);
56 use constant HAS_SHARE  => (ON_WIN);
57
58
59 =pod
60
61 =head1 NAME
62
63 File::Fetch - A generic file fetching mechanism
64
65 =head1 SYNOPSIS
66
67     use File::Fetch;
68
69     ### build a File::Fetch object ###
70     my $ff = File::Fetch->new(uri => 'http://some.where.com/dir/a.txt');
71
72     ### fetch the uri to cwd() ###
73     my $where = $ff->fetch() or die $ff->error;
74
75     ### fetch the uri to /tmp ###
76     my $where = $ff->fetch( to => '/tmp' );
77
78     ### parsed bits from the uri ###
79     $ff->uri;
80     $ff->scheme;
81     $ff->host;
82     $ff->path;
83     $ff->file;
84
85 =head1 DESCRIPTION
86
87 File::Fetch is a generic file fetching mechanism.
88
89 It allows you to fetch any file pointed to by a C<ftp>, C<http>,
90 C<file>, or C<rsync> uri by a number of different means.
91
92 See the C<HOW IT WORKS> section further down for details.
93
94 =head1 ACCESSORS
95
96 A C<File::Fetch> object has the following accessors
97
98 =over 4
99
100 =item $ff->uri
101
102 The uri you passed to the constructor
103
104 =item $ff->scheme
105
106 The scheme from the uri (like 'file', 'http', etc)
107
108 =item $ff->host
109
110 The hostname in the uri.  Will be empty if host was originally 
111 'localhost' for a 'file://' url.
112
113 =item $ff->vol
114
115 On operating systems with the concept of a volume the second element
116 of a file:// is considered to the be volume specification for the file.
117 Thus on Win32 this routine returns the volume, on other operating
118 systems this returns nothing.
119
120 On Windows this value may be empty if the uri is to a network share, in 
121 which case the 'share' property will be defined. Additionally, volume 
122 specifications that use '|' as ':' will be converted on read to use ':'.
123
124 On VMS, which has a volume concept, this field will be empty because VMS
125 file specifications are converted to absolute UNIX format and the volume
126 information is transparently included.
127
128 =item $ff->share
129
130 On systems with the concept of a network share (currently only Windows) returns 
131 the sharename from a file://// url.  On other operating systems returns empty.
132
133 =item $ff->path
134
135 The path from the uri, will be at least a single '/'.
136
137 =item $ff->file
138
139 The name of the remote file. For the local file name, the
140 result of $ff->output_file will be used. 
141
142 =cut
143
144
145 ##########################
146 ### Object & Accessors ###
147 ##########################
148
149 {
150     ### template for autogenerated accessors ###
151     my $Tmpl = {
152         scheme          => { default => 'http' },
153         host            => { default => 'localhost' },
154         path            => { default => '/' },
155         file            => { required => 1 },
156         uri             => { required => 1 },
157         vol             => { default => '' }, # windows for file:// uris
158         share           => { default => '' }, # windows for file:// uris
159         _error_msg      => { no_override => 1 },
160         _error_msg_long => { no_override => 1 },
161     };
162     
163     for my $method ( keys %$Tmpl ) {
164         no strict 'refs';
165         *$method = sub {
166                         my $self = shift;
167                         $self->{$method} = $_[0] if @_;
168                         return $self->{$method};
169                     }
170     }
171     
172     sub _create {
173         my $class = shift;
174         my %hash  = @_;
175         
176         my $args = check( $Tmpl, \%hash ) or return;
177         
178         bless $args, $class;
179     
180         if( lc($args->scheme) ne 'file' and not $args->host ) {
181             return File::Fetch->_error(loc(
182                 "Hostname required when fetching from '%1'",$args->scheme));
183         }
184         
185         for (qw[path file]) {
186             unless( $args->$_() ) { # 5.5.x needs the ()
187                 return File::Fetch->_error(loc("No '%1' specified",$_));
188             }
189         }
190         
191         return $args;
192     }    
193 }
194
195 =item $ff->output_file
196
197 The name of the output file. This is the same as $ff->file,
198 but any query parameters are stripped off. For example:
199
200     http://example.com/index.html?x=y
201
202 would make the output file be C<index.html> rather than 
203 C<index.html?x=y>.
204
205 =back
206
207 =cut
208
209 sub output_file {
210     my $self = shift;
211     my $file = $self->file;
212     
213     $file =~ s/\?.*$//g;
214     
215     return $file;
216 }
217
218 ### XXX do this or just point to URI::Escape?
219 # =head2 $esc_uri = $ff->escaped_uri
220
221 # =cut
222
223 # ### most of this is stolen straight from URI::escape
224 # {   ### Build a char->hex map
225 #     my %escapes = map { chr($_) => sprintf("%%%02X", $_) } 0..255;
226
227 #     sub escaped_uri {
228 #         my $self = shift;
229 #         my $uri  = $self->uri;
230
231 #         ### Default unsafe characters.  RFC 2732 ^(uric - reserved)
232 #         $uri =~ s/([^A-Za-z0-9\-_.!~*'()])/
233 #                     $escapes{$1} || $self->_fail_hi($1)/ge;
234
235 #         return $uri;
236 #     }
237
238 #     sub _fail_hi {
239 #         my $self = shift;
240 #         my $char = shift;
241 #         
242 #         $self->_error(loc(
243 #             "Can't escape '%1', try using the '%2' module instead", 
244 #             sprintf("\\x{%04X}", ord($char)), 'URI::Escape'
245 #         ));            
246 #     }
247
248 #     sub output_file {
249 #     
250 #     }
251 #     
252 #     
253 # }
254
255 =head1 METHODS
256
257 =head2 $ff = File::Fetch->new( uri => 'http://some.where.com/dir/file.txt' );
258
259 Parses the uri and creates a corresponding File::Fetch::Item object,
260 that is ready to be C<fetch>ed and returns it.
261
262 Returns false on failure.
263
264 =cut
265
266 sub new {
267     my $class = shift;
268     my %hash  = @_;
269
270     my ($uri);
271     my $tmpl = {
272         uri => { required => 1, store => \$uri },
273     };
274
275     check( $tmpl, \%hash ) or return;
276
277     ### parse the uri to usable parts ###
278     my $href    = __PACKAGE__->_parse_uri( $uri ) or return;
279
280     ### make it into a FFI object ###
281     my $ff      = File::Fetch->_create( %$href ) or return;
282
283
284     ### return the object ###
285     return $ff;
286 }
287
288 ### parses an uri to a hash structure:
289 ###
290 ### $class->_parse_uri( 'ftp://ftp.cpan.org/pub/mirror/index.txt' )
291 ###
292 ### becomes:
293 ###
294 ### $href = {
295 ###     scheme  => 'ftp',
296 ###     host    => 'ftp.cpan.org',
297 ###     path    => '/pub/mirror',
298 ###     file    => 'index.html'
299 ### };
300 ###
301 ### In the case of file:// urls there maybe be additional fields
302 ###
303 ### For systems with volume specifications such as Win32 there will be 
304 ### a volume specifier provided in the 'vol' field.
305 ###
306 ###   'vol' => 'volumename'
307 ###
308 ### For windows file shares there may be a 'share' key specified
309 ###
310 ###   'share' => 'sharename' 
311 ###
312 ### Note that the rules of what a file:// url means vary by the operating system 
313 ### of the host being addressed. Thus file:///d|/foo/bar.txt means the obvious
314 ### 'D:\foo\bar.txt' on windows, but on unix it means '/d|/foo/bar.txt' and 
315 ### not '/foo/bar.txt'
316 ###
317 ### Similarly if the host interpreting the url is VMS then 
318 ### file:///disk$user/my/notes/note12345.txt' means 
319 ### 'DISK$USER:[MY.NOTES]NOTE123456.TXT' but will be returned the same as
320 ### if it is unix where it means /disk$user/my/notes/note12345.txt'.
321 ### Except for some cases in the File::Spec methods, Perl on VMS will generally
322 ### handle UNIX format file specifications.
323 ###
324 ### This means it is impossible to serve certain file:// urls on certain systems.
325 ###
326 ### Thus are the problems with a protocol-less specification. :-(
327 ###
328
329 sub _parse_uri {
330     my $self = shift;
331     my $uri  = shift or return;
332
333     my $href = { uri => $uri };
334
335     ### find the scheme ###
336     $uri            =~ s|^(\w+)://||;
337     $href->{scheme} = $1;
338
339     ### See rfc 1738 section 3.10
340     ### http://www.faqs.org/rfcs/rfc1738.html
341     ### And wikipedia for more on windows file:// urls
342     ### http://en.wikipedia.org/wiki/File://
343     if( $href->{scheme} eq 'file' ) {
344         
345         my @parts = split '/',$uri;
346
347         ### file://hostname/...
348         ### file://hostname/...
349         ### normalize file://localhost with file:///
350         $href->{host} = $parts[0] || '';
351
352         ### index in @parts where the path components begin;
353         my $index = 1;  
354
355         ### file:////hostname/sharename/blah.txt        
356         if ( HAS_SHARE and not length $parts[0] and not length $parts[1] ) {
357             
358             $href->{host}   = $parts[2] || '';  # avoid warnings
359             $href->{share}  = $parts[3] || '';  # avoid warnings        
360
361             $index          = 4         # index after the share
362
363         ### file:///D|/blah.txt
364         ### file:///D:/blah.txt
365         } elsif (HAS_VOL) {
366         
367             ### this code comes from dmq's patch, but:
368             ### XXX if volume is empty, wouldn't that be an error? --kane
369             ### if so, our file://localhost test needs to be fixed as wel            
370             $href->{vol}    = $parts[1] || '';
371
372             ### correct D| style colume descriptors
373             $href->{vol}    =~ s/\A([A-Z])\|\z/$1:/i if ON_WIN;
374
375             $index          = 2;        # index after the volume
376         } 
377
378         ### rebuild the path from the leftover parts;
379         $href->{path} = join '/', '', splice( @parts, $index, $#parts );
380
381     } else {
382         ### using anything but qw() in hash slices may produce warnings 
383         ### in older perls :-(
384         @{$href}{ qw(host path) } = $uri =~ m|([^/]*)(/.*)$|s;
385     }
386
387     ### split the path into file + dir ###
388     {   my @parts = File::Spec::Unix->splitpath( delete $href->{path} );
389         $href->{path} = $parts[1];
390         $href->{file} = $parts[2];
391     }
392
393     ### host will be empty if the target was 'localhost' and the 
394     ### scheme was 'file'
395     $href->{host} = '' if   ($href->{host}      eq 'localhost') and
396                             ($href->{scheme}    eq 'file');
397
398     return $href;
399 }
400
401 =head2 $where = $ff->fetch( [to => /my/output/dir/ | \$scalar] )
402
403 Fetches the file you requested and returns the full path to the file.
404
405 By default it writes to C<cwd()>, but you can override that by specifying 
406 the C<to> argument:
407
408     ### file fetch to /tmp, full path to the file in $where
409     $where = $ff->fetch( to => '/tmp' );
410
411     ### file slurped into $scalar, full path to the file in $where
412     ### file is downloaded to a temp directory and cleaned up at exit time
413     $where = $ff->fetch( to => \$scalar );
414
415 Returns the full path to the downloaded file on success, and false
416 on failure.
417
418 =cut
419
420 sub fetch {
421     my $self = shift or return;
422     my %hash = @_;
423
424     my $target;
425     my $tmpl = {
426         to  => { default => cwd(), store => \$target },
427     };
428
429     check( $tmpl, \%hash ) or return;
430
431     my ($to, $fh);
432     ### you want us to slurp the contents
433     if( ref $target and UNIVERSAL::isa( $target, 'SCALAR' ) ) {
434         $to = tempdir( 'FileFetch.XXXXXX', CLEANUP => 1 );
435
436     ### plain old fetch
437     } else {
438         $to = $target;
439
440         ### On VMS force to VMS format so File::Spec will work.
441         $to = VMS::Filespec::vmspath($to) if ON_VMS;
442
443         ### create the path if it doesn't exist yet ###
444         unless( -d $to ) {
445             eval { mkpath( $to ) };
446     
447             return $self->_error(loc("Could not create path '%1'",$to)) if $@;
448         }
449     }
450
451     ### set passive ftp if required ###
452     local $ENV{FTP_PASSIVE} = $FTP_PASSIVE;
453
454     ### we dont use catfile on win32 because if we are using a cygwin tool
455     ### under cmd.exe they wont understand windows style separators.
456     my $out_to = ON_WIN ? $to.'/'.$self->output_file 
457                         : File::Spec->catfile( $to, $self->output_file );
458     
459     for my $method ( @{ $METHODS->{$self->scheme} } ) {
460         my $sub =  '_'.$method.'_fetch';
461
462         unless( __PACKAGE__->can($sub) ) {
463             $self->_error(loc("Cannot call method for '%1' -- WEIRD!",
464                         $method));
465             next;
466         }
467
468         ### method is blacklisted ###
469         next if grep { lc $_ eq $method } @$BLACKLIST;
470
471         ### method is known to fail ###
472         next if $METHOD_FAIL->{$method};
473
474         ### there's serious issues with IPC::Run and quoting of command
475         ### line arguments. using quotes in the wrong place breaks things,
476         ### and in the case of say, 
477         ### C:\cygwin\bin\wget.EXE --quiet --passive-ftp --output-document
478         ### "index.html" "http://www.cpan.org/index.html?q=1&y=2"
479         ### it doesn't matter how you quote, it always fails.
480         local $IPC::Cmd::USE_IPC_RUN = 0;
481         
482         if( my $file = $self->$sub( 
483                         to => $out_to
484         )){
485
486             unless( -e $file && -s _ ) {
487                 $self->_error(loc("'%1' said it fetched '%2', ".
488                      "but it was not created",$method,$file));
489
490                 ### mark the failure ###
491                 $METHOD_FAIL->{$method} = 1;
492
493                 next;
494
495             } else {
496
497                 ### slurp mode?
498                 if( ref $target and UNIVERSAL::isa( $target, 'SCALAR' ) ) {
499                     
500                     ### open the file
501                     open my $fh, $file or do {
502                         $self->_error(
503                             loc("Could not open '%1': %2", $file, $!));
504                         return;                            
505                     };
506                     
507                     ### slurp
508                     $$target = do { local $/; <$fh> };
509                 
510                 } 
511
512                 my $abs = File::Spec->rel2abs( $file );
513                 return $abs;
514
515             }
516         }
517     }
518
519
520     ### if we got here, we looped over all methods, but we weren't able
521     ### to fetch it.
522     return;
523 }
524
525 ########################
526 ### _*_fetch methods ###
527 ########################
528
529 ### LWP fetching ###
530 sub _lwp_fetch {
531     my $self = shift;
532     my %hash = @_;
533
534     my ($to);
535     my $tmpl = {
536         to  => { required => 1, store => \$to }
537     };
538     check( $tmpl, \%hash ) or return;
539
540     ### modules required to download with lwp ###
541     my $use_list = {
542         LWP                 => '0.0',
543         'LWP::UserAgent'    => '0.0',
544         'HTTP::Request'     => '0.0',
545         'HTTP::Status'      => '0.0',
546         URI                 => '0.0',
547
548     };
549
550     if( can_load(modules => $use_list) ) {
551
552         ### setup the uri object
553         my $uri = URI->new( File::Spec::Unix->catfile(
554                                     $self->path, $self->file
555                         ) );
556
557         ### special rules apply for file:// uris ###
558         $uri->scheme( $self->scheme );
559         $uri->host( $self->scheme eq 'file' ? '' : $self->host );
560         $uri->userinfo("anonymous:$FROM_EMAIL") if $self->scheme ne 'file';
561
562         ### set up the useragent object
563         my $ua = LWP::UserAgent->new();
564         $ua->timeout( $TIMEOUT ) if $TIMEOUT;
565         $ua->agent( $USER_AGENT );
566         $ua->from( $FROM_EMAIL );
567         $ua->env_proxy;
568
569         my $res = $ua->mirror($uri, $to) or return;
570
571         ### uptodate or fetched ok ###
572         if ( $res->code == 304 or $res->code == 200 ) {
573             return $to;
574
575         } else {
576             return $self->_error(loc("Fetch failed! HTTP response: %1 %2 [%3]",
577                         $res->code, HTTP::Status::status_message($res->code),
578                         $res->status_line));
579         }
580
581     } else {
582         $METHOD_FAIL->{'lwp'} = 1;
583         return;
584     }
585 }
586
587 ### Net::FTP fetching
588 sub _netftp_fetch {
589     my $self = shift;
590     my %hash = @_;
591
592     my ($to);
593     my $tmpl = {
594         to  => { required => 1, store => \$to }
595     };
596     check( $tmpl, \%hash ) or return;
597
598     ### required modules ###
599     my $use_list = { 'Net::FTP' => 0 };
600
601     if( can_load( modules => $use_list ) ) {
602
603         ### make connection ###
604         my $ftp;
605         my @options = ($self->host);
606         push(@options, Timeout => $TIMEOUT) if $TIMEOUT;
607         unless( $ftp = Net::FTP->new( @options ) ) {
608             return $self->_error(loc("Ftp creation failed: %1",$@));
609         }
610
611         ### login ###
612         unless( $ftp->login( anonymous => $FROM_EMAIL ) ) {
613             return $self->_error(loc("Could not login to '%1'",$self->host));
614         }
615
616         ### set binary mode, just in case ###
617         $ftp->binary;
618
619         ### create the remote path 
620         ### remember remote paths are unix paths! [#11483]
621         my $remote = File::Spec::Unix->catfile( $self->path, $self->file );
622
623         ### fetch the file ###
624         my $target;
625         unless( $target = $ftp->get( $remote, $to ) ) {
626             return $self->_error(loc("Could not fetch '%1' from '%2'",
627                         $remote, $self->host));
628         }
629
630         ### log out ###
631         $ftp->quit;
632
633         return $target;
634
635     } else {
636         $METHOD_FAIL->{'netftp'} = 1;
637         return;
638     }
639 }
640
641 ### /bin/wget fetch ###
642 sub _wget_fetch {
643     my $self = shift;
644     my %hash = @_;
645
646     my ($to);
647     my $tmpl = {
648         to  => { required => 1, store => \$to }
649     };
650     check( $tmpl, \%hash ) or return;
651
652     ### see if we have a wget binary ###
653     if( my $wget = can_run('wget') ) {
654
655         ### no verboseness, thanks ###
656         my $cmd = [ $wget, '--quiet' ];
657
658         ### if a timeout is set, add it ###
659         push(@$cmd, '--timeout=' . $TIMEOUT) if $TIMEOUT;
660
661         ### run passive if specified ###
662         push @$cmd, '--passive-ftp' if $FTP_PASSIVE;
663
664         ### set the output document, add the uri ###
665         push @$cmd, '--output-document', $to, $self->uri;
666
667         ### with IPC::Cmd > 0.41, this is fixed in teh library,
668         ### and there's no need for special casing any more.
669         ### DO NOT quote things for IPC::Run, it breaks stuff.
670         # $IPC::Cmd::USE_IPC_RUN
671         #    ? ($to, $self->uri)
672         #    : (QUOTE. $to .QUOTE, QUOTE. $self->uri .QUOTE);
673
674         ### shell out ###
675         my $captured;
676         unless(run( command => $cmd, 
677                     buffer  => \$captured, 
678                     verbose => $DEBUG  
679         )) {
680             ### wget creates the output document always, even if the fetch
681             ### fails.. so unlink it in that case
682             1 while unlink $to;
683             
684             return $self->_error(loc( "Command failed: %1", $captured || '' ));
685         }
686
687         return $to;
688
689     } else {
690         $METHOD_FAIL->{'wget'} = 1;
691         return;
692     }
693 }
694
695 ### /bin/lftp fetch ###
696 sub _lftp_fetch {
697     my $self = shift;
698     my %hash = @_;
699
700     my ($to);
701     my $tmpl = {
702         to  => { required => 1, store => \$to }
703     };
704     check( $tmpl, \%hash ) or return;
705
706     ### see if we have a wget binary ###
707     if( my $lftp = can_run('lftp') ) {
708
709         ### no verboseness, thanks ###
710         my $cmd = [ $lftp, '-f' ];
711
712         my $fh = File::Temp->new;
713         
714         my $str;
715         
716         ### if a timeout is set, add it ###
717         $str .= "set net:timeout $TIMEOUT;\n" if $TIMEOUT;
718
719         ### run passive if specified ###
720         $str .= "set ftp:passive-mode 1;\n" if $FTP_PASSIVE;
721
722         ### set the output document, add the uri ###
723         ### quote the URI, because lftp supports certain shell
724         ### expansions, most notably & for backgrounding.
725         ### ' quote does nto work, must be "
726         $str .= q[get ']. $self->uri .q[' -o ]. $to . $/;
727
728         if( $DEBUG ) {
729             my $pp_str = join ' ', split $/, $str;
730             print "# lftp command: $pp_str\n";
731         }              
732
733         ### write straight to the file.
734         $fh->autoflush(1);
735         print $fh $str;
736
737         ### the command needs to be 1 string to be executed
738         push @$cmd, $fh->filename;
739
740         ### with IPC::Cmd > 0.41, this is fixed in teh library,
741         ### and there's no need for special casing any more.
742         ### DO NOT quote things for IPC::Run, it breaks stuff.
743         # $IPC::Cmd::USE_IPC_RUN
744         #    ? ($to, $self->uri)
745         #    : (QUOTE. $to .QUOTE, QUOTE. $self->uri .QUOTE);
746
747
748         ### shell out ###
749         my $captured;
750         unless(run( command => $cmd,
751                     buffer  => \$captured,
752                     verbose => $DEBUG
753         )) {
754             ### wget creates the output document always, even if the fetch
755             ### fails.. so unlink it in that case
756             1 while unlink $to;
757
758             return $self->_error(loc( "Command failed: %1", $captured || '' ));
759         }
760
761         return $to;
762
763     } else {
764         $METHOD_FAIL->{'lftp'} = 1;
765         return;
766     }
767 }
768
769
770
771 ### /bin/ftp fetch ###
772 sub _ftp_fetch {
773     my $self = shift;
774     my %hash = @_;
775
776     my ($to);
777     my $tmpl = {
778         to  => { required => 1, store => \$to }
779     };
780     check( $tmpl, \%hash ) or return;
781
782     ### see if we have a ftp binary ###
783     if( my $ftp = can_run('ftp') ) {
784
785         my $fh = FileHandle->new;
786
787         local $SIG{CHLD} = 'IGNORE';
788
789         unless ($fh->open("|$ftp -n")) {
790             return $self->_error(loc("%1 creation failed: %2", $ftp, $!));
791         }
792
793         my @dialog = (
794             "lcd " . dirname($to),
795             "open " . $self->host,
796             "user anonymous $FROM_EMAIL",
797             "cd /",
798             "cd " . $self->path,
799             "binary",
800             "get " . $self->file . " " . $self->output_file,
801             "quit",
802         );
803
804         foreach (@dialog) { $fh->print($_, "\n") }
805         $fh->close or return;
806
807         return $to;
808     }
809 }
810
811 ### lynx is stupid - it decompresses any .gz file it finds to be text
812 ### use /bin/lynx to fetch files
813 sub _lynx_fetch {
814     my $self = shift;
815     my %hash = @_;
816
817     my ($to);
818     my $tmpl = {
819         to  => { required => 1, store => \$to }
820     };
821     check( $tmpl, \%hash ) or return;
822
823     ### see if we have a lynx binary ###
824     if( my $lynx = can_run('lynx') ) {
825
826         unless( IPC::Cmd->can_capture_buffer ) {
827             $METHOD_FAIL->{'lynx'} = 1;
828
829             return $self->_error(loc( 
830                 "Can not capture buffers. Can not use '%1' to fetch files",
831                 'lynx' ));
832         }            
833
834         ### check if the HTTP resource exists ###
835         if ($self->uri =~ /^https?:\/\//i) {
836             my $cmd = [
837                 $lynx,
838                 '-head',
839                 '-source',
840                 "-auth=anonymous:$FROM_EMAIL",
841             ];
842
843             push @$cmd, "-connect_timeout=$TIMEOUT" if $TIMEOUT;
844
845             push @$cmd, $self->uri;
846
847             ### shell out ###
848             my $head;
849             unless(run( command => $cmd,
850                         buffer  => \$head,
851                         verbose => $DEBUG )
852             ) {
853                 return $self->_error(loc("Command failed: %1", $head || ''));
854             }
855
856             unless($head =~ /^HTTP\/\d+\.\d+ 200\b/) {
857                 return $self->_error(loc("Command failed: %1", $head || ''));
858             }
859         }
860
861         ### write to the output file ourselves, since lynx ass_u_mes to much
862         my $local = FileHandle->new(">$to")
863                         or return $self->_error(loc(
864                             "Could not open '%1' for writing: %2",$to,$!));
865
866         ### dump to stdout ###
867         my $cmd = [
868             $lynx,
869             '-source',
870             "-auth=anonymous:$FROM_EMAIL",
871         ];
872
873         push @$cmd, "-connect_timeout=$TIMEOUT" if $TIMEOUT;
874
875         ### DO NOT quote things for IPC::Run, it breaks stuff.
876         push @$cmd, $self->uri;
877         
878         ### with IPC::Cmd > 0.41, this is fixed in teh library,
879         ### and there's no need for special casing any more.
880         ### DO NOT quote things for IPC::Run, it breaks stuff.
881         # $IPC::Cmd::USE_IPC_RUN
882         #    ? $self->uri
883         #    : QUOTE. $self->uri .QUOTE;
884
885
886         ### shell out ###
887         my $captured;
888         unless(run( command => $cmd,
889                     buffer  => \$captured,
890                     verbose => $DEBUG )
891         ) {
892             return $self->_error(loc("Command failed: %1", $captured || ''));
893         }
894
895         ### print to local file ###
896         ### XXX on a 404 with a special error page, $captured will actually
897         ### hold the contents of that page, and make it *appear* like the
898         ### request was a success, when really it wasn't :(
899         ### there doesn't seem to be an option for lynx to change the exit
900         ### code based on a 4XX status or so.
901         ### the closest we can come is using --error_file and parsing that,
902         ### which is very unreliable ;(
903         $local->print( $captured );
904         $local->close or return;
905
906         return $to;
907
908     } else {
909         $METHOD_FAIL->{'lynx'} = 1;
910         return;
911     }
912 }
913
914 ### use /bin/ncftp to fetch files
915 sub _ncftp_fetch {
916     my $self = shift;
917     my %hash = @_;
918
919     my ($to);
920     my $tmpl = {
921         to  => { required => 1, store => \$to }
922     };
923     check( $tmpl, \%hash ) or return;
924
925     ### we can only set passive mode in interactive sesssions, so bail out
926     ### if $FTP_PASSIVE is set
927     return if $FTP_PASSIVE;
928
929     ### see if we have a ncftp binary ###
930     if( my $ncftp = can_run('ncftp') ) {
931
932         my $cmd = [
933             $ncftp,
934             '-V',                   # do not be verbose
935             '-p', $FROM_EMAIL,      # email as password
936             $self->host,            # hostname
937             dirname($to),           # local dir for the file
938                                     # remote path to the file
939             ### DO NOT quote things for IPC::Run, it breaks stuff.
940             $IPC::Cmd::USE_IPC_RUN
941                         ? File::Spec::Unix->catdir( $self->path, $self->file )
942                         : QUOTE. File::Spec::Unix->catdir( 
943                                         $self->path, $self->file ) .QUOTE
944             
945         ];
946
947         ### shell out ###
948         my $captured;
949         unless(run( command => $cmd,
950                     buffer  => \$captured,
951                     verbose => $DEBUG )
952         ) {
953             return $self->_error(loc("Command failed: %1", $captured || ''));
954         }
955
956         return $to;
957
958     } else {
959         $METHOD_FAIL->{'ncftp'} = 1;
960         return;
961     }
962 }
963
964 ### use /bin/curl to fetch files
965 sub _curl_fetch {
966     my $self = shift;
967     my %hash = @_;
968
969     my ($to);
970     my $tmpl = {
971         to  => { required => 1, store => \$to }
972     };
973     check( $tmpl, \%hash ) or return;
974
975     if (my $curl = can_run('curl')) {
976
977         ### these long opts are self explanatory - I like that -jmb
978             my $cmd = [ $curl, '-q' ];
979
980             push(@$cmd, '--connect-timeout', $TIMEOUT) if $TIMEOUT;
981
982             push(@$cmd, '--silent') unless $DEBUG;
983
984         ### curl does the right thing with passive, regardless ###
985         if ($self->scheme eq 'ftp') {
986                 push(@$cmd, '--user', "anonymous:$FROM_EMAIL");
987         }
988
989         ### curl doesn't follow 302 (temporarily moved) etc automatically
990         ### so we add --location to enable that.
991         push @$cmd, '--fail', '--location', '--output', $to, $self->uri;
992
993         ### with IPC::Cmd > 0.41, this is fixed in teh library,
994         ### and there's no need for special casing any more.
995         ### DO NOT quote things for IPC::Run, it breaks stuff.
996         # $IPC::Cmd::USE_IPC_RUN
997         #    ? ($to, $self->uri)
998         #    : (QUOTE. $to .QUOTE, QUOTE. $self->uri .QUOTE);
999
1000
1001         my $captured;
1002         unless(run( command => $cmd,
1003                     buffer  => \$captured,
1004                     verbose => $DEBUG )
1005         ) {
1006
1007             return $self->_error(loc("Command failed: %1", $captured || ''));
1008         }
1009
1010         return $to;
1011
1012     } else {
1013         $METHOD_FAIL->{'curl'} = 1;
1014         return;
1015     }
1016 }
1017
1018
1019 ### use File::Copy for fetching file:// urls ###
1020 ###
1021 ### See section 3.10 of RFC 1738 (http://www.faqs.org/rfcs/rfc1738.html)
1022 ### Also see wikipedia on file:// (http://en.wikipedia.org/wiki/File://)
1023 ###
1024     
1025 sub _file_fetch {
1026     my $self = shift;
1027     my %hash = @_;
1028
1029     my ($to);
1030     my $tmpl = {
1031         to  => { required => 1, store => \$to }
1032     };
1033     check( $tmpl, \%hash ) or return;
1034
1035     
1036     
1037     ### prefix a / on unix systems with a file uri, since it would
1038     ### look somewhat like this:
1039     ###     file:///home/kane/file
1040     ### wheras windows file uris for 'c:\some\dir\file' might look like:
1041     ###     file:///C:/some/dir/file
1042     ###     file:///C|/some/dir/file
1043     ### or for a network share '\\host\share\some\dir\file':
1044     ###     file:////host/share/some/dir/file
1045     ###    
1046     ### VMS file uri's for 'DISK$USER:[MY.NOTES]NOTE123456.TXT' might look like:
1047     ###     file://vms.host.edu/disk$user/my/notes/note12345.txt
1048     ###
1049     
1050     my $path    = $self->path;
1051     my $vol     = $self->vol;
1052     my $share   = $self->share;
1053
1054     my $remote;
1055     if (!$share and $self->host) {
1056         return $self->_error(loc( 
1057             "Currently %1 cannot handle hosts in %2 urls",
1058             'File::Fetch', 'file://'
1059         ));            
1060     }
1061     
1062     if( $vol ) {
1063         $path   = File::Spec->catdir( split /\//, $path );
1064         $remote = File::Spec->catpath( $vol, $path, $self->file);
1065
1066     } elsif( $share ) {
1067         ### win32 specific, and a share name, so we wont bother with File::Spec
1068         $path   =~ s|/+|\\|g;
1069         $remote = "\\\\".$self->host."\\$share\\$path";
1070
1071     } else {
1072         ### File::Spec on VMS can not currently handle UNIX syntax.
1073         my $file_class = ON_VMS
1074             ? 'File::Spec::Unix'
1075             : 'File::Spec';
1076
1077         $remote  = $file_class->catfile( $path, $self->file );
1078     }
1079
1080     ### File::Copy is littered with 'die' statements :( ###
1081     my $rv = eval { File::Copy::copy( $remote, $to ) };
1082
1083     ### something went wrong ###
1084     if( !$rv or $@ ) {
1085         return $self->_error(loc("Could not copy '%1' to '%2': %3 %4",
1086                              $remote, $to, $!, $@));
1087     }
1088
1089     return $to;
1090 }
1091
1092 ### use /usr/bin/rsync to fetch files
1093 sub _rsync_fetch {
1094     my $self = shift;
1095     my %hash = @_;
1096
1097     my ($to);
1098     my $tmpl = {
1099         to  => { required => 1, store => \$to }
1100     };
1101     check( $tmpl, \%hash ) or return;
1102
1103     if (my $rsync = can_run('rsync')) {
1104
1105         my $cmd = [ $rsync ];
1106
1107         ### XXX: rsync has no I/O timeouts at all, by default
1108         push(@$cmd, '--timeout=' . $TIMEOUT) if $TIMEOUT;
1109
1110         push(@$cmd, '--quiet') unless $DEBUG;
1111
1112         ### DO NOT quote things for IPC::Run, it breaks stuff.
1113         push @$cmd, $self->uri, $to;
1114
1115         ### with IPC::Cmd > 0.41, this is fixed in teh library,
1116         ### and there's no need for special casing any more.
1117         ### DO NOT quote things for IPC::Run, it breaks stuff.
1118         # $IPC::Cmd::USE_IPC_RUN
1119         #    ? ($to, $self->uri)
1120         #    : (QUOTE. $to .QUOTE, QUOTE. $self->uri .QUOTE);
1121
1122         my $captured;
1123         unless(run( command => $cmd,
1124                     buffer  => \$captured,
1125                     verbose => $DEBUG )
1126         ) {
1127
1128             return $self->_error(loc("Command %1 failed: %2", 
1129                 "@$cmd" || '', $captured || ''));
1130         }
1131
1132         return $to;
1133
1134     } else {
1135         $METHOD_FAIL->{'rsync'} = 1;
1136         return;
1137     }
1138 }
1139
1140 #################################
1141 #
1142 # Error code
1143 #
1144 #################################
1145
1146 =pod
1147
1148 =head2 $ff->error([BOOL])
1149
1150 Returns the last encountered error as string.
1151 Pass it a true value to get the C<Carp::longmess()> output instead.
1152
1153 =cut
1154
1155 ### error handling the way Archive::Extract does it
1156 sub _error {
1157     my $self    = shift;
1158     my $error   = shift;
1159     
1160     $self->_error_msg( $error );
1161     $self->_error_msg_long( Carp::longmess($error) );
1162     
1163     if( $WARN ) {
1164         carp $DEBUG ? $self->_error_msg_long : $self->_error_msg;
1165     }
1166
1167     return;
1168 }
1169
1170 sub error {
1171     my $self = shift;
1172     return shift() ? $self->_error_msg_long : $self->_error_msg;
1173 }
1174
1175
1176 1;
1177
1178 =pod
1179
1180 =head1 HOW IT WORKS
1181
1182 File::Fetch is able to fetch a variety of uris, by using several
1183 external programs and modules.
1184
1185 Below is a mapping of what utilities will be used in what order
1186 for what schemes, if available:
1187
1188     file    => LWP, lftp, file
1189     http    => LWP, wget, curl, lftp, lynx
1190     ftp     => LWP, Net::FTP, wget, curl, lftp, ncftp, ftp
1191     rsync   => rsync
1192
1193 If you'd like to disable the use of one or more of these utilities
1194 and/or modules, see the C<$BLACKLIST> variable further down.
1195
1196 If a utility or module isn't available, it will be marked in a cache
1197 (see the C<$METHOD_FAIL> variable further down), so it will not be
1198 tried again. The C<fetch> method will only fail when all options are
1199 exhausted, and it was not able to retrieve the file.
1200
1201 A special note about fetching files from an ftp uri:
1202
1203 By default, all ftp connections are done in passive mode. To change
1204 that, see the C<$FTP_PASSIVE> variable further down.
1205
1206 Furthermore, ftp uris only support anonymous connections, so no
1207 named user/password pair can be passed along.
1208
1209 C</bin/ftp> is blacklisted by default; see the C<$BLACKLIST> variable
1210 further down.
1211
1212 =head1 GLOBAL VARIABLES
1213
1214 The behaviour of File::Fetch can be altered by changing the following
1215 global variables:
1216
1217 =head2 $File::Fetch::FROM_EMAIL
1218
1219 This is the email address that will be sent as your anonymous ftp
1220 password.
1221
1222 Default is C<File-Fetch@example.com>.
1223
1224 =head2 $File::Fetch::USER_AGENT
1225
1226 This is the useragent as C<LWP> will report it.
1227
1228 Default is C<File::Fetch/$VERSION>.
1229
1230 =head2 $File::Fetch::FTP_PASSIVE
1231
1232 This variable controls whether the environment variable C<FTP_PASSIVE>
1233 and any passive switches to commandline tools will be set to true.
1234
1235 Default value is 1.
1236
1237 Note: When $FTP_PASSIVE is true, C<ncftp> will not be used to fetch
1238 files, since passive mode can only be set interactively for this binary
1239
1240 =head2 $File::Fetch::TIMEOUT
1241
1242 When set, controls the network timeout (counted in seconds).
1243
1244 Default value is 0.
1245
1246 =head2 $File::Fetch::WARN
1247
1248 This variable controls whether errors encountered internally by
1249 C<File::Fetch> should be C<carp>'d or not.
1250
1251 Set to false to silence warnings. Inspect the output of the C<error()>
1252 method manually to see what went wrong.
1253
1254 Defaults to C<true>.
1255
1256 =head2 $File::Fetch::DEBUG
1257
1258 This enables debugging output when calling commandline utilities to
1259 fetch files.
1260 This also enables C<Carp::longmess> errors, instead of the regular
1261 C<carp> errors.
1262
1263 Good for tracking down why things don't work with your particular
1264 setup.
1265
1266 Default is 0.
1267
1268 =head2 $File::Fetch::BLACKLIST
1269
1270 This is an array ref holding blacklisted modules/utilities for fetching
1271 files with.
1272
1273 To disallow the use of, for example, C<LWP> and C<Net::FTP>, you could
1274 set $File::Fetch::BLACKLIST to:
1275
1276     $File::Fetch::BLACKLIST = [qw|lwp netftp|]
1277
1278 The default blacklist is [qw|ftp|], as C</bin/ftp> is rather unreliable.
1279
1280 See the note on C<MAPPING> below.
1281
1282 =head2 $File::Fetch::METHOD_FAIL
1283
1284 This is a hashref registering what modules/utilities were known to fail
1285 for fetching files (mostly because they weren't installed).
1286
1287 You can reset this cache by assigning an empty hashref to it, or
1288 individually remove keys.
1289
1290 See the note on C<MAPPING> below.
1291
1292 =head1 MAPPING
1293
1294
1295 Here's a quick mapping for the utilities/modules, and their names for
1296 the $BLACKLIST, $METHOD_FAIL and other internal functions.
1297
1298     LWP         => lwp
1299     Net::FTP    => netftp
1300     wget        => wget
1301     lynx        => lynx
1302     ncftp       => ncftp
1303     ftp         => ftp
1304     curl        => curl
1305     rsync       => rsync
1306     lftp        => lftp
1307
1308 =head1 FREQUENTLY ASKED QUESTIONS
1309
1310 =head2 So how do I use a proxy with File::Fetch?
1311
1312 C<File::Fetch> currently only supports proxies with LWP::UserAgent.
1313 You will need to set your environment variables accordingly. For
1314 example, to use an ftp proxy:
1315
1316     $ENV{ftp_proxy} = 'foo.com';
1317
1318 Refer to the LWP::UserAgent manpage for more details.
1319
1320 =head2 I used 'lynx' to fetch a file, but its contents is all wrong!
1321
1322 C<lynx> can only fetch remote files by dumping its contents to C<STDOUT>,
1323 which we in turn capture. If that content is a 'custom' error file
1324 (like, say, a C<404 handler>), you will get that contents instead.
1325
1326 Sadly, C<lynx> doesn't support any options to return a different exit
1327 code on non-C<200 OK> status, giving us no way to tell the difference
1328 between a 'successfull' fetch and a custom error page.
1329
1330 Therefor, we recommend to only use C<lynx> as a last resort. This is 
1331 why it is at the back of our list of methods to try as well.
1332
1333 =head2 Files I'm trying to fetch have reserved characters or non-ASCII characters in them. What do I do?
1334
1335 C<File::Fetch> is relatively smart about things. When trying to write 
1336 a file to disk, it removes the C<query parameters> (see the 
1337 C<output_file> method for details) from the file name before creating
1338 it. In most cases this suffices.
1339
1340 If you have any other characters you need to escape, please install 
1341 the C<URI::Escape> module from CPAN, and pre-encode your URI before
1342 passing it to C<File::Fetch>. You can read about the details of URIs 
1343 and URI encoding here:
1344
1345   http://www.faqs.org/rfcs/rfc2396.html
1346
1347 =head1 TODO
1348
1349 =over 4
1350
1351 =item Implement $PREFER_BIN
1352
1353 To indicate to rather use commandline tools than modules
1354
1355 =back
1356
1357 =head1 BUG REPORTS
1358
1359 Please report bugs or other issues to E<lt>bug-file-fetch@rt.cpan.org<gt>.
1360
1361 =head1 AUTHOR
1362
1363 This module by Jos Boumans E<lt>kane@cpan.orgE<gt>.
1364
1365 =head1 COPYRIGHT
1366
1367 This library is free software; you may redistribute and/or modify it 
1368 under the same terms as Perl itself.
1369
1370
1371 =cut
1372
1373 # Local variables:
1374 # c-indentation-style: bsd
1375 # c-basic-offset: 4
1376 # indent-tabs-mode: nil
1377 # End:
1378 # vim: expandtab shiftwidth=4:
1379
1380
1381
1382