From: Jos I. Boumans Date: Sat, 27 Jun 2009 15:35:17 +0000 (+0200) Subject: Upgrade to File::Fetch 0.20 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=8d16e270aaf343d05def7ca91debc167b1188b25;p=p5sagit%2Fp5-mst-13.2.git Upgrade to File::Fetch 0.20 --- diff --git a/lib/File/Fetch.pm b/lib/File/Fetch.pm index 03bf147..d093560 100644 --- a/lib/File/Fetch.pm +++ b/lib/File/Fetch.pm @@ -12,6 +12,7 @@ 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'; @@ -21,7 +22,7 @@ use vars qw[ $VERBOSE $PREFER_BIN $FROM_EMAIL $USER_AGENT $FTP_PASSIVE $TIMEOUT $DEBUG $WARN ]; -$VERSION = '0.18'; +$VERSION = '0.20'; $VERSION = eval $VERSION; # avoid warnings with development releases $PREFER_BIN = 0; # XXX TODO implement $FROM_EMAIL = 'File-Fetch@example.com'; @@ -397,10 +398,19 @@ sub _parse_uri { return $href; } -=head2 $ff->fetch( [to => /my/output/dir/] ) +=head2 $where = $ff->fetch( [to => /my/output/dir/ | \$scalar] ) -Fetches the file you requested. By default it writes to C, -but you can override that by specifying the C argument. +Fetches the file you requested and returns the full path to the file. + +By default it writes to C, but you can override that by specifying +the C 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. @@ -411,21 +421,31 @@ sub fetch { my $self = shift or return; my %hash = @_; - my $to; + my $target; my $tmpl = { - to => { default => cwd(), store => \$to }, + to => { default => cwd(), store => \$target }, }; check( $tmpl, \%hash ) or return; - ### On VMS force to VMS format so File::Spec will work. - $to = VMS::Filespec::vmspath($to) if ON_VMS; + 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; - ### create the path if it doesn't exist yet ### - unless( -d $to ) { - eval { mkpath( $to ) }; + ### On VMS force to VMS format so File::Spec will work. + $to = VMS::Filespec::vmspath($to) if ON_VMS; - return $self->_error(loc("Could not create path '%1'",$to)) if $@; + ### 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 ### @@ -474,8 +494,24 @@ sub fetch { } 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; + } } } diff --git a/lib/File/Fetch/t/01_File-Fetch.t b/lib/File/Fetch/t/01_File-Fetch.t index 519ca27..1cd7e8d 100644 --- a/lib/File/Fetch/t/01_File-Fetch.t +++ b/lib/File/Fetch/t/01_File-Fetch.t @@ -204,29 +204,43 @@ sub _fetch_uri { $File::Fetch::METHODS = $File::Fetch::METHODS = { $type => [$method] }; + ### fetch regularly my $ff = File::Fetch->new( uri => $uri ); - + ok( $ff, "FF object for $uri (fetch with $method)" ); - - my $file = $ff->fetch( to => 'tmp' ); - - SKIP: { - skip "You do not have '$method' installed/available", 3 + + for my $to ( 'tmp', do { \my $o } ) { SKIP: { + + + my $how = ref $to ? 'slurp' : 'file'; + my $skip = ref $to ? 4 : 3; + + ok( 1, " Fetching '$uri' in $how mode" ); + + my $file = $ff->fetch( to => $to ); + + skip "You do not have '$method' installed/available", $skip if $File::Fetch::METHOD_FAIL->{$method} && $File::Fetch::METHOD_FAIL->{$method}; ### if the file wasn't fetched, it may be a network/firewall issue - skip "Fetch failed; no network connectivity for '$type'?", 3 + skip "Fetch failed; no network connectivity for '$type'?", $skip unless $file; ok( $file, " File ($file) fetched with $method ($uri)" ); + + ### check we got some contents if we were meant to slurp + if( ref $to ) { + ok( $$to, " Contents slurped" ); + } + ok( $file && -s $file, " File has size" ); is( $file && basename($file), $ff->output_file, " File has expected name" ); unlink $file; - } + }} } }