vcs.maemo.org Git - pkg-perl/blob - deb-src/libalien-wxwidgets-perl/libalien-wxwidgets-perl-0.50/inc/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.10';
  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
  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
 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 ###
 255     my $ff      = File::Fetch->_create( %$href ) or return;
 256
 257
 258     ### return the object ###
 259     return $ff;
 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
 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         )){
 362
 363             unless( -e $file && -s _ ) {
 364                 $self->_error(loc("'%1' said it fetched '%2', ".
 365                      "but it was not created",$method,$file));
 366
 367                 ### mark the failure ###
 368                 $METHOD_FAIL->{$method} = 1;
 369
 370                 next;
 371
 372             } else {
 373
 374                 my $abs = File::Spec->rel2abs( $file );
 375                 return $abs;
 376             }
 377         }
 378     }
 379
 380
 381     ### if we got here, we looped over all methods, but we weren't able
 382     ### to fetch it.
 383     return;
 384 }
 385
 386 ########################
 387 ### _*_fetch methods ###
 388 ########################
 389
 390 ### LWP fetching ###
 391 sub _lwp_fetch {
 392     my $self = shift;
 393     my %hash = @_;
 394
 395     my ($to);
 396     my $tmpl = {
 397         to  => { required => 1, store => \$to }
 398     };
 399     check( $tmpl, \%hash ) or return;
 400
 401     ### modules required to download with lwp ###
 402     my $use_list = {
 403         LWP                 => '0.0',
 404         'LWP::UserAgent'    => '0.0',
 405         'HTTP::Request'     => '0.0',
 406         'HTTP::Status'      => '0.0',
 407         URI                 => '0.0',
 408
 409     };
 410
 411     if( can_load(modules => $use_list) ) {
 412
 413         ### setup the uri object
 414         my $uri = URI->new( File::Spec::Unix->catfile(
 415                                     $self->path, $self->file
 416                         ) );
 417
 418         ### special rules apply for file:// uris ###
 419         $uri->scheme( $self->scheme );
 420         $uri->host( $self->scheme eq 'file' ? '' : $self->host );
 421         $uri->userinfo("anonymous:$FROM_EMAIL") if $self->scheme ne 'file';
 422
 423         ### set up the useragent object
 424         my $ua = LWP::UserAgent->new();
 425         $ua->timeout( $TIMEOUT ) if $TIMEOUT;
 426         $ua->agent( $USER_AGENT );
 427         $ua->from( $FROM_EMAIL );
 428         $ua->env_proxy;
 429
 430         my $res = $ua->mirror($uri, $to) or return;
 431
 432         ### uptodate or fetched ok ###
 433         if ( $res->code == 304 or $res->code == 200 ) {
 434             return $to;
 435
 436         } else {
 437             return $self->_error(loc("Fetch failed! HTTP response: %1 %2 [%3]",
 438                         $res->code, HTTP::Status::status_message($res->code),
 439                         $res->status_line));
 440         }
 441
 442     } else {
 443         $METHOD_FAIL->{'lwp'} = 1;
 444         return;
 445     }
 446 }
 447
 448 ### Net::FTP fetching
 449 sub _netftp_fetch {
 450     my $self = shift;
 451     my %hash = @_;
 452
 453     my ($to);
 454     my $tmpl = {
 455         to  => { required => 1, store => \$to }
 456     };
 457     check( $tmpl, \%hash ) or return;
 458
 459     ### required modules ###
 460     my $use_list = { 'Net::FTP' => 0 };
 461
 462     if( can_load( modules => $use_list ) ) {
 463
 464         ### make connection ###
 465         my $ftp;
 466         my @options = ($self->host);
 467         push(@options, Timeout => $TIMEOUT) if $TIMEOUT;
 468         unless( $ftp = Net::FTP->new( @options ) ) {
 469             return $self->_error(loc("Ftp creation failed: %1",$@));
 470         }
 471
 472         ### login ###
 473         unless( $ftp->login( anonymous => $FROM_EMAIL ) ) {
 474             return $self->_error(loc("Could not login to '%1'",$self->host));
 475         }
 476
 477         ### set binary mode, just in case ###
 478         $ftp->binary;
 479
 480         ### create the remote path
 481         ### remember remote paths are unix paths! [#11483]
 482         my $remote = File::Spec::Unix->catfile( $self->path, $self->file );
 483
 484         ### fetch the file ###
 485         my $target;
 486         unless( $target = $ftp->get( $remote, $to ) ) {
 487             return $self->_error(loc("Could not fetch '%1' from '%2'",
 488                         $remote, $self->host));
 489         }
 490
 491         ### log out ###
 492         $ftp->quit;
 493
 494         return $target;
 495
 496     } else {
 497         $METHOD_FAIL->{'netftp'} = 1;
 498         return;
 499     }
 500 }
 501
 502 ### /bin/wget fetch ###
 503 sub _wget_fetch {
 504     my $self = shift;
 505     my %hash = @_;
 506
 507     my ($to);
 508     my $tmpl = {
 509         to  => { required => 1, store => \$to }
 510     };
 511     check( $tmpl, \%hash ) or return;
 512
 513     ### see if we have a wget binary ###
 514     if( my $wget = can_run('wget') ) {
 515
 516         ### no verboseness, thanks ###
 517         my $cmd = [ $wget, '--quiet' ];
 518
 519         ### if a timeout is set, add it ###
 520         push(@$cmd, '--timeout=' . $TIMEOUT) if $TIMEOUT;
 521
 522         ### run passive if specified ###
 523         push @$cmd, '--passive-ftp' if $FTP_PASSIVE;
 524
 525         ### set the output document, add the uri ###
 526         push @$cmd, '--output-document',
 527                     ### DO NOT quote things for IPC::Run, it breaks stuff.
 528                     $IPC::Cmd::USE_IPC_RUN
 529                         ? ($to, $self->uri)
 530                         : (QUOTE. $to .QUOTE, QUOTE. $self->uri .QUOTE);
 531
 532         ### shell out ###
 533         my $captured;
 534         unless(run( command => $cmd,
 535                     buffer  => \$captured,
 536                     verbose => $DEBUG
 537         )) {
 538             ### wget creates the output document always, even if the fetch
 539             ### fails.. so unlink it in that case
 540             1 while unlink $to;
 541
 542             return $self->_error(loc( "Command failed: %1", $captured || '' ));
 543         }
 544
 545         return $to;
 546
 547     } else {
 548         $METHOD_FAIL->{'wget'} = 1;
 549         return;
 550     }
 551 }
 552
 553
 554 ### /bin/ftp fetch ###
 555 sub _ftp_fetch {
 556     my $self = shift;
 557     my %hash = @_;
 558
 559     my ($to);
 560     my $tmpl = {
 561         to  => { required => 1, store => \$to }
 562     };
 563     check( $tmpl, \%hash ) or return;
 564
 565     ### see if we have a ftp binary ###
 566     if( my $ftp = can_run('ftp') ) {
 567
 568         my $fh = FileHandle->new;
 569
 570         local $SIG{CHLD} = 'IGNORE';
 571
 572         unless ($fh->open("|$ftp -n")) {
 573             return $self->_error(loc("%1 creation failed: %2", $ftp, $!));
 574         }
 575
 576         my @dialog = (
 577             "lcd " . dirname($to),
 578             "open " . $self->host,
 579             "user anonymous $FROM_EMAIL",
 580             "cd /",
 581             "cd " . $self->path,
 582             "binary",
 583             "get " . $self->file . " " . $self->output_file,
 584             "quit",
 585         );
 586
 587         foreach (@dialog) { $fh->print($_, "\n") }
 588         $fh->close or return;
 589
 590         return $to;
 591     }
 592 }
 593
 594 ### lynx is stupid - it decompresses any .gz file it finds to be text
 595 ### use /bin/lynx to fetch files
 596 sub _lynx_fetch {
 597     my $self = shift;
 598     my %hash = @_;
 599
 600     my ($to);
 601     my $tmpl = {
 602         to  => { required => 1, store => \$to }
 603     };
 604     check( $tmpl, \%hash ) or return;
 605
 606     ### see if we have a lynx binary ###
 607     if( my $lynx = can_run('lynx') ) {
 608
 609         unless( IPC::Cmd->can_capture_buffer ) {
 610             $METHOD_FAIL->{'lynx'} = 1;
 611
 612             return $self->_error(loc(
 613                 "Can not capture buffers. Can not use '%1' to fetch files",
 614                 'lynx' ));
 615         }
 616
 617         ### write to the output file ourselves, since lynx ass_u_mes to much
 618         my $local = FileHandle->new(">$to")
 619                         or return $self->_error(loc(
 620                             "Could not open '%1' for writing: %2",$to,$!));
 621
 622         ### dump to stdout ###
 623         my $cmd = [
 624             $lynx,
 625             '-source',
 626             "-auth=anonymous:$FROM_EMAIL",
 627         ];
 628
 629         push @$cmd, "-connect_timeout=$TIMEOUT" if $TIMEOUT;
 630
 631         ### DO NOT quote things for IPC::Run, it breaks stuff.
 632         push @$cmd, $IPC::Cmd::USE_IPC_RUN
 633                         ? $self->uri
 634                         : QUOTE. $self->uri .QUOTE;
 635
 636
 637         ### shell out ###
 638         my $captured;
 639         unless(run( command => $cmd,
 640                     buffer  => \$captured,
 641                     verbose => $DEBUG )
 642         ) {
 643             return $self->_error(loc("Command failed: %1", $captured || ''));
 644         }
 645
 646         ### print to local file ###
 647         ### XXX on a 404 with a special error page, $captured will actually
 648         ### hold the contents of that page, and make it *appear* like the
 649         ### request was a success, when really it wasn't :(
 650         ### there doesn't seem to be an option for lynx to change the exit
 651         ### code based on a 4XX status or so.
 652         ### the closest we can come is using --error_file and parsing that,
 653         ### which is very unreliable ;(
 654         $local->print( $captured );
 655         $local->close or return;
 656
 657         return $to;
 658
 659     } else {
 660         $METHOD_FAIL->{'lynx'} = 1;
 661         return;
 662     }
 663 }
 664
 665 ### use /bin/ncftp to fetch files
 666 sub _ncftp_fetch {
 667     my $self = shift;
 668     my %hash = @_;
 669
 670     my ($to);
 671     my $tmpl = {
 672         to  => { required => 1, store => \$to }
 673     };
 674     check( $tmpl, \%hash ) or return;
 675
 676     ### we can only set passive mode in interactive sesssions, so bail out
 677     ### if $FTP_PASSIVE is set
 678     return if $FTP_PASSIVE;
 679
 680     ### see if we have a ncftp binary ###
 681     if( my $ncftp = can_run('ncftp') ) {
 682
 683         my $cmd = [
 684             $ncftp,
 685             '-V',                   # do not be verbose
 686             '-p', $FROM_EMAIL,      # email as password
 687             $self->host,            # hostname
 688             dirname($to),           # local dir for the file
 689                                     # remote path to the file
 690             ### DO NOT quote things for IPC::Run, it breaks stuff.
 691             $IPC::Cmd::USE_IPC_RUN
 692                         ? File::Spec::Unix->catdir( $self->path, $self->file )
 693                         : QUOTE. File::Spec::Unix->catdir(
 694                                         $self->path, $self->file ) .QUOTE
 695
 696         ];
 697
 698         ### shell out ###
 699         my $captured;
 700         unless(run( command => $cmd,
 701                     buffer  => \$captured,
 702                     verbose => $DEBUG )
 703         ) {
 704             return $self->_error(loc("Command failed: %1", $captured || ''));
 705         }
 706
 707         return $to;
 708
 709     } else {
 710         $METHOD_FAIL->{'ncftp'} = 1;
 711         return;
 712     }
 713 }
 714
 715 ### use /bin/curl to fetch files
 716 sub _curl_fetch {
 717     my $self = shift;
 718     my %hash = @_;
 719
 720     my ($to);
 721     my $tmpl = {
 722         to  => { required => 1, store => \$to }
 723     };
 724     check( $tmpl, \%hash ) or return;
 725
 726     if (my $curl = can_run('curl')) {
 727
 728         ### these long opts are self explanatory - I like that -jmb
 729             my $cmd = [ $curl ];
 730
 731             push(@$cmd, '--connect-timeout', $TIMEOUT) if $TIMEOUT;
 732
 733             push(@$cmd, '--silent') unless $DEBUG;
 734
 735         ### curl does the right thing with passive, regardless ###
 736         if ($self->scheme eq 'ftp') {
 737                 push(@$cmd, '--user', "anonymous:$FROM_EMAIL");
 738         }
 739
 740         ### curl doesn't follow 302 (temporarily moved) etc automatically
 741         ### so we add --location to enable that.
 742         push @$cmd, '--fail', '--location', '--output',
 743                     ### DO NOT quote things for IPC::Run, it breaks stuff.
 744                     $IPC::Cmd::USE_IPC_RUN
 745                         ? ($to, $self->uri)
 746                         : (QUOTE. $to .QUOTE, QUOTE. $self->uri .QUOTE);
 747
 748         my $captured;
 749         unless(run( command => $cmd,
 750                     buffer  => \$captured,
 751                     verbose => $DEBUG )
 752         ) {
 753
 754             return $self->_error(loc("Command failed: %1", $captured || ''));
 755         }
 756
 757         return $to;
 758
 759     } else {
 760         $METHOD_FAIL->{'curl'} = 1;
 761         return;
 762     }
 763 }
 764
 765
 766 ### use File::Copy for fetching file:// urls ###
 767 ### XXX file:// uri to local path conversion is just too weird...
 768 ### depend on LWP to do it for us
 769 sub _file_fetch {
 770     my $self = shift;
 771     my %hash = @_;
 772
 773     my ($to);
 774     my $tmpl = {
 775         to  => { required => 1, store => \$to }
 776     };
 777     check( $tmpl, \%hash ) or return;
 778
 779     ### prefix a / on unix systems with a file uri, since it would
 780     ### look somewhat like this:
 781     ###     file://home/kane/file
 782     ### wheras windows file uris might look like:
 783     ###     file://C:/home/kane/file
 784     my $path    = ON_UNIX ? '/'. $self->path : $self->path;
 785
 786     my $remote  = File::Spec->catfile( $path, $self->file );
 787
 788     ### File::Copy is littered with 'die' statements :( ###
 789     my $rv = eval { File::Copy::copy( $remote, $to ) };
 790
 791     ### something went wrong ###
 792     if( !$rv or $@ ) {
 793         return $self->_error(loc("Could not copy '%1' to '%2': %3 %4",
 794                              $remote, $to, $!, $@));
 795     }
 796
 797     return $to;
 798 }
 799
 800 ### use /usr/bin/rsync to fetch files
 801 sub _rsync_fetch {
 802     my $self = shift;
 803     my %hash = @_;
 804
 805     my ($to);
 806     my $tmpl = {
 807         to  => { required => 1, store => \$to }
 808     };
 809     check( $tmpl, \%hash ) or return;
 810
 811     if (my $rsync = can_run('rsync')) {
 812
 813         my $cmd = [ $rsync ];
 814
 815         ### XXX: rsync has no I/O timeouts at all, by default
 816         push(@$cmd, '--timeout=' . $TIMEOUT) if $TIMEOUT;
 817
 818         push(@$cmd, '--quiet') unless $DEBUG;
 819
 820         ### DO NOT quote things for IPC::Run, it breaks stuff.
 821         push @$cmd, $IPC::Cmd::USE_IPC_RUN
 822                         ? ($self->uri, $to)
 823                         : (QUOTE. $self->uri .QUOTE, QUOTE. $to .QUOTE);
 824
 825         my $captured;
 826         unless(run( command => $cmd,
 827                     buffer  => \$captured,
 828                     verbose => $DEBUG )
 829         ) {
 830
 831             return $self->_error(loc("Command failed: %1", $captured || ''));
 832         }
 833
 834         return $to;
 835
 836     } else {
 837         $METHOD_FAIL->{'rsync'} = 1;
 838         return;
 839     }
 840 }
 841
 842 #################################
 843 #
 844 # Error code
 845 #
 846 #################################
 847
 848 =pod
 849
 850 =head2 $ff->error([BOOL])
 851
 852 Returns the last encountered error as string.
 853 Pass it a true value to get the C<Carp::longmess()> output instead.
 854
 855 =cut
 856
 857 ### error handling the way Archive::Extract does it
 858 sub _error {
 859     my $self    = shift;
 860     my $error   = shift;
 861
 862     $self->_error_msg( $error );
 863     $self->_error_msg_long( Carp::longmess($error) );
 864
 865     if( $WARN ) {
 866         carp $DEBUG ? $self->_error_msg_long : $self->_error_msg;
 867     }
 868
 869     return;
 870 }
 871
 872 sub error {
 873     my $self = shift;
 874     return shift() ? $self->_error_msg_long : $self->_error_msg;
 875 }
 876
 877
 878 1;
 879
 880 =pod
 881
 882 =head1 HOW IT WORKS
 883
 884 File::Fetch is able to fetch a variety of uris, by using several
 885 external programs and modules.
 886
 887 Below is a mapping of what utilities will be used in what order
 888 for what schemes, if available:
 889
 890     file    => LWP, file
 891     http    => LWP, wget, curl, lynx
 892     ftp     => LWP, Net::FTP, wget, curl, ncftp, ftp
 893     rsync   => rsync
 894
 895 If you'd like to disable the use of one or more of these utilities
 896 and/or modules, see the C<$BLACKLIST> variable further down.
 897
 898 If a utility or module isn't available, it will be marked in a cache
 899 (see the C<$METHOD_FAIL> variable further down), so it will not be
 900 tried again. The C<fetch> method will only fail when all options are
 901 exhausted, and it was not able to retrieve the file.
 902
 903 A special note about fetching files from an ftp uri:
 904
 905 By default, all ftp connections are done in passive mode. To change
 906 that, see the C<$FTP_PASSIVE> variable further down.
 907
 908 Furthermore, ftp uris only support anonymous connections, so no
 909 named user/password pair can be passed along.
 910
 911 C</bin/ftp> is blacklisted by default; see the C<$BLACKLIST> variable
 912 further down.
 913
 914 =head1 GLOBAL VARIABLES
 915
 916 The behaviour of File::Fetch can be altered by changing the following
 917 global variables:
 918
 919 =head2 $File::Fetch::FROM_EMAIL
 920
 921 This is the email address that will be sent as your anonymous ftp
 922 password.
 923
 924 Default is C<File-Fetch@example.com>.
 925
 926 =head2 $File::Fetch::USER_AGENT
 927
 928 This is the useragent as C<LWP> will report it.
 929
 930 Default is C<File::Fetch/$VERSION>.
 931
 932 =head2 $File::Fetch::FTP_PASSIVE
 933
 934 This variable controls whether the environment variable C<FTP_PASSIVE>
 935 and any passive switches to commandline tools will be set to true.
 936
 937 Default value is 1.
 938
 939 Note: When $FTP_PASSIVE is true, C<ncftp> will not be used to fetch
 940 files, since passive mode can only be set interactively for this binary
 941
 942 =head2 $File::Fetch::TIMEOUT
 943
 944 When set, controls the network timeout (counted in seconds).
 945
 946 Default value is 0.
 947
 948 =head2 $File::Fetch::WARN
 949
 950 This variable controls whether errors encountered internally by
 951 C<File::Fetch> should be C<carp>'d or not.
 952
 953 Set to false to silence warnings. Inspect the output of the C<error()>
 954 method manually to see what went wrong.
 955
 956 Defaults to C<true>.
 957
 958 =head2 $File::Fetch::DEBUG
 959
 960 This enables debugging output when calling commandline utilities to
 961 fetch files.
 962 This also enables C<Carp::longmess> errors, instead of the regular
 963 C<carp> errors.
 964
 965 Good for tracking down why things don't work with your particular
 966 setup.
 967
 968 Default is 0.
 969
 970 =head2 $File::Fetch::BLACKLIST
 971
 972 This is an array ref holding blacklisted modules/utilities for fetching
 973 files with.
 974
 975 To disallow the use of, for example, C<LWP> and C<Net::FTP>, you could
 976 set $File::Fetch::BLACKLIST to:
 977
 978     $File::Fetch::BLACKLIST = [qw|lwp netftp|]
 979
 980 The default blacklist is [qw|ftp|], as C</bin/ftp> is rather unreliable.
 981
 982 See the note on C<MAPPING> below.
 983
 984 =head2 $File::Fetch::METHOD_FAIL
 985
 986 This is a hashref registering what modules/utilities were known to fail
 987 for fetching files (mostly because they weren't installed).
 988
 989 You can reset this cache by assigning an empty hashref to it, or
 990 individually remove keys.
 991
 992 See the note on C<MAPPING> below.
 993
 994 =head1 MAPPING
 995
 996
 997 Here's a quick mapping for the utilities/modules, and their names for
 998 the $BLACKLIST, $METHOD_FAIL and other internal functions.
 999
1000     LWP         => lwp
1001     Net::FTP    => netftp
1002     wget        => wget
1003     lynx        => lynx
1004     ncftp       => ncftp
1005     ftp         => ftp
1006     curl        => curl
1007     rsync       => rsync
1008
1009 =head1 FREQUENTLY ASKED QUESTIONS
1010
1011 =head2 So how do I use a proxy with File::Fetch?
1012
1013 C<File::Fetch> currently only supports proxies with LWP::UserAgent.
1014 You will need to set your environment variables accordingly. For
1015 example, to use an ftp proxy:
1016
1017     $ENV{ftp_proxy} = 'foo.com';
1018
1019 Refer to the LWP::UserAgent manpage for more details.
1020
1021 =head2 I used 'lynx' to fetch a file, but its contents is all wrong!
1022
1023 C<lynx> can only fetch remote files by dumping its contents to C<STDOUT>,
1024 which we in turn capture. If that content is a 'custom' error file
1025 (like, say, a C<404 handler>), you will get that contents instead.
1026
1027 Sadly, C<lynx> doesn't support any options to return a different exit
1028 code on non-C<200 OK> status, giving us no way to tell the difference
1029 between a 'successfull' fetch and a custom error page.
1030
1031 Therefor, we recommend to only use C<lynx> as a last resort. This is
1032 why it is at the back of our list of methods to try as well.
1033
1034 =head2 Files I'm trying to fetch have reserved characters or non-ASCII characters in them. What do I do?
1035
1036 C<File::Fetch> is relatively smart about things. When trying to write
1037 a file to disk, it removes the C<query parameters> (see the
1038 C<output_file> method for details) from the file name before creating
1039 it. In most cases this suffices.
1040
1041 If you have any other characters you need to escape, please install
1042 the C<URI::Escape> module from CPAN, and pre-encode your URI before
1043 passing it to C<File::Fetch>. You can read about the details of URIs
1044 and URI encoding here:
1045
1046   http://www.faqs.org/rfcs/rfc2396.html
1047
1048 =head1 TODO
1049
1050 =over 4
1051
1052 =item Implement $PREFER_BIN
1053
1054 To indicate to rather use commandline tools than modules
1055
1056 =head1 AUTHORS
1057
1058 This module by Jos Boumans E<lt>kane@cpan.orgE<gt>.
1059
1060 =head1 COPYRIGHT
1061
1062 This module is copyright (c) 2003-2007 Jos Boumans
1063 E<lt>kane@cpan.orgE<gt>. All rights reserved.
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