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