summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/File/Fetch.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/File/Fetch.pm')
-rw-r--r--Master/tlpkg/tlperl/lib/File/Fetch.pm1466
1 files changed, 1466 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/File/Fetch.pm b/Master/tlpkg/tlperl/lib/File/Fetch.pm
new file mode 100644
index 00000000000..4aabc29be55
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/File/Fetch.pm
@@ -0,0 +1,1466 @@
+package File::Fetch;
+
+use strict;
+use FileHandle;
+use File::Temp;
+use File::Copy;
+use File::Spec;
+use File::Spec::Unix;
+use File::Basename qw[dirname];
+
+use Cwd qw[cwd];
+use Carp qw[carp];
+use IPC::Cmd qw[can_run run QUOTE];
+use File::Path qw[mkpath];
+use File::Temp qw[tempdir];
+use Params::Check qw[check];
+use Module::Load::Conditional qw[can_load];
+use Locale::Maketext::Simple Style => 'gettext';
+
+use vars qw[ $VERBOSE $PREFER_BIN $FROM_EMAIL $USER_AGENT
+ $BLACKLIST $METHOD_FAIL $VERSION $METHODS
+ $FTP_PASSIVE $TIMEOUT $DEBUG $WARN
+ ];
+
+$VERSION = '0.24';
+$VERSION = eval $VERSION; # avoid warnings with development releases
+$PREFER_BIN = 0; # XXX TODO implement
+$FROM_EMAIL = 'File-Fetch@example.com';
+$USER_AGENT = "File::Fetch/$VERSION";
+$BLACKLIST = [qw|ftp|];
+$METHOD_FAIL = { };
+$FTP_PASSIVE = 1;
+$TIMEOUT = 0;
+$DEBUG = 0;
+$WARN = 1;
+
+### methods available to fetch the file depending on the scheme
+$METHODS = {
+ http => [ qw|lwp wget curl lftp lynx iosock| ],
+ ftp => [ qw|lwp netftp wget curl lftp ncftp ftp| ],
+ file => [ qw|lwp lftp file| ],
+ rsync => [ qw|rsync| ]
+};
+
+### silly warnings ###
+local $Params::Check::VERBOSE = 1;
+local $Params::Check::VERBOSE = 1;
+local $Module::Load::Conditional::VERBOSE = 0;
+local $Module::Load::Conditional::VERBOSE = 0;
+
+### see what OS we are on, important for file:// uris ###
+use constant ON_WIN => ($^O eq 'MSWin32');
+use constant ON_VMS => ($^O eq 'VMS');
+use constant ON_UNIX => (!ON_WIN);
+use constant HAS_VOL => (ON_WIN);
+use constant HAS_SHARE => (ON_WIN);
+
+
+=pod
+
+=head1 NAME
+
+File::Fetch - A generic file fetching mechanism
+
+=head1 SYNOPSIS
+
+ use File::Fetch;
+
+ ### build a File::Fetch object ###
+ my $ff = File::Fetch->new(uri => 'http://some.where.com/dir/a.txt');
+
+ ### fetch the uri to cwd() ###
+ my $where = $ff->fetch() or die $ff->error;
+
+ ### fetch the uri to /tmp ###
+ my $where = $ff->fetch( to => '/tmp' );
+
+ ### parsed bits from the uri ###
+ $ff->uri;
+ $ff->scheme;
+ $ff->host;
+ $ff->path;
+ $ff->file;
+
+=head1 DESCRIPTION
+
+File::Fetch is a generic file fetching mechanism.
+
+It allows you to fetch any file pointed to by a C<ftp>, C<http>,
+C<file>, or C<rsync> uri by a number of different means.
+
+See the C<HOW IT WORKS> section further down for details.
+
+=head1 ACCESSORS
+
+A C<File::Fetch> object has the following accessors
+
+=over 4
+
+=item $ff->uri
+
+The uri you passed to the constructor
+
+=item $ff->scheme
+
+The scheme from the uri (like 'file', 'http', etc)
+
+=item $ff->host
+
+The hostname in the uri. Will be empty if host was originally
+'localhost' for a 'file://' url.
+
+=item $ff->vol
+
+On operating systems with the concept of a volume the second element
+of a file:// is considered to the be volume specification for the file.
+Thus on Win32 this routine returns the volume, on other operating
+systems this returns nothing.
+
+On Windows this value may be empty if the uri is to a network share, in
+which case the 'share' property will be defined. Additionally, volume
+specifications that use '|' as ':' will be converted on read to use ':'.
+
+On VMS, which has a volume concept, this field will be empty because VMS
+file specifications are converted to absolute UNIX format and the volume
+information is transparently included.
+
+=item $ff->share
+
+On systems with the concept of a network share (currently only Windows) returns
+the sharename from a file://// url. On other operating systems returns empty.
+
+=item $ff->path
+
+The path from the uri, will be at least a single '/'.
+
+=item $ff->file
+
+The name of the remote file. For the local file name, the
+result of $ff->output_file will be used.
+
+=cut
+
+
+##########################
+### Object & Accessors ###
+##########################
+
+{
+ ### template for autogenerated accessors ###
+ my $Tmpl = {
+ scheme => { default => 'http' },
+ host => { default => 'localhost' },
+ path => { default => '/' },
+ file => { required => 1 },
+ uri => { required => 1 },
+ vol => { default => '' }, # windows for file:// uris
+ share => { default => '' }, # windows for file:// uris
+ _error_msg => { no_override => 1 },
+ _error_msg_long => { no_override => 1 },
+ };
+
+ for my $method ( keys %$Tmpl ) {
+ no strict 'refs';
+ *$method = sub {
+ my $self = shift;
+ $self->{$method} = $_[0] if @_;
+ return $self->{$method};
+ }
+ }
+
+ sub _create {
+ my $class = shift;
+ my %hash = @_;
+
+ my $args = check( $Tmpl, \%hash ) or return;
+
+ bless $args, $class;
+
+ if( lc($args->scheme) ne 'file' and not $args->host ) {
+ return $class->_error(loc(
+ "Hostname required when fetching from '%1'",$args->scheme));
+ }
+
+ for (qw[path file]) {
+ unless( $args->$_() ) { # 5.5.x needs the ()
+ return $class->_error(loc("No '%1' specified",$_));
+ }
+ }
+
+ return $args;
+ }
+}
+
+=item $ff->output_file
+
+The name of the output file. This is the same as $ff->file,
+but any query parameters are stripped off. For example:
+
+ http://example.com/index.html?x=y
+
+would make the output file be C<index.html> rather than
+C<index.html?x=y>.
+
+=back
+
+=cut
+
+sub output_file {
+ my $self = shift;
+ my $file = $self->file;
+
+ $file =~ s/\?.*$//g;
+
+ return $file;
+}
+
+### XXX do this or just point to URI::Escape?
+# =head2 $esc_uri = $ff->escaped_uri
+#
+# =cut
+#
+# ### most of this is stolen straight from URI::escape
+# { ### Build a char->hex map
+# my %escapes = map { chr($_) => sprintf("%%%02X", $_) } 0..255;
+#
+# sub escaped_uri {
+# my $self = shift;
+# my $uri = $self->uri;
+#
+# ### Default unsafe characters. RFC 2732 ^(uric - reserved)
+# $uri =~ s/([^A-Za-z0-9\-_.!~*'()])/
+# $escapes{$1} || $self->_fail_hi($1)/ge;
+#
+# return $uri;
+# }
+#
+# sub _fail_hi {
+# my $self = shift;
+# my $char = shift;
+#
+# $self->_error(loc(
+# "Can't escape '%1', try using the '%2' module instead",
+# sprintf("\\x{%04X}", ord($char)), 'URI::Escape'
+# ));
+# }
+#
+# sub output_file {
+#
+# }
+#
+#
+# }
+
+=head1 METHODS
+
+=head2 $ff = File::Fetch->new( uri => 'http://some.where.com/dir/file.txt' );
+
+Parses the uri and creates a corresponding File::Fetch::Item object,
+that is ready to be C<fetch>ed and returns it.
+
+Returns false on failure.
+
+=cut
+
+sub new {
+ my $class = shift;
+ my %hash = @_;
+
+ my ($uri);
+ my $tmpl = {
+ uri => { required => 1, store => \$uri },
+ };
+
+ check( $tmpl, \%hash ) or return;
+
+ ### parse the uri to usable parts ###
+ my $href = $class->_parse_uri( $uri ) or return;
+
+ ### make it into a FFI object ###
+ my $ff = $class->_create( %$href ) or return;
+
+
+ ### return the object ###
+ return $ff;
+}
+
+### parses an uri to a hash structure:
+###
+### $class->_parse_uri( 'ftp://ftp.cpan.org/pub/mirror/index.txt' )
+###
+### becomes:
+###
+### $href = {
+### scheme => 'ftp',
+### host => 'ftp.cpan.org',
+### path => '/pub/mirror',
+### file => 'index.html'
+### };
+###
+### In the case of file:// urls there maybe be additional fields
+###
+### For systems with volume specifications such as Win32 there will be
+### a volume specifier provided in the 'vol' field.
+###
+### 'vol' => 'volumename'
+###
+### For windows file shares there may be a 'share' key specified
+###
+### 'share' => 'sharename'
+###
+### Note that the rules of what a file:// url means vary by the operating system
+### of the host being addressed. Thus file:///d|/foo/bar.txt means the obvious
+### 'D:\foo\bar.txt' on windows, but on unix it means '/d|/foo/bar.txt' and
+### not '/foo/bar.txt'
+###
+### Similarly if the host interpreting the url is VMS then
+### file:///disk$user/my/notes/note12345.txt' means
+### 'DISK$USER:[MY.NOTES]NOTE123456.TXT' but will be returned the same as
+### if it is unix where it means /disk$user/my/notes/note12345.txt'.
+### Except for some cases in the File::Spec methods, Perl on VMS will generally
+### handle UNIX format file specifications.
+###
+### This means it is impossible to serve certain file:// urls on certain systems.
+###
+### Thus are the problems with a protocol-less specification. :-(
+###
+
+sub _parse_uri {
+ my $self = shift;
+ my $uri = shift or return;
+
+ my $href = { uri => $uri };
+
+ ### find the scheme ###
+ $uri =~ s|^(\w+)://||;
+ $href->{scheme} = $1;
+
+ ### See rfc 1738 section 3.10
+ ### http://www.faqs.org/rfcs/rfc1738.html
+ ### And wikipedia for more on windows file:// urls
+ ### http://en.wikipedia.org/wiki/File://
+ if( $href->{scheme} eq 'file' ) {
+
+ my @parts = split '/',$uri;
+
+ ### file://hostname/...
+ ### file://hostname/...
+ ### normalize file://localhost with file:///
+ $href->{host} = $parts[0] || '';
+
+ ### index in @parts where the path components begin;
+ my $index = 1;
+
+ ### file:////hostname/sharename/blah.txt
+ if ( HAS_SHARE and not length $parts[0] and not length $parts[1] ) {
+
+ $href->{host} = $parts[2] || ''; # avoid warnings
+ $href->{share} = $parts[3] || ''; # avoid warnings
+
+ $index = 4 # index after the share
+
+ ### file:///D|/blah.txt
+ ### file:///D:/blah.txt
+ } elsif (HAS_VOL) {
+
+ ### this code comes from dmq's patch, but:
+ ### XXX if volume is empty, wouldn't that be an error? --kane
+ ### if so, our file://localhost test needs to be fixed as wel
+ $href->{vol} = $parts[1] || '';
+
+ ### correct D| style colume descriptors
+ $href->{vol} =~ s/\A([A-Z])\|\z/$1:/i if ON_WIN;
+
+ $index = 2; # index after the volume
+ }
+
+ ### rebuild the path from the leftover parts;
+ $href->{path} = join '/', '', splice( @parts, $index, $#parts );
+
+ } else {
+ ### using anything but qw() in hash slices may produce warnings
+ ### in older perls :-(
+ @{$href}{ qw(host path) } = $uri =~ m|([^/]*)(/.*)$|s;
+ }
+
+ ### split the path into file + dir ###
+ { my @parts = File::Spec::Unix->splitpath( delete $href->{path} );
+ $href->{path} = $parts[1];
+ $href->{file} = $parts[2];
+ }
+
+ ### host will be empty if the target was 'localhost' and the
+ ### scheme was 'file'
+ $href->{host} = '' if ($href->{host} eq 'localhost') and
+ ($href->{scheme} eq 'file');
+
+ return $href;
+}
+
+=head2 $where = $ff->fetch( [to => /my/output/dir/ | \$scalar] )
+
+Fetches the file you requested and returns the full path to the file.
+
+By default it writes to C<cwd()>, but you can override that by specifying
+the C<to> argument:
+
+ ### file fetch to /tmp, full path to the file in $where
+ $where = $ff->fetch( to => '/tmp' );
+
+ ### file slurped into $scalar, full path to the file in $where
+ ### file is downloaded to a temp directory and cleaned up at exit time
+ $where = $ff->fetch( to => \$scalar );
+
+Returns the full path to the downloaded file on success, and false
+on failure.
+
+=cut
+
+sub fetch {
+ my $self = shift or return;
+ my %hash = @_;
+
+ my $target;
+ my $tmpl = {
+ to => { default => cwd(), store => \$target },
+ };
+
+ check( $tmpl, \%hash ) or return;
+
+ my ($to, $fh);
+ ### you want us to slurp the contents
+ if( ref $target and UNIVERSAL::isa( $target, 'SCALAR' ) ) {
+ $to = tempdir( 'FileFetch.XXXXXX', CLEANUP => 1 );
+
+ ### plain old fetch
+ } else {
+ $to = $target;
+
+ ### On VMS force to VMS format so File::Spec will work.
+ $to = VMS::Filespec::vmspath($to) if ON_VMS;
+
+ ### create the path if it doesn't exist yet ###
+ unless( -d $to ) {
+ eval { mkpath( $to ) };
+
+ return $self->_error(loc("Could not create path '%1'",$to)) if $@;
+ }
+ }
+
+ ### set passive ftp if required ###
+ local $ENV{FTP_PASSIVE} = $FTP_PASSIVE;
+
+ ### we dont use catfile on win32 because if we are using a cygwin tool
+ ### under cmd.exe they wont understand windows style separators.
+ my $out_to = ON_WIN ? $to.'/'.$self->output_file
+ : File::Spec->catfile( $to, $self->output_file );
+
+ for my $method ( @{ $METHODS->{$self->scheme} } ) {
+ my $sub = '_'.$method.'_fetch';
+
+ unless( __PACKAGE__->can($sub) ) {
+ $self->_error(loc("Cannot call method for '%1' -- WEIRD!",
+ $method));
+ next;
+ }
+
+ ### method is blacklisted ###
+ next if grep { lc $_ eq $method } @$BLACKLIST;
+
+ ### method is known to fail ###
+ next if $METHOD_FAIL->{$method};
+
+ ### there's serious issues with IPC::Run and quoting of command
+ ### line arguments. using quotes in the wrong place breaks things,
+ ### and in the case of say,
+ ### C:\cygwin\bin\wget.EXE --quiet --passive-ftp --output-document
+ ### "index.html" "http://www.cpan.org/index.html?q=1&y=2"
+ ### it doesn't matter how you quote, it always fails.
+ local $IPC::Cmd::USE_IPC_RUN = 0;
+
+ if( my $file = $self->$sub(
+ to => $out_to
+ )){
+
+ unless( -e $file && -s _ ) {
+ $self->_error(loc("'%1' said it fetched '%2', ".
+ "but it was not created",$method,$file));
+
+ ### mark the failure ###
+ $METHOD_FAIL->{$method} = 1;
+
+ next;
+
+ } else {
+
+ ### slurp mode?
+ if( ref $target and UNIVERSAL::isa( $target, 'SCALAR' ) ) {
+
+ ### open the file
+ open my $fh, $file or do {
+ $self->_error(
+ loc("Could not open '%1': %2", $file, $!));
+ return;
+ };
+
+ ### slurp
+ $$target = do { local $/; <$fh> };
+
+ }
+
+ my $abs = File::Spec->rel2abs( $file );
+ return $abs;
+
+ }
+ }
+ }
+
+
+ ### if we got here, we looped over all methods, but we weren't able
+ ### to fetch it.
+ return;
+}
+
+########################
+### _*_fetch methods ###
+########################
+
+### LWP fetching ###
+sub _lwp_fetch {
+ my $self = shift;
+ my %hash = @_;
+
+ my ($to);
+ my $tmpl = {
+ to => { required => 1, store => \$to }
+ };
+ check( $tmpl, \%hash ) or return;
+
+ ### modules required to download with lwp ###
+ my $use_list = {
+ LWP => '0.0',
+ 'LWP::UserAgent' => '0.0',
+ 'HTTP::Request' => '0.0',
+ 'HTTP::Status' => '0.0',
+ URI => '0.0',
+
+ };
+
+ if( can_load(modules => $use_list) ) {
+
+ ### setup the uri object
+ my $uri = URI->new( File::Spec::Unix->catfile(
+ $self->path, $self->file
+ ) );
+
+ ### special rules apply for file:// uris ###
+ $uri->scheme( $self->scheme );
+ $uri->host( $self->scheme eq 'file' ? '' : $self->host );
+ $uri->userinfo("anonymous:$FROM_EMAIL") if $self->scheme ne 'file';
+
+ ### set up the useragent object
+ my $ua = LWP::UserAgent->new();
+ $ua->timeout( $TIMEOUT ) if $TIMEOUT;
+ $ua->agent( $USER_AGENT );
+ $ua->from( $FROM_EMAIL );
+ $ua->env_proxy;
+
+ my $res = $ua->mirror($uri, $to) or return;
+
+ ### uptodate or fetched ok ###
+ if ( $res->code == 304 or $res->code == 200 ) {
+ return $to;
+
+ } else {
+ return $self->_error(loc("Fetch failed! HTTP response: %1 %2 [%3]",
+ $res->code, HTTP::Status::status_message($res->code),
+ $res->status_line));
+ }
+
+ } else {
+ $METHOD_FAIL->{'lwp'} = 1;
+ return;
+ }
+}
+
+### Simple IO::Socket::INET fetching ###
+sub _iosock_fetch {
+ my $self = shift;
+ my %hash = @_;
+
+ my ($to);
+ my $tmpl = {
+ to => { required => 1, store => \$to }
+ };
+ check( $tmpl, \%hash ) or return;
+
+ my $use_list = {
+ 'IO::Socket::INET' => '0.0',
+ 'IO::Select' => '0.0',
+ };
+
+ if( can_load(modules => $use_list) ) {
+ my $sock = IO::Socket::INET->new(
+ PeerHost => $self->host,
+ ( $self->host =~ /:/ ? () : ( PeerPort => 80 ) ),
+ );
+
+ unless ( $sock ) {
+ return $self->_error(loc("Could not open socket to '%1', '%2'",$self->host,$!));
+ }
+
+ my $fh = FileHandle->new;
+
+ # Check open()
+
+ unless ( $fh->open($to,'>') ) {
+ return $self->_error(loc(
+ "Could not open '%1' for writing: %2",$to,$!));
+ }
+
+ my $path = File::Spec::Unix->catfile( $self->path, $self->file );
+ my $req = "GET $path HTTP/1.0\x0d\x0aHost: " . $self->host . "\x0d\x0a\x0d\x0a";
+ $sock->send( $req );
+
+ my $select = IO::Select->new( $sock );
+
+ my $resp = '';
+ my $normal = 0;
+ while ( $select->can_read( $TIMEOUT || 60 ) ) {
+ my $ret = $sock->sysread( $resp, 4096, length($resp) );
+ if ( !defined $ret or $ret == 0 ) {
+ $select->remove( $sock );
+ $normal++;
+ }
+ }
+ close $sock;
+
+ unless ( $normal ) {
+ return $self->_error(loc("Socket timed out after '%1' seconds", ( $TIMEOUT || 60 )));
+ }
+
+ # Check the "response"
+ # Strip preceeding blank lines apparently they are allowed (RFC 2616 4.1)
+ $resp =~ s/^(\x0d?\x0a)+//;
+ # Check it is an HTTP response
+ unless ( $resp =~ m!^HTTP/(\d+)\.(\d+)!i ) {
+ return $self->_error(loc("Did not get a HTTP response from '%1'",$self->host));
+ }
+
+ # Check for OK
+ my ($code) = $resp =~ m!^HTTP/\d+\.\d+\s+(\d+)!i;
+ unless ( $code eq '200' ) {
+ return $self->_error(loc("Got a '%1' from '%2' expected '200'",$code,$self->host));
+ }
+
+ print $fh +($resp =~ m/\x0d\x0a\x0d\x0a(.*)$/s )[0];
+ close $fh;
+ return $to;
+
+ } else {
+ $METHOD_FAIL->{'iosock'} = 1;
+ return;
+ }
+}
+
+### Net::FTP fetching
+sub _netftp_fetch {
+ my $self = shift;
+ my %hash = @_;
+
+ my ($to);
+ my $tmpl = {
+ to => { required => 1, store => \$to }
+ };
+ check( $tmpl, \%hash ) or return;
+
+ ### required modules ###
+ my $use_list = { 'Net::FTP' => 0 };
+
+ if( can_load( modules => $use_list ) ) {
+
+ ### make connection ###
+ my $ftp;
+ my @options = ($self->host);
+ push(@options, Timeout => $TIMEOUT) if $TIMEOUT;
+ unless( $ftp = Net::FTP->new( @options ) ) {
+ return $self->_error(loc("Ftp creation failed: %1",$@));
+ }
+
+ ### login ###
+ unless( $ftp->login( anonymous => $FROM_EMAIL ) ) {
+ return $self->_error(loc("Could not login to '%1'",$self->host));
+ }
+
+ ### set binary mode, just in case ###
+ $ftp->binary;
+
+ ### create the remote path
+ ### remember remote paths are unix paths! [#11483]
+ my $remote = File::Spec::Unix->catfile( $self->path, $self->file );
+
+ ### fetch the file ###
+ my $target;
+ unless( $target = $ftp->get( $remote, $to ) ) {
+ return $self->_error(loc("Could not fetch '%1' from '%2'",
+ $remote, $self->host));
+ }
+
+ ### log out ###
+ $ftp->quit;
+
+ return $target;
+
+ } else {
+ $METHOD_FAIL->{'netftp'} = 1;
+ return;
+ }
+}
+
+### /bin/wget fetch ###
+sub _wget_fetch {
+ my $self = shift;
+ my %hash = @_;
+
+ my ($to);
+ my $tmpl = {
+ to => { required => 1, store => \$to }
+ };
+ check( $tmpl, \%hash ) or return;
+
+ ### see if we have a wget binary ###
+ if( my $wget = can_run('wget') ) {
+
+ ### no verboseness, thanks ###
+ my $cmd = [ $wget, '--quiet' ];
+
+ ### if a timeout is set, add it ###
+ push(@$cmd, '--timeout=' . $TIMEOUT) if $TIMEOUT;
+
+ ### run passive if specified ###
+ push @$cmd, '--passive-ftp' if $FTP_PASSIVE;
+
+ ### set the output document, add the uri ###
+ push @$cmd, '--output-document', $to, $self->uri;
+
+ ### with IPC::Cmd > 0.41, this is fixed in teh library,
+ ### and there's no need for special casing any more.
+ ### DO NOT quote things for IPC::Run, it breaks stuff.
+ # $IPC::Cmd::USE_IPC_RUN
+ # ? ($to, $self->uri)
+ # : (QUOTE. $to .QUOTE, QUOTE. $self->uri .QUOTE);
+
+ ### shell out ###
+ my $captured;
+ unless(run( command => $cmd,
+ buffer => \$captured,
+ verbose => $DEBUG
+ )) {
+ ### wget creates the output document always, even if the fetch
+ ### fails.. so unlink it in that case
+ 1 while unlink $to;
+
+ return $self->_error(loc( "Command failed: %1", $captured || '' ));
+ }
+
+ return $to;
+
+ } else {
+ $METHOD_FAIL->{'wget'} = 1;
+ return;
+ }
+}
+
+### /bin/lftp fetch ###
+sub _lftp_fetch {
+ my $self = shift;
+ my %hash = @_;
+
+ my ($to);
+ my $tmpl = {
+ to => { required => 1, store => \$to }
+ };
+ check( $tmpl, \%hash ) or return;
+
+ ### see if we have a wget binary ###
+ if( my $lftp = can_run('lftp') ) {
+
+ ### no verboseness, thanks ###
+ my $cmd = [ $lftp, '-f' ];
+
+ my $fh = File::Temp->new;
+
+ my $str;
+
+ ### if a timeout is set, add it ###
+ $str .= "set net:timeout $TIMEOUT;\n" if $TIMEOUT;
+
+ ### run passive if specified ###
+ $str .= "set ftp:passive-mode 1;\n" if $FTP_PASSIVE;
+
+ ### set the output document, add the uri ###
+ ### quote the URI, because lftp supports certain shell
+ ### expansions, most notably & for backgrounding.
+ ### ' quote does nto work, must be "
+ $str .= q[get ']. $self->uri .q[' -o ]. $to . $/;
+
+ if( $DEBUG ) {
+ my $pp_str = join ' ', split $/, $str;
+ print "# lftp command: $pp_str\n";
+ }
+
+ ### write straight to the file.
+ $fh->autoflush(1);
+ print $fh $str;
+
+ ### the command needs to be 1 string to be executed
+ push @$cmd, $fh->filename;
+
+ ### with IPC::Cmd > 0.41, this is fixed in teh library,
+ ### and there's no need for special casing any more.
+ ### DO NOT quote things for IPC::Run, it breaks stuff.
+ # $IPC::Cmd::USE_IPC_RUN
+ # ? ($to, $self->uri)
+ # : (QUOTE. $to .QUOTE, QUOTE. $self->uri .QUOTE);
+
+
+ ### shell out ###
+ my $captured;
+ unless(run( command => $cmd,
+ buffer => \$captured,
+ verbose => $DEBUG
+ )) {
+ ### wget creates the output document always, even if the fetch
+ ### fails.. so unlink it in that case
+ 1 while unlink $to;
+
+ return $self->_error(loc( "Command failed: %1", $captured || '' ));
+ }
+
+ return $to;
+
+ } else {
+ $METHOD_FAIL->{'lftp'} = 1;
+ return;
+ }
+}
+
+
+
+### /bin/ftp fetch ###
+sub _ftp_fetch {
+ my $self = shift;
+ my %hash = @_;
+
+ my ($to);
+ my $tmpl = {
+ to => { required => 1, store => \$to }
+ };
+ check( $tmpl, \%hash ) or return;
+
+ ### see if we have a ftp binary ###
+ if( my $ftp = can_run('ftp') ) {
+
+ my $fh = FileHandle->new;
+
+ local $SIG{CHLD} = 'IGNORE';
+
+ unless ($fh->open("|$ftp -n")) {
+ return $self->_error(loc("%1 creation failed: %2", $ftp, $!));
+ }
+
+ my @dialog = (
+ "lcd " . dirname($to),
+ "open " . $self->host,
+ "user anonymous $FROM_EMAIL",
+ "cd /",
+ "cd " . $self->path,
+ "binary",
+ "get " . $self->file . " " . $self->output_file,
+ "quit",
+ );
+
+ foreach (@dialog) { $fh->print($_, "\n") }
+ $fh->close or return;
+
+ return $to;
+ }
+}
+
+### lynx is stupid - it decompresses any .gz file it finds to be text
+### use /bin/lynx to fetch files
+sub _lynx_fetch {
+ my $self = shift;
+ my %hash = @_;
+
+ my ($to);
+ my $tmpl = {
+ to => { required => 1, store => \$to }
+ };
+ check( $tmpl, \%hash ) or return;
+
+ ### see if we have a lynx binary ###
+ if( my $lynx = can_run('lynx') ) {
+
+ unless( IPC::Cmd->can_capture_buffer ) {
+ $METHOD_FAIL->{'lynx'} = 1;
+
+ return $self->_error(loc(
+ "Can not capture buffers. Can not use '%1' to fetch files",
+ 'lynx' ));
+ }
+
+ ### check if the HTTP resource exists ###
+ if ($self->uri =~ /^https?:\/\//i) {
+ my $cmd = [
+ $lynx,
+ '-head',
+ '-source',
+ "-auth=anonymous:$FROM_EMAIL",
+ ];
+
+ push @$cmd, "-connect_timeout=$TIMEOUT" if $TIMEOUT;
+
+ push @$cmd, $self->uri;
+
+ ### shell out ###
+ my $head;
+ unless(run( command => $cmd,
+ buffer => \$head,
+ verbose => $DEBUG )
+ ) {
+ return $self->_error(loc("Command failed: %1", $head || ''));
+ }
+
+ unless($head =~ /^HTTP\/\d+\.\d+ 200\b/) {
+ return $self->_error(loc("Command failed: %1", $head || ''));
+ }
+ }
+
+ ### write to the output file ourselves, since lynx ass_u_mes to much
+ my $local = FileHandle->new(">$to")
+ or return $self->_error(loc(
+ "Could not open '%1' for writing: %2",$to,$!));
+
+ ### dump to stdout ###
+ my $cmd = [
+ $lynx,
+ '-source',
+ "-auth=anonymous:$FROM_EMAIL",
+ ];
+
+ push @$cmd, "-connect_timeout=$TIMEOUT" if $TIMEOUT;
+
+ ### DO NOT quote things for IPC::Run, it breaks stuff.
+ push @$cmd, $self->uri;
+
+ ### with IPC::Cmd > 0.41, this is fixed in teh library,
+ ### and there's no need for special casing any more.
+ ### DO NOT quote things for IPC::Run, it breaks stuff.
+ # $IPC::Cmd::USE_IPC_RUN
+ # ? $self->uri
+ # : QUOTE. $self->uri .QUOTE;
+
+
+ ### shell out ###
+ my $captured;
+ unless(run( command => $cmd,
+ buffer => \$captured,
+ verbose => $DEBUG )
+ ) {
+ return $self->_error(loc("Command failed: %1", $captured || ''));
+ }
+
+ ### print to local file ###
+ ### XXX on a 404 with a special error page, $captured will actually
+ ### hold the contents of that page, and make it *appear* like the
+ ### request was a success, when really it wasn't :(
+ ### there doesn't seem to be an option for lynx to change the exit
+ ### code based on a 4XX status or so.
+ ### the closest we can come is using --error_file and parsing that,
+ ### which is very unreliable ;(
+ $local->print( $captured );
+ $local->close or return;
+
+ return $to;
+
+ } else {
+ $METHOD_FAIL->{'lynx'} = 1;
+ return;
+ }
+}
+
+### use /bin/ncftp to fetch files
+sub _ncftp_fetch {
+ my $self = shift;
+ my %hash = @_;
+
+ my ($to);
+ my $tmpl = {
+ to => { required => 1, store => \$to }
+ };
+ check( $tmpl, \%hash ) or return;
+
+ ### we can only set passive mode in interactive sesssions, so bail out
+ ### if $FTP_PASSIVE is set
+ return if $FTP_PASSIVE;
+
+ ### see if we have a ncftp binary ###
+ if( my $ncftp = can_run('ncftp') ) {
+
+ my $cmd = [
+ $ncftp,
+ '-V', # do not be verbose
+ '-p', $FROM_EMAIL, # email as password
+ $self->host, # hostname
+ dirname($to), # local dir for the file
+ # remote path to the file
+ ### DO NOT quote things for IPC::Run, it breaks stuff.
+ $IPC::Cmd::USE_IPC_RUN
+ ? File::Spec::Unix->catdir( $self->path, $self->file )
+ : QUOTE. File::Spec::Unix->catdir(
+ $self->path, $self->file ) .QUOTE
+
+ ];
+
+ ### shell out ###
+ my $captured;
+ unless(run( command => $cmd,
+ buffer => \$captured,
+ verbose => $DEBUG )
+ ) {
+ return $self->_error(loc("Command failed: %1", $captured || ''));
+ }
+
+ return $to;
+
+ } else {
+ $METHOD_FAIL->{'ncftp'} = 1;
+ return;
+ }
+}
+
+### use /bin/curl to fetch files
+sub _curl_fetch {
+ my $self = shift;
+ my %hash = @_;
+
+ my ($to);
+ my $tmpl = {
+ to => { required => 1, store => \$to }
+ };
+ check( $tmpl, \%hash ) or return;
+
+ if (my $curl = can_run('curl')) {
+
+ ### these long opts are self explanatory - I like that -jmb
+ my $cmd = [ $curl, '-q' ];
+
+ push(@$cmd, '--connect-timeout', $TIMEOUT) if $TIMEOUT;
+
+ push(@$cmd, '--silent') unless $DEBUG;
+
+ ### curl does the right thing with passive, regardless ###
+ if ($self->scheme eq 'ftp') {
+ push(@$cmd, '--user', "anonymous:$FROM_EMAIL");
+ }
+
+ ### curl doesn't follow 302 (temporarily moved) etc automatically
+ ### so we add --location to enable that.
+ push @$cmd, '--fail', '--location', '--output', $to, $self->uri;
+
+ ### with IPC::Cmd > 0.41, this is fixed in teh library,
+ ### and there's no need for special casing any more.
+ ### DO NOT quote things for IPC::Run, it breaks stuff.
+ # $IPC::Cmd::USE_IPC_RUN
+ # ? ($to, $self->uri)
+ # : (QUOTE. $to .QUOTE, QUOTE. $self->uri .QUOTE);
+
+
+ my $captured;
+ unless(run( command => $cmd,
+ buffer => \$captured,
+ verbose => $DEBUG )
+ ) {
+
+ return $self->_error(loc("Command failed: %1", $captured || ''));
+ }
+
+ return $to;
+
+ } else {
+ $METHOD_FAIL->{'curl'} = 1;
+ return;
+ }
+}
+
+
+### use File::Copy for fetching file:// urls ###
+###
+### See section 3.10 of RFC 1738 (http://www.faqs.org/rfcs/rfc1738.html)
+### Also see wikipedia on file:// (http://en.wikipedia.org/wiki/File://)
+###
+
+sub _file_fetch {
+ my $self = shift;
+ my %hash = @_;
+
+ my ($to);
+ my $tmpl = {
+ to => { required => 1, store => \$to }
+ };
+ check( $tmpl, \%hash ) or return;
+
+
+
+ ### prefix a / on unix systems with a file uri, since it would
+ ### look somewhat like this:
+ ### file:///home/kane/file
+ ### wheras windows file uris for 'c:\some\dir\file' might look like:
+ ### file:///C:/some/dir/file
+ ### file:///C|/some/dir/file
+ ### or for a network share '\\host\share\some\dir\file':
+ ### file:////host/share/some/dir/file
+ ###
+ ### VMS file uri's for 'DISK$USER:[MY.NOTES]NOTE123456.TXT' might look like:
+ ### file://vms.host.edu/disk$user/my/notes/note12345.txt
+ ###
+
+ my $path = $self->path;
+ my $vol = $self->vol;
+ my $share = $self->share;
+
+ my $remote;
+ if (!$share and $self->host) {
+ return $self->_error(loc(
+ "Currently %1 cannot handle hosts in %2 urls",
+ 'File::Fetch', 'file://'
+ ));
+ }
+
+ if( $vol ) {
+ $path = File::Spec->catdir( split /\//, $path );
+ $remote = File::Spec->catpath( $vol, $path, $self->file);
+
+ } elsif( $share ) {
+ ### win32 specific, and a share name, so we wont bother with File::Spec
+ $path =~ s|/+|\\|g;
+ $remote = "\\\\".$self->host."\\$share\\$path";
+
+ } else {
+ ### File::Spec on VMS can not currently handle UNIX syntax.
+ my $file_class = ON_VMS
+ ? 'File::Spec::Unix'
+ : 'File::Spec';
+
+ $remote = $file_class->catfile( $path, $self->file );
+ }
+
+ ### File::Copy is littered with 'die' statements :( ###
+ my $rv = eval { File::Copy::copy( $remote, $to ) };
+
+ ### something went wrong ###
+ if( !$rv or $@ ) {
+ return $self->_error(loc("Could not copy '%1' to '%2': %3 %4",
+ $remote, $to, $!, $@));
+ }
+
+ return $to;
+}
+
+### use /usr/bin/rsync to fetch files
+sub _rsync_fetch {
+ my $self = shift;
+ my %hash = @_;
+
+ my ($to);
+ my $tmpl = {
+ to => { required => 1, store => \$to }
+ };
+ check( $tmpl, \%hash ) or return;
+
+ if (my $rsync = can_run('rsync')) {
+
+ my $cmd = [ $rsync ];
+
+ ### XXX: rsync has no I/O timeouts at all, by default
+ push(@$cmd, '--timeout=' . $TIMEOUT) if $TIMEOUT;
+
+ push(@$cmd, '--quiet') unless $DEBUG;
+
+ ### DO NOT quote things for IPC::Run, it breaks stuff.
+ push @$cmd, $self->uri, $to;
+
+ ### with IPC::Cmd > 0.41, this is fixed in teh library,
+ ### and there's no need for special casing any more.
+ ### DO NOT quote things for IPC::Run, it breaks stuff.
+ # $IPC::Cmd::USE_IPC_RUN
+ # ? ($to, $self->uri)
+ # : (QUOTE. $to .QUOTE, QUOTE. $self->uri .QUOTE);
+
+ my $captured;
+ unless(run( command => $cmd,
+ buffer => \$captured,
+ verbose => $DEBUG )
+ ) {
+
+ return $self->_error(loc("Command %1 failed: %2",
+ "@$cmd" || '', $captured || ''));
+ }
+
+ return $to;
+
+ } else {
+ $METHOD_FAIL->{'rsync'} = 1;
+ return;
+ }
+}
+
+#################################
+#
+# Error code
+#
+#################################
+
+=pod
+
+=head2 $ff->error([BOOL])
+
+Returns the last encountered error as string.
+Pass it a true value to get the C<Carp::longmess()> output instead.
+
+=cut
+
+### error handling the way Archive::Extract does it
+sub _error {
+ my $self = shift;
+ my $error = shift;
+
+ $self->_error_msg( $error );
+ $self->_error_msg_long( Carp::longmess($error) );
+
+ if( $WARN ) {
+ carp $DEBUG ? $self->_error_msg_long : $self->_error_msg;
+ }
+
+ return;
+}
+
+sub error {
+ my $self = shift;
+ return shift() ? $self->_error_msg_long : $self->_error_msg;
+}
+
+
+1;
+
+=pod
+
+=head1 HOW IT WORKS
+
+File::Fetch is able to fetch a variety of uris, by using several
+external programs and modules.
+
+Below is a mapping of what utilities will be used in what order
+for what schemes, if available:
+
+ file => LWP, lftp, file
+ http => LWP, wget, curl, lftp, lynx, iosock
+ ftp => LWP, Net::FTP, wget, curl, lftp, ncftp, ftp
+ rsync => rsync
+
+If you'd like to disable the use of one or more of these utilities
+and/or modules, see the C<$BLACKLIST> variable further down.
+
+If a utility or module isn't available, it will be marked in a cache
+(see the C<$METHOD_FAIL> variable further down), so it will not be
+tried again. The C<fetch> method will only fail when all options are
+exhausted, and it was not able to retrieve the file.
+
+C<iosock> is a very limited L<IO::Socket::INET> based mechanism for
+retrieving C<http> schemed urls. It doesn't follow redirects for instance.
+
+A special note about fetching files from an ftp uri:
+
+By default, all ftp connections are done in passive mode. To change
+that, see the C<$FTP_PASSIVE> variable further down.
+
+Furthermore, ftp uris only support anonymous connections, so no
+named user/password pair can be passed along.
+
+C</bin/ftp> is blacklisted by default; see the C<$BLACKLIST> variable
+further down.
+
+=head1 GLOBAL VARIABLES
+
+The behaviour of File::Fetch can be altered by changing the following
+global variables:
+
+=head2 $File::Fetch::FROM_EMAIL
+
+This is the email address that will be sent as your anonymous ftp
+password.
+
+Default is C<File-Fetch@example.com>.
+
+=head2 $File::Fetch::USER_AGENT
+
+This is the useragent as C<LWP> will report it.
+
+Default is C<File::Fetch/$VERSION>.
+
+=head2 $File::Fetch::FTP_PASSIVE
+
+This variable controls whether the environment variable C<FTP_PASSIVE>
+and any passive switches to commandline tools will be set to true.
+
+Default value is 1.
+
+Note: When $FTP_PASSIVE is true, C<ncftp> will not be used to fetch
+files, since passive mode can only be set interactively for this binary
+
+=head2 $File::Fetch::TIMEOUT
+
+When set, controls the network timeout (counted in seconds).
+
+Default value is 0.
+
+=head2 $File::Fetch::WARN
+
+This variable controls whether errors encountered internally by
+C<File::Fetch> should be C<carp>'d or not.
+
+Set to false to silence warnings. Inspect the output of the C<error()>
+method manually to see what went wrong.
+
+Defaults to C<true>.
+
+=head2 $File::Fetch::DEBUG
+
+This enables debugging output when calling commandline utilities to
+fetch files.
+This also enables C<Carp::longmess> errors, instead of the regular
+C<carp> errors.
+
+Good for tracking down why things don't work with your particular
+setup.
+
+Default is 0.
+
+=head2 $File::Fetch::BLACKLIST
+
+This is an array ref holding blacklisted modules/utilities for fetching
+files with.
+
+To disallow the use of, for example, C<LWP> and C<Net::FTP>, you could
+set $File::Fetch::BLACKLIST to:
+
+ $File::Fetch::BLACKLIST = [qw|lwp netftp|]
+
+The default blacklist is [qw|ftp|], as C</bin/ftp> is rather unreliable.
+
+See the note on C<MAPPING> below.
+
+=head2 $File::Fetch::METHOD_FAIL
+
+This is a hashref registering what modules/utilities were known to fail
+for fetching files (mostly because they weren't installed).
+
+You can reset this cache by assigning an empty hashref to it, or
+individually remove keys.
+
+See the note on C<MAPPING> below.
+
+=head1 MAPPING
+
+
+Here's a quick mapping for the utilities/modules, and their names for
+the $BLACKLIST, $METHOD_FAIL and other internal functions.
+
+ LWP => lwp
+ Net::FTP => netftp
+ wget => wget
+ lynx => lynx
+ ncftp => ncftp
+ ftp => ftp
+ curl => curl
+ rsync => rsync
+ lftp => lftp
+ IO::Socket => iosock
+
+=head1 FREQUENTLY ASKED QUESTIONS
+
+=head2 So how do I use a proxy with File::Fetch?
+
+C<File::Fetch> currently only supports proxies with LWP::UserAgent.
+You will need to set your environment variables accordingly. For
+example, to use an ftp proxy:
+
+ $ENV{ftp_proxy} = 'foo.com';
+
+Refer to the LWP::UserAgent manpage for more details.
+
+=head2 I used 'lynx' to fetch a file, but its contents is all wrong!
+
+C<lynx> can only fetch remote files by dumping its contents to C<STDOUT>,
+which we in turn capture. If that content is a 'custom' error file
+(like, say, a C<404 handler>), you will get that contents instead.
+
+Sadly, C<lynx> doesn't support any options to return a different exit
+code on non-C<200 OK> status, giving us no way to tell the difference
+between a 'successfull' fetch and a custom error page.
+
+Therefor, we recommend to only use C<lynx> as a last resort. This is
+why it is at the back of our list of methods to try as well.
+
+=head2 Files I'm trying to fetch have reserved characters or non-ASCII characters in them. What do I do?
+
+C<File::Fetch> is relatively smart about things. When trying to write
+a file to disk, it removes the C<query parameters> (see the
+C<output_file> method for details) from the file name before creating
+it. In most cases this suffices.
+
+If you have any other characters you need to escape, please install
+the C<URI::Escape> module from CPAN, and pre-encode your URI before
+passing it to C<File::Fetch>. You can read about the details of URIs
+and URI encoding here:
+
+ http://www.faqs.org/rfcs/rfc2396.html
+
+=head1 TODO
+
+=over 4
+
+=item Implement $PREFER_BIN
+
+To indicate to rather use commandline tools than modules
+
+=back
+
+=head1 BUG REPORTS
+
+Please report bugs or other issues to E<lt>bug-file-fetch@rt.cpan.org<gt>.
+
+=head1 AUTHOR
+
+This module by Jos Boumans E<lt>kane@cpan.orgE<gt>.
+
+=head1 COPYRIGHT
+
+This library is free software; you may redistribute and/or modify it
+under the same terms as Perl itself.
+
+
+=cut
+
+# Local variables:
+# c-indentation-style: bsd
+# c-basic-offset: 4
+# indent-tabs-mode: nil
+# End:
+# vim: expandtab shiftwidth=4:
+
+
+
+
generated by cgit v1.2.3 (git 2.39.1) at 2024-10-31 16:10:16 +0000