Commit | Line | Data |
---|---|---|
79fd8837 JB |
1 | package File::Fetch; |
2 | ||
3 | use strict; | |
4 | use FileHandle; | |
5 | use File::Copy; | |
6 | use File::Spec; | |
7 | use File::Spec::Unix; | |
79fd8837 JB |
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 | ||
d4b3706f RGS |
23 | use constant QUOTE => do { $^O eq 'MSWin32' ? q["] : q['] }; |
24 | ||
25 | ||
26 | $VERSION = '0.10'; | |
79fd8837 JB |
27 | $PREFER_BIN = 0; # XXX TODO implement |
28 | $FROM_EMAIL = 'File-Fetch@example.com'; | |
29 | $USER_AGENT = 'File::Fetch/$VERSION'; | |
30 | $BLACKLIST = [qw|ftp|]; | |
31 | $METHOD_FAIL = { }; | |
32 | $FTP_PASSIVE = 1; | |
33 | $TIMEOUT = 0; | |
34 | $DEBUG = 0; | |
35 | $WARN = 1; | |
36 | ||
37 | ### methods available to fetch the file depending on the scheme | |
38 | $METHODS = { | |
39 | http => [ qw|lwp wget curl lynx| ], | |
40 | ftp => [ qw|lwp netftp wget curl ncftp ftp| ], | |
41 | file => [ qw|lwp file| ], | |
42 | rsync => [ qw|rsync| ] | |
43 | }; | |
44 | ||
45 | ### silly warnings ### | |
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' and | |
54 | $^O ne 'VMS'); | |
55 | ||
56 | =pod | |
57 | ||
58 | =head1 NAME | |
59 | ||
60 | File::Fetch - A generic file fetching mechanism | |
61 | ||
62 | =head1 SYNOPSIS | |
63 | ||
64 | use File::Fetch; | |
65 | ||
66 | ### build a File::Fetch object ### | |
67 | my $ff = File::Fetch->new(uri => 'http://some.where.com/dir/a.txt'); | |
68 | ||
69 | ### fetch the uri to cwd() ### | |
70 | my $where = $ff->fetch() or die $ff->error; | |
71 | ||
72 | ### fetch the uri to /tmp ### | |
73 | my $where = $ff->fetch( to => '/tmp' ); | |
74 | ||
75 | ### parsed bits from the uri ### | |
76 | $ff->uri; | |
77 | $ff->scheme; | |
78 | $ff->host; | |
79 | $ff->path; | |
80 | $ff->file; | |
81 | ||
82 | =head1 DESCRIPTION | |
83 | ||
84 | File::Fetch is a generic file fetching mechanism. | |
85 | ||
86 | It allows you to fetch any file pointed to by a C<ftp>, C<http>, | |
87 | C<file>, or C<rsync> uri by a number of different means. | |
88 | ||
89 | See the C<HOW IT WORKS> section further down for details. | |
90 | ||
d4b3706f RGS |
91 | =head1 ACCESSORS |
92 | ||
93 | A C<File::Fetch> object has the following accessors | |
94 | ||
95 | =over 4 | |
96 | ||
97 | =item $ff->uri | |
98 | ||
99 | The uri you passed to the constructor | |
100 | ||
101 | =item $ff->scheme | |
102 | ||
103 | The scheme from the uri (like 'file', 'http', etc) | |
104 | ||
105 | =item $ff->host | |
106 | ||
107 | The hostname in the uri, will be empty for a 'file' scheme. | |
108 | ||
109 | =item $ff->path | |
110 | ||
111 | The path from the uri, will be at least a single '/'. | |
112 | ||
113 | =item $ff->file | |
114 | ||
115 | The name of the remote file. For the local file name, the | |
116 | result of $ff->output_file will be used. | |
117 | ||
118 | =cut | |
119 | ||
120 | ||
121 | ########################## | |
122 | ### Object & Accessors ### | |
123 | ########################## | |
124 | ||
125 | { | |
126 | ### template for new() and autogenerated accessors ### | |
127 | my $Tmpl = { | |
128 | scheme => { default => 'http' }, | |
129 | host => { default => 'localhost' }, | |
130 | path => { default => '/' }, | |
131 | file => { required => 1 }, | |
132 | uri => { required => 1 }, | |
133 | _error_msg => { no_override => 1 }, | |
134 | _error_msg_long => { no_override => 1 }, | |
135 | }; | |
136 | ||
137 | for my $method ( keys %$Tmpl ) { | |
138 | no strict 'refs'; | |
139 | *$method = sub { | |
140 | my $self = shift; | |
141 | $self->{$method} = $_[0] if @_; | |
142 | return $self->{$method}; | |
143 | } | |
144 | } | |
145 | ||
146 | sub _create { | |
147 | my $class = shift; | |
148 | my %hash = @_; | |
149 | ||
150 | my $args = check( $Tmpl, \%hash ) or return; | |
151 | ||
152 | bless $args, $class; | |
153 | ||
154 | if( lc($args->scheme) ne 'file' and not $args->host ) { | |
155 | return File::Fetch->_error(loc( | |
156 | "Hostname required when fetching from '%1'",$args->scheme)); | |
157 | } | |
158 | ||
159 | for (qw[path file]) { | |
160 | unless( $args->$_ ) { | |
161 | return File::Fetch->_error(loc("No '%1' specified",$_)); | |
162 | } | |
163 | } | |
164 | ||
165 | return $args; | |
166 | } | |
167 | } | |
168 | ||
169 | =item $ff->output_file | |
170 | ||
171 | The name of the output file. This is the same as $ff->file, | |
172 | but any query parameters are stripped off. For example: | |
173 | ||
174 | http://example.com/index.html?x=y | |
175 | ||
176 | would make the output file be C<index.html> rather than | |
177 | C<index.html?x=y>. | |
178 | ||
179 | =back | |
180 | ||
181 | =cut | |
182 | ||
183 | sub output_file { | |
184 | my $self = shift; | |
185 | my $file = $self->file; | |
186 | ||
187 | $file =~ s/\?.*$//g; | |
188 | ||
189 | return $file; | |
190 | } | |
191 | ||
192 | ### XXX do this or just point to URI::Escape? | |
193 | # =head2 $esc_uri = $ff->escaped_uri | |
194 | # | |
195 | # =cut | |
196 | # | |
197 | # ### most of this is stolen straight from URI::escape | |
198 | # { ### Build a char->hex map | |
199 | # my %escapes = map { chr($_) => sprintf("%%%02X", $_) } 0..255; | |
200 | # | |
201 | # sub escaped_uri { | |
202 | # my $self = shift; | |
203 | # my $uri = $self->uri; | |
204 | # | |
205 | # ### Default unsafe characters. RFC 2732 ^(uric - reserved) | |
206 | # $uri =~ s/([^A-Za-z0-9\-_.!~*'()])/ | |
207 | # $escapes{$1} || $self->_fail_hi($1)/ge; | |
208 | # | |
209 | # return $uri; | |
210 | # } | |
211 | # | |
212 | # sub _fail_hi { | |
213 | # my $self = shift; | |
214 | # my $char = shift; | |
215 | # | |
216 | # $self->_error(loc( | |
217 | # "Can't escape '%1', try using the '%2' module instead", | |
218 | # sprintf("\\x{%04X}", ord($char)), 'URI::Escape' | |
219 | # )); | |
220 | # } | |
221 | # | |
222 | # sub output_file { | |
223 | # | |
224 | # } | |
225 | # | |
226 | # | |
227 | # } | |
228 | ||
79fd8837 JB |
229 | =head1 METHODS |
230 | ||
231 | =head2 $ff = File::Fetch->new( uri => 'http://some.where.com/dir/file.txt' ); | |
232 | ||
233 | Parses the uri and creates a corresponding File::Fetch::Item object, | |
234 | that is ready to be C<fetch>ed and returns it. | |
235 | ||
236 | Returns false on failure. | |
237 | ||
238 | =cut | |
239 | ||
240 | sub new { | |
241 | my $class = shift; | |
242 | my %hash = @_; | |
243 | ||
244 | my ($uri); | |
245 | my $tmpl = { | |
246 | uri => { required => 1, store => \$uri }, | |
247 | }; | |
248 | ||
249 | check( $tmpl, \%hash ) or return; | |
250 | ||
251 | ### parse the uri to usable parts ### | |
252 | my $href = __PACKAGE__->_parse_uri( $uri ) or return; | |
253 | ||
254 | ### make it into a FFI object ### | |
d4b3706f | 255 | my $ff = File::Fetch->_create( %$href ) or return; |
79fd8837 JB |
256 | |
257 | ||
258 | ### return the object ### | |
d4b3706f | 259 | return $ff; |
79fd8837 JB |
260 | } |
261 | ||
262 | ### parses an uri to a hash structure: | |
263 | ### | |
264 | ### $class->_parse_uri( 'ftp://ftp.cpan.org/pub/mirror/index.txt' ) | |
265 | ### | |
266 | ### becomes: | |
267 | ### | |
268 | ### $href = { | |
269 | ### scheme => 'ftp', | |
270 | ### host => 'ftp.cpan.org', | |
271 | ### path => '/pub/mirror', | |
272 | ### file => 'index.html' | |
273 | ### }; | |
274 | ### | |
275 | sub _parse_uri { | |
276 | my $self = shift; | |
277 | my $uri = shift or return; | |
278 | ||
279 | my $href = { uri => $uri }; | |
280 | ||
281 | ### find the scheme ### | |
282 | $uri =~ s|^(\w+)://||; | |
283 | $href->{scheme} = $1; | |
284 | ||
285 | ### file:// paths have no host ### | |
286 | if( $href->{scheme} eq 'file' ) { | |
287 | $href->{path} = $uri; | |
288 | $href->{host} = ''; | |
289 | ||
290 | } else { | |
291 | @{$href}{qw|host path|} = $uri =~ m|([^/]*)(/.*)$|s; | |
292 | } | |
293 | ||
294 | ### split the path into file + dir ### | |
295 | { my @parts = File::Spec::Unix->splitpath( delete $href->{path} ); | |
296 | $href->{path} = $parts[1]; | |
297 | $href->{file} = $parts[2]; | |
298 | } | |
299 | ||
300 | ||
301 | return $href; | |
302 | } | |
303 | ||
304 | =head2 $ff->fetch( [to => /my/output/dir/] ) | |
305 | ||
306 | Fetches the file you requested. By default it writes to C<cwd()>, | |
307 | but you can override that by specifying the C<to> argument. | |
308 | ||
309 | Returns the full path to the downloaded file on success, and false | |
310 | on failure. | |
311 | ||
312 | =cut | |
313 | ||
314 | sub fetch { | |
315 | my $self = shift or return; | |
316 | my %hash = @_; | |
317 | ||
318 | my $to; | |
319 | my $tmpl = { | |
320 | to => { default => cwd(), store => \$to }, | |
321 | }; | |
322 | ||
323 | check( $tmpl, \%hash ) or return; | |
324 | ||
325 | ### create the path if it doesn't exist yet ### | |
326 | unless( -d $to ) { | |
327 | eval { mkpath( $to ) }; | |
328 | ||
329 | return $self->_error(loc("Could not create path '%1'",$to)) if $@; | |
330 | } | |
331 | ||
332 | ### set passive ftp if required ### | |
333 | local $ENV{FTP_PASSIVE} = $FTP_PASSIVE; | |
334 | ||
335 | ### | |
336 | for my $method ( @{ $METHODS->{$self->scheme} } ) { | |
337 | my $sub = '_'.$method.'_fetch'; | |
338 | ||
339 | unless( __PACKAGE__->can($sub) ) { | |
340 | $self->_error(loc("Cannot call method for '%1' -- WEIRD!", | |
341 | $method)); | |
342 | next; | |
343 | } | |
344 | ||
345 | ### method is blacklisted ### | |
346 | next if grep { lc $_ eq $method } @$BLACKLIST; | |
347 | ||
348 | ### method is known to fail ### | |
349 | next if $METHOD_FAIL->{$method}; | |
350 | ||
d4b3706f RGS |
351 | ### there's serious issues with IPC::Run and quoting of command |
352 | ### line arguments. using quotes in the wrong place breaks things, | |
353 | ### and in the case of say, | |
354 | ### C:\cygwin\bin\wget.EXE --quiet --passive-ftp --output-document | |
355 | ### "index.html" "http://www.cpan.org/index.html?q=1&y=2" | |
356 | ### it doesn't matter how you quote, it always fails. | |
357 | local $IPC::Cmd::USE_IPC_RUN = 0; | |
358 | ||
359 | if( my $file = $self->$sub( | |
360 | to => File::Spec->catfile( $to, $self->output_file ) | |
361 | )){ | |
79fd8837 JB |
362 | |
363 | unless( -e $file && -s _ ) { | |
364 | $self->_error(loc("'%1' said it fetched '%2', ". | |
365 | "but it was not created",$method,$file)); | |
366 | ||
367 | ### mark the failure ### | |
368 | $METHOD_FAIL->{$method} = 1; | |
369 | ||
370 | next; | |
371 | ||
372 | } else { | |
373 | ||
374 | my $abs = File::Spec->rel2abs( $file ); | |
375 | return $abs; | |
376 | } | |
377 | } | |
378 | } | |
379 | ||
380 | ||
381 | ### if we got here, we looped over all methods, but we weren't able | |
382 | ### to fetch it. | |
383 | return; | |
384 | } | |
385 | ||
79fd8837 JB |
386 | ######################## |
387 | ### _*_fetch methods ### | |
388 | ######################## | |
389 | ||
390 | ### LWP fetching ### | |
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 ### | |
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 ### | |
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 | ||
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 | |
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 | ||
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 | |
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 | ||
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 | |
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. | |
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 | |
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 | ||
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 | ||
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 | ||
d4b3706f RGS |
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; | |
79fd8837 JB |
867 | } |
868 | ||
d4b3706f | 869 | return; |
79fd8837 JB |
870 | } |
871 | ||
d4b3706f RGS |
872 | sub error { |
873 | my $self = shift; | |
874 | return shift() ? $self->_error_msg_long : $self->_error_msg; | |
875 | } | |
79fd8837 JB |
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 | ||
d4b3706f RGS |
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 | ||
79fd8837 JB |
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 | =head1 AUTHORS | |
1057 | ||
d4b3706f | 1058 | This module by Jos Boumans E<lt>kane@cpan.orgE<gt>. |
79fd8837 JB |
1059 | |
1060 | =head1 COPYRIGHT | |
1061 | ||
d4b3706f RGS |
1062 | This module is copyright (c) 2003-2007 Jos Boumans |
1063 | E<lt>kane@cpan.orgE<gt>. All rights reserved. | |
79fd8837 JB |
1064 | |
1065 | This library is free software; | |
1066 | you may redistribute and/or modify it under the same | |
1067 | terms as Perl itself. | |
1068 | ||
1069 | =cut | |
1070 | ||
1071 | # Local variables: | |
1072 | # c-indentation-style: bsd | |
1073 | # c-basic-offset: 4 | |
1074 | # indent-tabs-mode: nil | |
1075 | # End: | |
1076 | # vim: expandtab shiftwidth=4: | |
1077 | ||
1078 | ||
1079 | ||
1080 |