[Bps-public-commit] r15467 - in Shipwright/branches/1.10: . share/bin
sunnavy at bestpractical.com
sunnavy at bestpractical.com
Tue Aug 26 02:55:21 EDT 2008
Author: sunnavy
Date: Tue Aug 26 02:55:21 2008
New Revision: 15467
Modified:
Shipwright/branches/1.10/Makefile.PL
Shipwright/branches/1.10/lib/Shipwright/Source/Base.pm
Shipwright/branches/1.10/lib/Shipwright/Source/Compressed.pm
Shipwright/branches/1.10/share/bin/shipwright-builder
Log:
merged 15465:15466 to 1.1
Modified: Shipwright/branches/1.10/Makefile.PL
==============================================================================
--- Shipwright/branches/1.10/Makefile.PL (original)
+++ Shipwright/branches/1.10/Makefile.PL Tue Aug 26 02:55:21 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/branches/1.10/lib/Shipwright/Source/Base.pm
==============================================================================
--- Shipwright/branches/1.10/lib/Shipwright/Source/Base.pm (original)
+++ Shipwright/branches/1.10/lib/Shipwright/Source/Base.pm Tue Aug 26 02:55:21 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/branches/1.10/lib/Shipwright/Source/Compressed.pm
==============================================================================
--- Shipwright/branches/1.10/lib/Shipwright/Source/Compressed.pm (original)
+++ Shipwright/branches/1.10/lib/Shipwright/Source/Compressed.pm Tue Aug 26 02:55:21 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;
Modified: Shipwright/branches/1.10/share/bin/shipwright-builder
==============================================================================
--- Shipwright/branches/1.10/share/bin/shipwright-builder (original)
+++ Shipwright/branches/1.10/share/bin/shipwright-builder Tue Aug 26 02:55:21 2008
@@ -11,6 +11,7 @@
use Getopt::Long;
use Cwd qw/getcwd abs_path/;
use inc::YAML::Tiny;
+use Carp qw/confess/;
my $build_base = getcwd;
@@ -25,7 +26,7 @@
'force', 'clean',
'name=s', 'help',
'noclean', 'only=s',
- 'with=s',
+ 'with=s', 'noclean-after-install',
);
my $USAGE = <<'END'
@@ -175,44 +176,31 @@
my $log;
if ( $args{'only-test'} ) {
- open $log, '>', 'test.log' or die $!;
+ open $log, '>', 'test.log' or confess $!;
test();
}
elsif ( $args{'clean'} ) {
- open $log, '>', 'clean.log' or die $!;
-
- system('rm -rf tmp_dists') && die "rm tmp_dists failed\n";
-
- print $log "removed tmp_dists";
-
- for my $dist (@$order) {
- clean($dist);
- chdir $build_base;
- }
-
- unlink '__need_clean';
+ clean();
}
else {
-
- # for install
- open $log, '>', 'build.log' or die $!;
-
if ( -e '__need_clean' && !$args{noclean} ) {
print "seems it has been built before, need to clean first\n";
- print $log "seems it has been built before, need to clean first\n";
- system(
- "$0 --clean "
- . (
- $args{only}
- ? '--only ' . join( ',', keys %{ $args{only} } )
- : '--skip ' . ( join( ',', keys %{ $args{skip} } || q{''} ) )
- )
- ) && die 'clean failed.';
+ clean();
+ }
+ install();
+ unless ( $args{'noclean-after-install'} ) {
+ clean();
+ print "install finished, the dists are at $args{'install-base'}\n";
}
+}
+
+sub install {
+ # for install
+ open my $log, '>', 'build.log' or confess $!;
# set clean flag again
- open my $tmp_fh, '>', '__need_clean' or die $!;
+ open my $tmp_fh, '>', '__need_clean' or confess $!;
close $tmp_fh;
process_tmp_dists() if keys %{ $args{with} };
@@ -231,7 +219,7 @@
};
open my $fh, '>', '__install_base'
- or die "can't write to __install_base: $!";
+ or confess "can't write to __install_base: $!";
print $fh $args{'install-base'};
close $fh;
@@ -287,21 +275,23 @@
catfile( $args{'install-base'}, 'tools', 'shipwright-utility' );
for my $dist (@$order) {
- install($dist);
- record($dist);
+ _install($dist, $log);
+ _record($dist, $log);
chdir $build_base;
}
mkdir catfile( $args{'install-base'}, 'bin' )
unless -e catfile( $args{'install-base'}, 'bin' );
- wrap_bin();
+ wrap_bin( $log );
+
print "install finished, the dists are at $args{'install-base'}\n";
print $log "install finished, the dists are at $args{'install-base'}\n";
}
-sub install {
+sub _install {
my $dir = shift;
+ my $log = shift;
if ( $args{with}{$dir} && -e catfile( 'tmp_dists', $dir ) ) {
chdir catfile( 'tmp_dists', $dir );
@@ -330,7 +320,7 @@
$args{'clean'} ? '--clean' : ();
if ( system($cmd) ) {
print $log "build $dir with failure.\n";
- die "build $dir with failure.\n";
+ confess "build $dir with failure.\n";
}
}
else {
@@ -363,7 +353,7 @@
next;
}
}
- die "build $dir $type part with failure.\n";
+ confess "build $dir $type part with failure.\n";
}
else {
print $log "build $dir $type part with success!\n";
@@ -376,7 +366,7 @@
}
sub wrap_bin {
- my $self = shift;
+ my $log = shift;
my $sub = sub {
my $file = $_;
@@ -402,7 +392,7 @@
my $type;
if ( -T $file ) {
- open my $fh, '<', $file or die "can't open $file: $!";
+ open my $fh, '<', $file or confess "can't open $file: $!";
my $shebang = <$fh>;
if (
$shebang =~ m{
@@ -416,7 +406,7 @@
}
move( $file => catfile( $args{'install-base'}, "$dir-wrapped" ) )
- or die $!;
+ or confess $!;
# if we have this $type(e.g. perl) installed and have that specific wrapper,
# then link to it, else link to the normal one
@@ -425,12 +415,12 @@
&& -e catfile( '..', 'etc', "shipwright-$type-wrapper" ) )
{
symlink catfile( '..', 'etc', "shipwright-$type-wrapper" ) => $file
- or die $!;
+ or confess $!;
}
else {
symlink catfile( '..', 'etc', 'shipwright-script-wrapper' ) => $file
- or die $!;
+ or confess $!;
}
chmod oct 755, $file;
};
@@ -473,7 +463,7 @@
my ( $type, $cmd ) = @$_;
print $log "run tests $type part with cmd: $cmd\n";
if ( system($cmd ) ) {
- die "something wrong when execute $cmd.";
+ confess "something wrong when execute $cmd.";
}
else {
print $log "run test $type part with success\n";
@@ -488,7 +478,7 @@
my @cmds;
{
- open my $fh, '<', $file or die "$!: $file";
+ open my $fh, '<', $file or confess "$!: $file";
@cmds = <$fh>;
close $fh;
chomp @cmds;
@@ -515,7 +505,25 @@
}
sub clean {
+ open my $log, '>', 'clean.log' or confess $!;
+
+ system('rm -rf tmp_dists') && confess "rm tmp_dists failed\n";
+
+ print $log "removed tmp_dists";
+
+ chdir $build_base;
+ for my $dist (@$order) {
+ _clean($dist, $log);
+ chdir $build_base;
+ }
+
+ unlink '__need_clean';
+}
+
+
+sub _clean {
my $dir = shift;
+ my $log = shift;
my $cmd;
chdir catfile( 'dists', $dir );
@@ -565,7 +573,7 @@
for my $name ( keys %{ $args{with} } ) {
my $cmd = cmd( $name, $args{with}{$name} );
if ($cmd) {
- system($cmd) && die "run $cmd with failure";
+ system($cmd) && confess "run $cmd with failure";
}
}
}
@@ -592,7 +600,7 @@
return;
}
-sub record {
+sub _record {
my $dist = shift;
push @{ $installed->[0] }, $dist;
$installed->write($installed_file);
More information about the Bps-public-commit
mailing list