From: Jos I. Boumans <jos@dwim.org>
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<cwd()>,
-but you can override that by specifying the C<to> argument.
+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.
@@ -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;
-        }
+        }}
     }
 }