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