Alien-ROOT
view release on metacpan or search on metacpan
inc/inc_File-Fetch/File/Fetch.pm view on Meta::CPAN
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.36';
$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 httptiny wget curl lftp fetch httplite lynx iosock| ],
ftp => [ qw|lwp netftp wget curl lftp fetch 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);
use constant HAS_FETCH => ( $^O =~ m!^(freebsd|netbsd|dragonfly)$! );
=pod
=head1 NAME
File::Fetch - A generic file fetching mechanism
=head1 SYNOPSIS
use File::Fetch;
inc/inc_File-Fetch/File/Fetch.pm view on Meta::CPAN
=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, $file_default);
my $tmpl = {
uri => { required => 1, store => \$uri },
file_default => { required => 0, store => \$file_default },
};
check( $tmpl, \%hash ) or return;
### parse the uri to usable parts ###
my $href = $class->_parse_uri( $uri ) or return;
$href->{file_default} = $file_default if $file_default;
### 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 $@;
}
inc/inc_File-Fetch/File/Fetch.pm view on Meta::CPAN
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;
}
}
### HTTP::Tiny fetching ###
sub _httptiny_fetch {
my $self = shift;
my %hash = @_;
my ($to);
my $tmpl = {
to => { required => 1, store => \$to }
};
check( $tmpl, \%hash ) or return;
my $use_list = {
'HTTP::Tiny' => '0.008',
};
if( can_load(modules => $use_list) ) {
my $uri = $self->uri;
my $http = HTTP::Tiny->new( ( $TIMEOUT ? ( timeout => $TIMEOUT ) : () ) );
my $rc = $http->mirror( $uri, $to );
unless ( $rc->{success} ) {
return $self->_error(loc( "Fetch failed! HTTP response: %1 [%2]",
inc/inc_File-Fetch/File/Fetch.pm view on Meta::CPAN
$uri = $loc;
}
next RETRIES;
}
elsif ( $rc == 200 ) {
return $to;
}
else {
return $self->_error(loc("Fetch failed! HTTP response: %1 [%2]",
$rc, $http->status_message));
}
} # Loop for 5 retries.
return $self->_error("Fetch failed! Gave up after 5 tries");
} else {
$METHOD_FAIL->{'httplite'} = 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,$!));
}
$fh->autoflush(1);
binmode $fh;
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 preceding 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));
}
{
local $\;
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
inc/inc_File-Fetch/File/Fetch.pm view on Meta::CPAN
# $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 sessions, 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,
inc/inc_File-Fetch/File/Fetch.pm view on Meta::CPAN
### no verboseness, thanks ###
my $cmd = [ $fetch, '-q' ];
### if a timeout is set, add it ###
push(@$cmd, '-T', $TIMEOUT) if $TIMEOUT;
### run passive if specified ###
#push @$cmd, '-p' if $FTP_PASSIVE;
local $ENV{'FTP_PASSIVE_MODE'} = 1 if $FTP_PASSIVE;
### set the output document, add the uri ###
push @$cmd, '-o', $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;
}
}
### 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
### whereas 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 {
( run in 1.314 second using v1.01-cache-2.11-cpan-64ef6c95b5d )