Update File-Fetch to CPAN version 0.42

  [DELTA]

  Changes for 0.42        Fri Apr 12 15:28:34 2013
  =================================================
  * Skip slurp tests for git://

  Changes for 0.40        Fri Apr 12 11:18:52 2013
  =================================================
  * Added git:// url support

diff --git a/Porting/Maintainers.pl b/Porting/Maintainers.pl
index c910406..c69d718 100755 (executable)
--- a/Porting/Maintainers.pl
+++ b/Porting/Maintainers.pl
@@ -762,7 +762,7 @@ use File::Glob qw(:case);
 
     'File::Fetch' => {
         'MAINTAINER'   => 'kane',
-        'DISTRIBUTION' => 'BINGOS/File-Fetch-0.38.tar.gz',
+        'DISTRIBUTION' => 'BINGOS/File-Fetch-0.42.tar.gz',
         'FILES'        => q[cpan/File-Fetch],
         'UPSTREAM'     => 'cpan',
     },

diff --git a/cpan/File-Fetch/lib/File/Fetch.pm b/cpan/File-Fetch/lib/File/Fetch.pm
index 37f7bc6..75e42c6 100644 (file)
--- a/cpan/File-Fetch/lib/File/Fetch.pm
+++ b/cpan/File-Fetch/lib/File/Fetch.pm
@@ -22,7 +22,7 @@ use vars    qw[ $VERBOSE $PREFER_BIN $FROM_EMAIL $USER_AGENT
                 $FTP_PASSIVE $TIMEOUT $DEBUG $WARN
             ];
 
-$VERSION        = '0.38';
+$VERSION        = '0.42';
 $VERSION        = eval $VERSION;    # avoid warnings with development releases
 $PREFER_BIN     = 0;                # XXX TODO implement
 $FROM_EMAIL     = 'File-Fetch@example.com';
@@ -39,7 +39,8 @@ $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| ]
+    rsync   => [ qw|rsync| ],
+    git     => [ qw|git| ],
 };
 
 ### silly warnings ###
@@ -87,7 +88,7 @@ File::Fetch - A generic file fetching mechanism
 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.
+C<file>, C<git> or C<rsync> uri by a number of different means.
 
 See the C<HOW IT WORKS> section further down for details.
 
@@ -1402,6 +1403,52 @@ sub _rsync_fetch {
 
 }
 
+### use git to fetch files
+sub _git_fetch {
+    my $self = shift;
+    my %hash = @_;
+
+    my ($to);
+    my $tmpl = {
+        to  => { required => 1, store => \$to }
+    };
+    check( $tmpl, \%hash ) or return;
+    my $git;
+    unless ( $git = can_run('git') ) {
+        $METHOD_FAIL->{'git'} = 1;
+        return;
+    }
+
+    my $cmd = [ $git, 'clone' ];
+
+    #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;
+
+}
+
 #################################
 #
 # Error code
@@ -1454,6 +1501,7 @@ for what schemes, if available:
     http    => LWP, HTTP::Lite, wget, curl, lftp, fetch, lynx, iosock
     ftp     => LWP, Net::FTP, wget, curl, lftp, fetch, ncftp, ftp
     rsync   => rsync
+    git     => git
 
 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.
@@ -1470,6 +1518,8 @@ three platforms.
 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.
 
+C<git> only supports C<git://> style urls.
+
 A special note about fetching files from an ftp uri:
 
 By default, all ftp connections are done in passive mode. To change

diff --git a/cpan/File-Fetch/t/01_File-Fetch.t b/cpan/File-Fetch/t/01_File-Fetch.t
index 538c55e..e4fdccf 100644 (file)
--- a/cpan/File-Fetch/t/01_File-Fetch.t
+++ b/cpan/File-Fetch/t/01_File-Fetch.t
@@ -7,6 +7,7 @@ use Test::More 'no_plan';
 
 use Cwd             qw[cwd];
 use File::Basename  qw[basename];
+use File::Path      qw[rmtree];
 use Data::Dumper;
 
 use_ok('File::Fetch');
@@ -46,7 +47,7 @@ if( $File::Fetch::DEBUG ) {
 }
 
 ### Heuristics
-my %heuristics = map { $_ => 1 } qw(http ftp rsync file);
+my %heuristics = map { $_ => 1 } qw(http ftp rsync file git);
 ### _parse_uri tests
 ### these go on all platforms
 my @map = (
@@ -62,6 +63,12 @@ my @map = (
         path   => '/CPAN/',
         file   => 'MIRRORING.FROM',
     },
+    {  uri         => 'git://github.com/jib/file-fetch.git',
+        scheme => 'git',
+        host   => 'github.com',
+        path   => '/jib/',
+        file   => 'file-fetch.git',
+    },
     {   uri     => 'http://localhost/tmp/index.txt',
         scheme  => 'http',
         host    => 'localhost',          # host is empty only on 'file://'
@@ -216,6 +223,21 @@ for my $entry (@map) {
     }
 }
 
+### Heuristics
+{
+  require IO::Socket::INET;
+  my $sock = IO::Socket::INET->new( PeerAddr => 'github.com', PeerPort => 9418, Timeout => 20 )
+     or $heuristics{git} = 0;
+}
+
+### git:// tests ###
+{   my $uri = 'git://github.com/jib/file-fetch.git';
+
+    for (qw[git]) {
+        _fetch_uri( git => $uri, $_ );
+    }
+}
+
 sub _fetch_uri {
     my $type    = shift;
     my $uri     = shift;
@@ -240,7 +262,7 @@ sub _fetch_uri {
         for my $to ( 'tmp', do { \my $o } ) { SKIP: {
 
 
-            my $how     = ref $to ? 'slurp' : 'file';
+            my $how     = ref $to && $type ne 'git' ? 'slurp' : 'file';
             my $skip    = ref $to ? 4       : 3;
 
             ok( 1,              "   Fetching '$uri' in $how mode" );
@@ -258,7 +280,7 @@ sub _fetch_uri {
             ok( $file,          "   File ($file) fetched with $method ($uri)" );
 
             ### check we got some contents if we were meant to slurp
-            if( ref $to ) {
+            if( ref $to && $type ne 'git' ) {
                 ok( $$to,       "   Contents slurped" );
             }
 
@@ -267,7 +289,7 @@ sub _fetch_uri {
             is( $file && basename($file), $ff->output_file,
                                 "   File has expected name" );
 
-            unlink $file;
+            rmtree $file;
         }}
     }
 }