[Bps-public-commit] r15465 - in Shipwright/trunk: lib/Shipwright/Source

[sunnavy at bestpractical.com]

Author: sunnavy
Date: Tue Aug 26 02:53:54 2008
New Revision: 15465

Modified:
   Shipwright/trunk/   (props changed)
   Shipwright/trunk/Makefile.PL
   Shipwright/trunk/lib/Shipwright/Source/Base.pm
   Shipwright/trunk/lib/Shipwright/Source/Compressed.pm

Log:
 r16090 at sunnavys-mb:  sunnavy | 2008-08-26 14:52:34 +0800
 use Archive::Extract instead of tar cmd


Modified: Shipwright/trunk/Makefile.PL
==============================================================================
--- Shipwright/trunk/Makefile.PL	(original)
+++ Shipwright/trunk/Makefile.PL	Tue Aug 26 02:53:54 2008
@@ -29,6 +29,10 @@
 requires 'version' => 0;
 requires 'Module::Info' => 0;
 requires 'YAML::Tiny' => 0;
+requires 'IO::Uncompress::Bunzip2' => 0;
+requires 'Archive::Extract' => 0;
+requires 'IO::Uncompress::RawInflate' => '2.012';
+
 
 if ( can_cc() ) {
     requires( 'YAML::Syck' => 0.71 );

Modified: Shipwright/trunk/lib/Shipwright/Source/Base.pm
==============================================================================
--- Shipwright/trunk/lib/Shipwright/Source/Base.pm	(original)
+++ Shipwright/trunk/lib/Shipwright/Source/Base.pm	Tue Aug 26 02:53:54 2008
@@ -45,7 +45,12 @@
     my $self = shift;
     my %args = @_;
     for ( $self->_cmd ) {
-        Shipwright::Util->run($_);
+        if ( ref $_ eq 'CODE' ) {
+            $_->();
+        }
+        else {
+            Shipwright::Util->run($_);
+        }
     }
     $self->_copy( %{ $args{copy} } ) if $args{copy};
 }
@@ -320,6 +325,7 @@
                                 source  => $require->{$type}{$module}{source},
                                 name    => $name,
                                 version => undef,
+                                _path   => undef,
                             );
                         }
                         else {
@@ -328,6 +334,7 @@
                                 source  => "cpan:$module",
                                 version => undef,
                                 name => '',   # cpan name is automaticaly fixed.
+                                _path   => undef,
                             );
                         }
                         $s->run();

Modified: Shipwright/trunk/lib/Shipwright/Source/Compressed.pm
==============================================================================
--- Shipwright/trunk/lib/Shipwright/Source/Compressed.pm	(original)
+++ Shipwright/trunk/lib/Shipwright/Source/Compressed.pm	Tue Aug 26 02:53:54 2008
@@ -6,6 +6,8 @@
 use File::Spec::Functions qw/catfile catdir/;
 
 use base qw/Shipwright::Source::Base/;
+use Archive::Extract;
+use File::Temp qw/tempdir/;
 
 =head2 run
 
@@ -41,36 +43,34 @@
 
 sub path {
     my $self   = shift;
+
+    # we memoize path info so we don't need to extract on each call.
+    return $self->{_path} if $self->{_path};
+
     my $source = $self->source;
-    my ($out) = Shipwright::Util->run( [ 'tar', '-t', '-f', $source ] );
-    my $sep = $/;
-    my @contents = split /$sep/, $out;
-    my %path;
+    my $ae = Archive::Extract->new( archive => $source );
+    # this's to check if $source is valid, aka. it only contains one directory.
+    my $tmp_dir = tempdir( 'shipwright_tmp_XXXXXX', CLEANUP => 1, TMPDIR => 1 );
+    $ae->extract( to => $tmp_dir );
+    my $files = $ae->files;
+
+    my $base_dir = $files->[0];
 
-    for (@contents) {
-        $path{$1} = 1 if m{^(.+?)/};
+    if ( @$files != grep { /^\Q$base_dir\E/ } @$files ) {
+        croak 'only support compressed file which contains only one directory';
     }
 
-    my @paths = keys %path;
-    croak 'only support compressed file which contains only one directory'
-      unless @paths == 1;
-    return $paths[0];
+    $base_dir =~ s![/\\]$!!; # trim the last / or \\ if possible
+
+    $self->{_path} = $base_dir;
+
+    return $base_dir;
 }
 
 sub _cmd {
     my $self = shift;
     my $arg;
 
-    if ( $self->source =~ /\.(tar\.|t)gz$/ ) {
-        $arg = 'xfz';
-    }
-    elsif ( $self->source =~ /\.tar\.bz2$/ ) {
-        $arg = 'xfj';
-    }
-    else {
-        croak "I've no idea what the cmd is";
-    }
-
     my ( $from, $to );
     $from = catfile( $self->directory, $self->path );
     $to   = catfile( $self->directory, $self->name );
@@ -79,11 +79,13 @@
     # again
     return if -e $to;
 
+    my $ae = Archive::Extract->new( archive => $self->source );
+
     my @cmds;
-    push @cmds, [ 'tar', $arg, $self->source, '-C', $self->directory ];
+    push @cmds, sub { $ae->extract( to => $self->directory ) };
 
     if ( $from ne $to ) {
-        push @cmds, [ 'mv', $from, $to, ];
+        push @cmds, [ 'mv', $from, $to ];
     }
 
     return @cmds;