[Bps-public-commit] r13660 - in Shipwright/trunk: lib/Shipwright/Backend
sunnavy at bestpractical.com
sunnavy at bestpractical.com
Fri Jun 27 14:14:49 EDT 2008
Author: sunnavy
Date: Fri Jun 27 14:14:49 2008
New Revision: 13660
Modified:
Shipwright/trunk/ (props changed)
Shipwright/trunk/lib/Shipwright/Backend/FS.pm
Shipwright/trunk/lib/Shipwright/Backend/SVK.pm
Shipwright/trunk/lib/Shipwright/Backend/SVN.pm
Log:
r13895 at sunnavys-mb: sunnavy | 2008-06-28 01:29:43 +0800
refactor backend a lot
Modified: Shipwright/trunk/lib/Shipwright/Backend/FS.pm
==============================================================================
--- Shipwright/trunk/lib/Shipwright/Backend/FS.pm (original)
+++ Shipwright/trunk/lib/Shipwright/Backend/FS.pm Fri Jun 27 14:14:49 2008
@@ -5,16 +5,12 @@
use Carp;
use File::Spec;
use Shipwright::Util;
-use File::Temp qw/tempdir/;
use File::Copy qw/copy/;
use File::Copy::Recursive qw/dircopy/;
-use List::MoreUtils qw/uniq/;
-use File::Path;
our %REQUIRE_OPTIONS = ( import => [qw/source/] );
-use base qw/Class::Accessor::Fast/;
-__PACKAGE__->mk_accessors(qw/repository log/);
+use base qw/Shipwright::Backend::Base/;
=head1 NAME
@@ -28,21 +24,6 @@
=over
-=item new
-
-This is the constructor.
-
-=cut
-
-sub new {
- my $class = shift;
- my $self = {@_};
-
- bless $self, $class;
- $self->log( Log::Log4perl->get_logger( ref $self ) );
- return $self;
-}
-
=item initialize
Initialize a project.
@@ -52,99 +33,13 @@
sub initialize {
my $self = shift;
- $self->delete; # clean repository in case it exists
- mkpath $self->repository unless -e $self->repository;
-
- dircopy( Shipwright::Util->share_root, $self->repository );
-
- # share_root can't keep empty dirs, we have to create them manually
- for (qw/dists scripts t/) {
- mkdir File::Spec->catfile( $self->repository, $_ );
- }
-
- # hack for share_root living under blib/
- unlink( File::Spec->catfile( $self->repository, '.exists' ) );
-
- return 1;
-}
-
-=item import
-
-Import a dist.
-
-=cut
-
-sub import {
- my $self = shift;
- return unless @_;
- my %args = @_;
- my $name = $args{source};
- $name =~ s{.*/}{};
-
- unless ( $args{_extra_tests} ) {
- if ( $args{build_script} ) {
- if ( $self->info( path => "scripts/$name" )
- && not $args{overwrite} )
- {
- $self->log->warn(
-"path scripts/$name alreay exists, need to set overwrite arg to overwrite"
- );
- }
- else {
- $self->log->info(
- "import $args{source}'s scripts to " . $self->repository );
- Shipwright::Util->run(
- $self->_cmd( import => %args, name => $name ) );
- }
- }
- else {
- if ( $self->info( path => "dists/$name" ) && not $args{overwrite} )
- {
- $self->log->warn(
-"path dists/$name alreay exists, need to set overwrite arg to overwrite"
- );
- }
- else {
- $self->log->info(
- "import $args{source} to " . $self->repository );
- $self->_add_to_order($name);
-
- my $version = $self->version;
- $version->{$name} = $args{version};
- $self->version($version);
+ my $dir = $self->SUPER::initialize(@_);
- Shipwright::Util->run(
- $self->_cmd( import => %args, name => $name ) );
- }
- }
- }
- else {
- Shipwright::Util->run( $self->_cmd( import => %args, name => $name ) );
- }
-}
-
-=item export
-
-
-=cut
+ $self->delete; # clean repository in case it exists
-sub export {
- my $self = shift;
- my %args = @_;
- my $path = $args{path} || '';
- $self->log->info(
- 'export ' . $self->repository . "/$path to $args{target}" );
- Shipwright::Util->run( $self->_cmd( checkout => %args ) );
+ dircopy( $dir, $self->repository );
}
-=item checkout
-
-=cut
-
-sub checkout;
-
-*checkout = *export;
-
# a cmd generating factory
sub _cmd {
my $self = shift;
@@ -158,7 +53,7 @@
my $cmd;
- if ( $type eq 'checkout' ) {
+ if ( $type eq 'checkout' || $type eq 'export' ) {
$cmd = [ 'cp', '-r', $self->repository . $args{path}, $args{target} ];
}
elsif ( $type eq 'import' ) {
@@ -193,7 +88,7 @@
join( '/', $self->repository, $args{new_path} )
];
}
- elsif ( $type eq 'info' ) {
+ elsif ( $type eq 'info' || $type eq 'list' ) {
$cmd = [ 'ls', join '/', $self->repository, $args{path} ];
}
else {
@@ -203,89 +98,6 @@
return $cmd;
}
-# add a dist to order
-
-sub _add_to_order {
- my $self = shift;
- my $name = shift;
-
- my $order = $self->order;
-
- unless ( grep { $name eq $_ } @$order ) {
- $self->log->info( "add $name to order for " . $self->repository );
- push @$order, $name;
- $self->order($order);
- }
-}
-
-=item update_order
-
-Regenerate the dependency order.
-
-=cut
-
-sub update_order {
- my $self = shift;
- my %args = @_;
-
- $self->log->info( "update order for " . $self->repository );
-
- my @dists = @{ $args{for_dists} || [] };
- unless (@dists) {
- my ($out) =
- Shipwright::Util->run( [ 'ls', $self->repository . '/scripts' ] );
- @dists = split /\s+/, $out;
- chomp @dists;
- s{/$}{} for @dists;
- }
-
- my $require = {};
-
- for (@dists) {
- $self->_fill_deps( %args, require => $require, name => $_ );
- }
-
- require Algorithm::Dependency::Ordered;
- require Algorithm::Dependency::Source::HoA;
-
- my $source = Algorithm::Dependency::Source::HoA->new($require);
- $source->load();
- my $dep = Algorithm::Dependency::Ordered->new( source => $source, )
- or die $@;
- my $order = $dep->schedule_all();
-
- $self->order($order);
-}
-
-sub _fill_deps {
- my $self = shift;
- my %args = @_;
- my $require = $args{require};
- my $name = $args{name};
-
- return if $require->{$name};
- my $req = Shipwright::Util::LoadFile(
- $self->repository . "/scripts/$name/require.yml" );
-
- if ( $req->{requires} ) {
- for (qw/requires recommends build_requires/) {
- push @{ $require->{$name} }, keys %{ $req->{$_} }
- if $args{"keep_$_"};
- }
- @{ $require->{$name} } = uniq @{ $require->{$name} };
- }
- else {
-
- #for back compatbility
- push @{ $require->{$name} }, keys %$req;
- }
-
- for my $dep ( @{ $require->{$name} } ) {
- next if $require->{$dep};
- $self->_fill_deps( %args, name => $dep, require => $require );
- }
-}
-
=item _yml
@@ -306,83 +118,6 @@
}
}
-=item order
-
-Get or set the dependency order.
-
-=cut
-
-sub order {
- my $self = shift;
- my $order = shift;
- my $path = File::Spec->catfile( 'shipwright', 'order.yml' );
- return $self->_yml( $path, $order );
-}
-
-=item map
-
-Get or set the map.
-
-=cut
-
-sub map {
- my $self = shift;
- my $map = shift;
-
- my $path = File::Spec->catfile( 'shipwright', 'map.yml' );
- return $self->_yml( $path, $map );
-}
-
-=item source
-
-Get or set the sources map.
-
-=cut
-
-sub source {
- my $self = shift;
- my $source = shift;
- my $path = File::Spec->catfile( 'shipwright', 'source.yml' );
- return $self->_yml( $path, $source );
-}
-
-=item delete
-
-
-=cut
-
-sub delete {
- my $self = shift;
- my %args = @_;
- my $path = $args{path} || '';
- if ( $self->info( path => $path ) ) {
- $self->log->info( "delete " . $self->repository . "/$path" );
- Shipwright::Util->run( $self->_cmd( delete => path => $path ), 1 );
- }
-}
-
-=item move
-
-
-=cut
-
-sub move {
- my $self = shift;
- my %args = @_;
- my $path = $args{path} || '';
- my $new_path = $args{new_path} || '';
- if ( $self->info( path => $path ) ) {
- $self->log->info(
- "move " . $self->repository . "/$path to /$new_path" );
- Shipwright::Util->run(
- $self->_cmd(
- move => path => $path,
- new_path => $new_path,
- ),
- );
- }
-}
-
=item info
@@ -393,9 +128,7 @@
my %args = @_;
my $path = $args{path} || '';
- my ( $info, $err ) =
- Shipwright::Util->run( $self->_cmd( info => path => $path ), 1 );
- $self->log->warn($err) if $err;
+ my ( $info, $err ) = $self->SUPER::info( path => $path );
if (wantarray) {
return $info, $err;
@@ -423,49 +156,6 @@
copy( $args{source}, $file );
}
-=item requires
-
-Return the hashref of require.yml for a dist.
-
-=cut
-
-sub requires {
- my $self = shift;
- my %args = @_;
- my $name = $args{name};
-
- return $self->_yml(
- File::Spec->catfile( 'scripts', $name, 'require.yml' ) );
-}
-
-=item flags
-
-Get or set flags.
-
-=cut
-
-sub flags {
- my $self = shift;
- my $flags = shift;
-
- my $path = File::Spec->catfile( 'shipwright', 'flags.yml' );
- return $self->_yml( $path, $flags );
-}
-
-=item version
-
-Get or set version.
-
-=cut
-
-sub version {
- my $self = shift;
- my $version = shift;
-
- my $path = File::Spec->catfile( 'shipwright', 'version.yml' );
- return $self->_yml( $path, $version );
-}
-
=item check_repository
Check if the given repository is valid.
@@ -474,20 +164,7 @@
sub check_repository {
my $self = shift;
- my %args = @_;
-
- if ( $args{action} eq 'create' ) {
- return 1;
- }
- else {
-
- # every valid shipwright repo has 'shipwright' subdir;
- my $info = $self->info( path => 'shipwright' );
-
- return 1 if $info;
- }
-
- return;
+ return $self->SUPER::check_repository(@_);
}
=item update
@@ -497,42 +174,14 @@
=cut
sub update {
- my $self = shift;
- my %args = @_;
-
- croak "need path option" unless $args{path};
-
- croak "$args{path} seems not shipwright's own file"
- unless -e File::Spec->catfile( Shipwright::Util->share_root,
- $args{path} );
-
- $args{path} = '/' . $args{path} unless $args{path} =~ m{^/};
+ my $self = shift;
+ my %args = @_;
+ my $latest = $self->SUPER::update(@_);
my $file =
File::Spec->catfile( $self->repository, 'shipwright', $args{path} );
- copy( File::Spec->catfile( Shipwright::Util->share_root, $args{path} ),
- $file );
-}
-
-=item ktf
-
-Get or set known failure conditions.
-
-=cut
-
-sub ktf {
- my $self = shift;
- my $failure = shift;
-
- my $file =
- File::Spec->catfile( $self->repository, 'shipwright', 'ktf.yml' );
- if ($failure) {
- Shipwright::Util::DumpFile( $file, $failure );
- }
- else {
- Shipwright::Util::LoadFile($file) || {};
- }
+ copy( $latest, $file );
}
=back
Modified: Shipwright/trunk/lib/Shipwright/Backend/SVK.pm
==============================================================================
--- Shipwright/trunk/lib/Shipwright/Backend/SVK.pm (original)
+++ Shipwright/trunk/lib/Shipwright/Backend/SVK.pm Fri Jun 27 14:14:49 2008
@@ -7,13 +7,10 @@
use Shipwright::Util;
use File::Temp qw/tempdir/;
use File::Copy qw/copy/;
-use File::Copy::Recursive qw/dircopy/;
-use List::MoreUtils qw/uniq/;
our %REQUIRE_OPTIONS = ( import => [qw/source/] );
-use base qw/Class::Accessor::Fast/;
-__PACKAGE__->mk_accessors(qw/repository log/);
+use base qw/Shipwright::Backend::Base/;
=head1 NAME
@@ -27,21 +24,6 @@
=over
-=item new
-
-This is the constructor.
-
-=cut
-
-sub new {
- my $class = shift;
- my $self = {@_};
-
- bless $self, $class;
- $self->log( Log::Log4perl->get_logger( ref $self ) );
- return $self;
-}
-
=item initialize
Initialize a project.
@@ -50,20 +32,9 @@
sub initialize {
my $self = shift;
- my $dir = tempdir( CLEANUP => 1 );
-
- dircopy( Shipwright::Util->share_root, $dir );
-
- # share_root can't keep empty dirs, we have to create them manually
- for (qw/dists scripts t/) {
- mkdir File::Spec->catfile( $dir, $_ );
- }
-
- # hack for share_root living under blib/
- unlink( File::Spec->catfile( $dir, '.exists' ) );
+ my $dir = $self->SUPER::initialize(@_);
$self->delete; # clean repository in case it exists
- $self->log->info( 'initialize ' . $self->repository );
$self->import(
source => $dir,
_initialize => 1,
@@ -71,110 +42,6 @@
);
}
-=item import
-
-Import a dist.
-
-=cut
-
-sub import {
- my $self = shift;
- return unless @_;
- my %args = @_;
- my $name = $args{source};
- $name =~ s{.*/}{};
-
- unless ( $args{_initialize} || $args{_extra_tests} ) {
- if ( $args{build_script} ) {
- if ( $self->info( path => "scripts/$name" )
- && not $args{overwrite} )
- {
- $self->log->warn(
-"path scripts/$name alreay exists, need to set overwrite arg to overwrite"
- );
- }
- else {
- $self->log->info(
- "import $args{source}'s scripts to " . $self->repository );
- Shipwright::Util->run(
- $self->_cmd( import => %args, name => $name ) );
- }
- }
- else {
- if ( $self->info( path => "dists/$name" ) && not $args{overwrite} )
- {
- $self->log->warn(
-"path dists/$name alreay exists, need to set overwrite arg to overwrite"
- );
- }
- else {
- $self->log->info(
- "import $args{source} to " . $self->repository );
- $self->_add_to_order($name);
-
- my $version = $self->version;
- $version->{$name} = $args{version};
- $self->version($version);
-
- Shipwright::Util->run(
- $self->_cmd( import => %args, name => $name ) );
- }
- }
- }
- else {
- Shipwright::Util->run( $self->_cmd( import => %args, name => $name ) );
- }
-}
-
-=item export
-
-A wrapper around svk's export command. Export a project, partly or as a whole.
-
-=cut
-
-sub export {
- my $self = shift;
- my %args = @_;
- my $path = $args{path} || '';
- $self->log->info(
- 'export ' . $self->repository . "/$path to $args{target}" );
- Shipwright::Util->run( $self->_cmd( checkout => %args ) );
- Shipwright::Util->run( $self->_cmd( checkout => %args, detach => 1 ) );
-}
-
-=item checkout
-
-A wrapper around svk's checkout command. Checkout a project, partly or as a
-whole.
-
-=cut
-
-sub checkout {
- my $self = shift;
- my %args = @_;
- my $path = $args{path} || '';
- $self->log->info(
- 'export ' . $self->repository . "/$path to $args{target}" );
- Shipwright::Util->run( $self->_cmd( checkout => %args ) );
-}
-
-=item commit
-
-A wrapper around svk's commit command.
-
-=cut
-
-sub commit {
- my $self = shift;
- my %args = @_;
- $self->log->info( 'commit ' . $args{path} );
-
- # have to omit the failure since we will get error if nothing need to commit,
- # which's harmless
- Shipwright::Util->run( $self->_cmd( commit => @_ ), 1 );
-
-}
-
# a cmd generating factory
sub _cmd {
my $self = shift;
@@ -200,6 +67,15 @@
];
}
}
+ elsif ( $type eq 'export' ) {
+ $cmd =
+ [ 'svk', 'checkout', $self->repository . $args{path}, $args{target} ];
+
+ # $cmd = [ 'svk', 'checkout', '-d', $args{target} ];
+ }
+ elsif ( $type eq 'list' ) {
+ $cmd = [ 'svk', 'list', $self->repository . $args{path} ];
+ }
elsif ( $type eq 'import' ) {
if ( $args{_initialize} ) {
$cmd = [
@@ -271,217 +147,32 @@
return $cmd;
}
-# add a dist to order
-
-sub _add_to_order {
- my $self = shift;
- my $name = shift;
-
- my $order = $self->order;
-
- unless ( grep { $name eq $_ } @$order ) {
- $self->log->info( "add $name to order for " . $self->repository );
- push @$order, $name;
- $self->order($order);
- }
-}
-
-=item update_order
-
-Regenerate the dependency order.
-
-=cut
-
-sub update_order {
+sub _yml {
my $self = shift;
- my %args = @_;
+ my $path = shift;
+ my $yml = shift;
- $self->log->info( "update order for " . $self->repository );
+ $path = '/' . $path unless $path =~ m{^/};
- my @dists = @{ $args{for_dists} || [] };
- unless (@dists) {
- my ($out) = Shipwright::Util->run(
- [ 'svk', 'ls', $self->repository . '/scripts' ] );
- my $sep = $/;
- @dists = split /$sep/, $out;
- chomp @dists;
- s{/$}{} for @dists;
- }
-
- my $require = {};
+ my ($f) = $path =~ m{.*/(.*)$};
- for (@dists) {
- $self->_fill_deps( %args, require => $require, name => $_ );
- }
-
- require Algorithm::Dependency::Ordered;
- require Algorithm::Dependency::Source::HoA;
-
- my $source = Algorithm::Dependency::Source::HoA->new($require);
- $source->load();
- my $dep = Algorithm::Dependency::Ordered->new( source => $source, )
- or die $@;
- my $order = $dep->schedule_all();
-
- $self->order($order);
-}
-
-sub _fill_deps {
- my $self = shift;
- my %args = @_;
- my $require = $args{require};
- my $name = $args{name};
-
- return if $require->{$name};
- my ($string) = Shipwright::Util->run(
- [ 'svk', 'cat', $self->repository . "/scripts/$name/require.yml" ], 1 );
- my $req = Shipwright::Util::Load($string) || {};
-
- if ( $req->{requires} ) {
- for (qw/requires recommends build_requires/) {
- push @{ $require->{$name} }, keys %{ $req->{$_} }
- if $args{"keep_$_"};
- }
- @{ $require->{$name} } = uniq @{$require->{$name}};
- }
- else {
-
- #for back compatbility
- push @{ $require->{$name} }, keys %$req;
- }
-
- for my $dep ( @{ $require->{$name} } ) {
- next if $require->{$dep};
- $self->_fill_deps( %args, name => $dep, require => $require );
- }
-}
-
-=item order
-
-Get or set the dependency order.
-
-=cut
-
-sub order {
- my $self = shift;
- my $order = shift;
- if ($order) {
+ if ($yml) {
my $dir = tempdir( CLEANUP => 1 );
- my $file = File::Spec->catfile( $dir, 'order.yml' );
+ my $file = File::Spec->catfile( $dir, $f );
- $self->checkout(
- path => '/shipwright/order.yml',
- target => $file,
- );
+ $self->checkout( path => $path, target => $file );
- Shipwright::Util::DumpFile( $file, $order );
- $self->commit( path => $file, comment => "set order" );
+ Shipwright::Util::DumpFile( $file, $yml );
+ $self->commit( path => $file, comment => "updated $path" );
$self->checkout( detach => 1, target => $file );
}
else {
- my ($out) = Shipwright::Util->run(
- [ 'svk', 'cat', $self->repository . '/shipwright/order.yml' ] );
+ my ($out) =
+ Shipwright::Util->run( [ 'svk', 'cat', $self->repository . $path ] );
return Shipwright::Util::Load($out);
}
}
-=item map
-
-Get or set the map.
-
-=cut
-
-sub map {
- my $self = shift;
- my $map = shift;
- if ($map) {
- my $dir = tempdir( CLEANUP => 1 );
- my $file = File::Spec->catfile( $dir, 'map.yml' );
-
- $self->checkout(
- path => '/shipwright/map.yml',
- target => $file,
- );
-
- Shipwright::Util::DumpFile( $file, $map );
- $self->commit( path => $file, comment => "set map" );
- $self->checkout( detach => 1, target => $file );
- }
- else {
- my ($out) = Shipwright::Util->run(
- [ 'svk', 'cat', $self->repository . '/shipwright/map.yml' ] );
- return Shipwright::Util::Load($out);
- }
-}
-
-=item source
-
-Get or set the sources map.
-
-=cut
-
-sub source {
- my $self = shift;
- my $source = shift;
- if ($source) {
- my $dir = tempdir( CLEANUP => 1 );
- my $file = File::Spec->catfile( $dir, 'source.yml' );
-
- $self->checkout(
- path => '/shipwright/source.yml',
- target => $file,
- );
-
- Shipwright::Util::DumpFile( $file, $source );
- $self->commit( path => $file, comment => "set source" );
- $self->checkout( detach => 1, target => $file );
- }
- else {
- my ($out) = Shipwright::Util->run(
- [ 'svk', 'cat', $self->repository . '/shipwright/source.yml' ] );
- return Shipwright::Util::Load($out);
- }
-}
-
-=item delete
-
-A wrapper around svk's delete command.
-
-=cut
-
-sub delete {
- my $self = shift;
- my %args = @_;
- my $path = $args{path} || '';
- if ( $self->info( path => $path ) ) {
- $self->log->info( "delete " . $self->repository . "/$path" );
- Shipwright::Util->run( $self->_cmd( delete => path => $path ), 1 );
- }
-}
-
-=item move
-
-A wrapper around svk's move command.
-
-=cut
-
-sub move {
- my $self = shift;
- my %args = @_;
- my $path = $args{path} || '';
- my $new_path = $args{new_path} || '';
- if ( $self->info( path => $path ) ) {
- $self->log->info(
- "move " . $self->repository . "/$path to /$new_path" );
- Shipwright::Util->run(
- $self->_cmd(
- move => path => $path,
- new_path => $new_path,
- ),
- );
- }
-}
-
=item info
A wrapper around svk's info command.
@@ -490,12 +181,7 @@
sub info {
my $self = shift;
- my %args = @_;
- my $path = $args{path} || '';
-
- my ( $info, $err ) =
- Shipwright::Util->run( $self->_cmd( info => path => $path ), 1 );
- $self->log->warn($err) if $err;
+ my ( $info, $err ) = $self->SUPER::info(@_);
if (wantarray) {
return $info, $err;
@@ -545,85 +231,6 @@
$self->checkout( detach => 1, target => $file );
}
-=item requires
-
-Return the hashref of require.yml for a dist.
-
-=cut
-
-sub requires {
- my $self = shift;
- my %args = @_;
- my $name = $args{name};
-
- my ($string) = Shipwright::Util->run(
- [ 'svk', 'cat', $self->repository . "/scripts/$name/require.yml" ], 1 );
- return Shipwright::Util::Load($string) || {};
-}
-
-=item flags
-
-Get or set flags.
-
-=cut
-
-sub flags {
- my $self = shift;
- my $flags = shift;
-
- if ($flags) {
- my $dir = tempdir( CLEANUP => 1 );
- my $file = File::Spec->catfile( $dir, 'flags.yml' );
-
- $self->checkout(
- path => '/shipwright/flags.yml',
- target => $file,
- );
-
- Shipwright::Util::DumpFile( $file, $flags );
- $self->commit( path => $file, comment => 'set flags' );
- $self->checkout( detach => 1, target => $file );
- }
- else {
- my ($out) = Shipwright::Util->run(
- [ 'svk', 'cat', $self->repository . '/shipwright/flags.yml' ] );
- return Shipwright::Util::Load($out) || {};
- }
-}
-
-=item version
-
-Get or set version.
-
-=cut
-
-sub version {
- my $self = shift;
- my $version = shift;
-
- if ($version) {
- my $dir = tempdir( CLEANUP => 1 );
- my $file = File::Spec->catfile( $dir, 'version.yml' );
-
- $self->checkout(
- path => '/shipwright/version.yml',
- target => $file,
- );
-
- Shipwright::Util::DumpFile( $file, $version );
- $self->commit(
- path => $file,
- comment => 'set version',
- );
- $self->checkout( detach => 1, target => $file );
- }
- else {
- my ($out) = Shipwright::Util->run(
- [ 'svk', 'cat', $self->repository . '/shipwright/version.yml' ] );
- return Shipwright::Util::Load($out) || {};
- }
-}
-
=item check_repository
Check if the given repository is valid.
@@ -653,14 +260,8 @@
}
else {
-
- # every valid shipwright repo has 'shipwright' subdir;
- my $info = $self->info( path => 'shipwright' );
-
- return 1 if $info;
+ return $self->SUPER::check_repository(@_);
}
-
- return 0;
}
=item update
@@ -670,16 +271,9 @@
=cut
sub update {
- my $self = shift;
- my %args = @_;
-
- croak "need path option" unless $args{path};
-
- croak "$args{path} seems not shipwright's own file"
- unless -e File::Spec->catfile( Shipwright::Util->share_root,
- $args{path} );
-
- $args{path} = '/' . $args{path} unless $args{path} =~ m{^/};
+ my $self = shift;
+ my %args = @_;
+ my $latest = $self->SUPER::update(@_);
my $dir = tempdir( CLEANUP => 1 );
my $file = File::Spec->catfile( $dir, $args{path} );
@@ -689,8 +283,7 @@
target => $file,
);
- copy( File::Spec->catfile( Shipwright::Util->share_root, $args{path} ),
- $file );
+ copy( $latest, $file );
$self->commit(
path => $file,
comment => "update $args{path}",
@@ -698,39 +291,6 @@
$self->checkout( detach => 1, target => $file );
}
-=item ktf
-
-Get or set known failure conditions.
-
-=cut
-
-sub ktf {
- my $self = shift;
- my $failure = shift;
-
- if ($failure) {
- my $dir = tempdir( CLEANUP => 1 );
- my $file = File::Spec->catfile( $dir, 'ktf.yml' );
-
- $self->checkout(
- path => '/shipwright/ktf.yml',
- target => $file,
- );
-
- Shipwright::Util::DumpFile( $file, $failure );
- $self->commit(
- path => $file,
- comment => 'set known failure',
- );
- $self->checkout( detach => 1, target => $file );
- }
- else {
- my ($out) = Shipwright::Util->run(
- [ 'svk', 'cat', $self->repository . '/shipwright/ktf.yml' ] );
- return Shipwright::Util::Load($out) || {};
- }
-}
-
=back
=cut
Modified: Shipwright/trunk/lib/Shipwright/Backend/SVN.pm
==============================================================================
--- Shipwright/trunk/lib/Shipwright/Backend/SVN.pm (original)
+++ Shipwright/trunk/lib/Shipwright/Backend/SVN.pm Fri Jun 27 14:14:49 2008
@@ -7,13 +7,10 @@
use Shipwright::Util;
use File::Temp qw/tempdir/;
use File::Copy qw/copy/;
-use File::Copy::Recursive qw/dircopy/;
-use List::MoreUtils qw/uniq/;
our %REQUIRE_OPTIONS = ( import => [qw/source/], );
-use base qw/Class::Accessor::Fast/;
-__PACKAGE__->mk_accessors(qw/repository log/);
+use base qw/Shipwright::Backend::Base/;
=head1 NAME
@@ -27,21 +24,6 @@
=over
-=item new
-
-This is the constructor.
-
-=cut
-
-sub new {
- my $class = shift;
- my $self = {@_};
-
- bless $self, $class;
- $self->log( Log::Log4perl->get_logger( ref $self ) );
- return $self;
-}
-
=item initialize
Initialize a project.
@@ -50,19 +32,9 @@
sub initialize {
my $self = shift;
- my $dir = tempdir( CLEANUP => 1 );
- dircopy( Shipwright::Util->share_root, $dir );
-
- # share_root can't keep empty dirs, we have to create them manually
- for (qw/dists scripts t/) {
- mkdir File::Spec->catfile( $dir, $_ );
- }
-
- # hack for share_root living under blib/
- unlink( File::Spec->catfile( $dir, '.exists' ) );
+ my $dir = $self->SUPER::initialize(@_);
$self->delete; # clean repository in case it exists
- $self->log->info( 'initialize ' . $self->repository );
$self->import(
source => $dir,
comment => 'create project',
@@ -73,108 +45,11 @@
=item import
-Import a dist.
-
=cut
sub import {
my $self = shift;
- return unless @_;
- my %args = @_;
- my $name = $args{source};
- $name =~ s{.*/}{};
-
- unless ( $args{_initialize} ) {
- if ( $args{_extra_tests} ) {
- $self->delete( path => "t/extra" );
- $self->log->info( "import extra tests to " . $self->repository );
- Shipwright::Util->run(
- $self->_cmd( import => %args, name => $name ) );
- }
- elsif ( $args{build_script} ) {
- if ( $self->info( path => "scripts/$name" )
- && not $args{overwrite} )
- {
- $self->log->warn(
-"path scripts/$name alreay exists, need to set overwrite arg to overwrite"
- );
- }
- else {
- $self->delete( path => "scripts/$name" );
- $self->log->info(
- "import $args{source}'s scripts to " . $self->repository );
- Shipwright::Util->run(
- $self->_cmd( import => %args, name => $name ) );
- }
- }
- else {
- if ( $self->info( path => "dists/$name" ) && not $args{overwrite} )
- {
- $self->log->warn(
-"path dists/$name alreay exists, need to set overwrite arg to overwrite"
- );
- }
- else {
- $self->delete( path => "dists/$name" );
- $self->log->info(
- "import $args{source} to " . $self->repository );
- $self->_add_to_order($name);
- my $version = $self->version;
- $version->{$name} = $args{version};
- $self->version($version);
-
- Shipwright::Util->run(
- $self->_cmd( import => %args, name => $name ) );
- }
- }
- }
- else {
- Shipwright::Util->run( $self->_cmd( import => %args, name => $name ) );
- }
-}
-
-=item export
-
-A wrapper around svn's export command. Export a project, partly or as a whole.
-
-=cut
-
-sub export {
- my $self = shift;
- my %args = @_;
- my $path = $args{path} || '';
- $self->log->info(
- 'export ' . $self->repository . "/$path to $args{target}" );
- Shipwright::Util->run( $self->_cmd( export => %args ) );
-}
-
-=item checkout
-
-A wrapper around svn's checkout command. Checkout a project, partly or as a
-whole.
-
-=cut
-
-sub checkout {
- my $self = shift;
- my %args = @_;
- my $path = $args{path} || '';
- $self->log->info(
- 'export ' . $self->repository . "/$path to $args{target}" );
- Shipwright::Util->run( $self->_cmd( checkout => @_ ) );
-}
-
-=item commit
-
-A wrapper around svn's commit command.
-
-=cut
-
-sub commit {
- my $self = shift;
- my %args = @_;
- $self->log->info( 'commit ' . $args{path} );
- Shipwright::Util->run( $self->_cmd( commit => @_ ), 1 );
+ return $self->SUPER::import( @_, delete => 1 );
}
# a cmd generating factory
@@ -231,6 +106,9 @@
}
}
}
+ elsif ( $type eq 'list' ) {
+ $cmd = [ 'svn', 'list', $self->repository . $args{path} ];
+ }
elsif ( $type eq 'commit' ) {
$cmd =
[ 'svn', 'commit', '-m', q{'} . $args{comment} . q{'}, $args{path} ];
@@ -268,218 +146,38 @@
return $cmd;
}
-# add a dist to order
-
-sub _add_to_order {
+sub _yml {
my $self = shift;
- my $name = shift;
-
- my $order = $self->order;
-
- unless ( grep { $name eq $_ } @$order ) {
- $self->log->info( "add $name to order for " . $self->repository );
- push @$order, $name;
- $self->order($order);
- }
-}
-
-=item update_order
-
-Regenerate the dependency order.
-
-=cut
-
-sub update_order {
- my $self = shift;
- my %args = @_;
- $self->log->info( "update order for " . $self->repository );
-
- my @dists = @{ $args{for_dists} || [] };
- unless (@dists) {
- my ($out) = Shipwright::Util->run(
- [ 'svn', 'ls', $self->repository . '/scripts' ] );
- my $sep = $/;
- @dists = split /$sep/, $out;
- chomp @dists;
- s{/$}{} for @dists;
- }
-
- my $require = {};
-
- for (@dists) {
- $self->_fill_deps( %args, require => $require, name => $_ );
- }
-
- require Algorithm::Dependency::Ordered;
- require Algorithm::Dependency::Source::HoA;
-
- my $source = Algorithm::Dependency::Source::HoA->new($require);
- $source->load();
- my $dep = Algorithm::Dependency::Ordered->new( source => $source, )
- or die $@;
- my $order = $dep->schedule_all();
- $self->order($order);
-}
-
-sub _fill_deps {
- my $self = shift;
- my %args = @_;
- my $require = $args{require};
- my $name = $args{name};
-
- return if $require->{$name};
-
- my ($string) = Shipwright::Util->run(
- [ 'svn', 'cat', $self->repository . "/scripts/$_/require.yml" ], 1 );
-
- my $req = Shipwright::Util::Load($string) || {};
-
- if ( $req->{requires} ) {
- for (qw/requires recommends build_requires/) {
- push @{ $require->{$name} }, keys %{ $req->{$_} }
- if $args{"keep_$_"};
- }
- @{ $require->{$name} } = uniq @{$require->{$name}};
- }
- else {
-
- #for back compatbility
- push @{ $require->{$name} }, keys %$req;
- }
-
- for my $dep ( @{ $require->{$name} } ) {
- next if $require->{$dep};
- $self->_fill_deps( %args, name => $dep, require => $require );
- }
-}
-
-=item order
-
-Get or set the dependency order.
-
-=cut
-
-sub order {
- my $self = shift;
- my $order = shift;
- if ($order) {
- my $dir = tempdir( CLEANUP => 1 );
- my $file = File::Spec->catfile( $dir, 'order.yml' );
-
- $self->checkout(
- path => '/shipwright',
- target => $dir,
- );
-
- Shipwright::Util::DumpFile( $file, $order );
- $self->commit( path => $file, comment => "set order" );
-
- }
- else {
- my ($out) = Shipwright::Util->run(
- [ 'svn', 'cat', $self->repository . '/shipwright/order.yml' ] );
- return Shipwright::Util::Load($out);
- }
-}
-
-=item map
-
-Get or set the map.
-
-=cut
-
-sub map {
- my $self = shift;
- my $map = shift;
- if ($map) {
- my $dir = tempdir( CLEANUP => 1 );
- my $file = File::Spec->catfile( $dir, 'map.yml' );
-
- $self->checkout(
- path => '/shipwright',
- target => $dir,
- );
+ my $path = shift;
+ my $yml = shift;
- Shipwright::Util::DumpFile( $file, $map );
- $self->commit( path => $file, comment => "set map" );
+ $path = '/' . $path unless $path =~ m{^/};
+ my ( $p_dir, $f );
+ if ( $path =~ m{(.*)/(.*)$} ) {
+ $p_dir = $1;
+ $f = $2;
}
- else {
- my ($out) = Shipwright::Util->run(
- [ 'svn', 'cat', $self->repository . '/shipwright/map.yml' ] );
- return Shipwright::Util::Load($out);
- }
-}
-
-=item source
-
-Get or set the sources map.
-
-=cut
-sub source {
- my $self = shift;
- my $source = shift;
- if ($source) {
+ if ($yml) {
my $dir = tempdir( CLEANUP => 1 );
- my $file = File::Spec->catfile( $dir, 'source.yml' );
+ my $file = File::Spec->catfile( $dir, $f );
$self->checkout(
- path => '/shipwright',
+ path => $p_dir,
target => $dir,
);
- Shipwright::Util::DumpFile( $file, $source );
- $self->commit( path => $file, comment => "set source" );
-
+ Shipwright::Util::DumpFile( $file, $yml );
+ $self->commit( path => $file, comment => "updated $path" );
}
else {
- my ($out) = Shipwright::Util->run(
- [ 'svn', 'cat', $self->repository . '/shipwright/source.yml' ] );
+ my ($out) =
+ Shipwright::Util->run( [ 'svn', 'cat', $self->repository . $path ] );
return Shipwright::Util::Load($out);
}
}
-=item delete
-
-A wrapper around svn's delete command.
-
-=cut
-
-sub delete {
- my $self = shift;
- my %args = @_;
-
- my $path = $args{path} || '';
- if ( $self->info( path => $path ) ) {
- $self->log->info( "delete " . $self->repository . "/$path" );
- Shipwright::Util->run( $self->_cmd( delete => path => $path ), 1 );
- }
-}
-
-=item move
-
-A wrapper around svn's move command.
-
-=cut
-
-sub move {
- my $self = shift;
- my %args = @_;
- my $path = $args{path} || '';
- my $new_path = $args{new_path} || '';
- if ( $self->info( path => $path ) ) {
- $self->log->info(
- "move " . $self->repository . "/$path to /$new_path" );
- Shipwright::Util->run(
- $self->_cmd(
- move => path => $path,
- new_path => $new_path,
- ),
- );
- }
-}
-
=item info
A wrapper around svn's info command.
@@ -488,11 +186,7 @@
sub info {
my $self = shift;
- my %args = @_;
- my $path = $args{path} || '';
-
- my ( $info, $err ) =
- Shipwright::Util->run( $self->_cmd( info => path => $path ), 1 );
+ my ( $info, $err ) = $self->SUPER::info(@_);
if (wantarray) {
return $info, $err;
@@ -557,84 +251,6 @@
$self->commit( path => $file, comment => "update test script" );
}
-=item requires
-
-Return the hashref of require.yml for a dist.
-
-=cut
-
-sub requires {
- my $self = shift;
- my %args = @_;
- my $name = $args{name};
-
- my ($string) = Shipwright::Util->run(
- [ 'svn', 'cat', $self->repository . "/scripts/$name/require.yml" ], 1 );
- return Shipwright::Util::Load($string) || {};
-}
-
-=item flags
-
-Get or set flags.
-
-=cut
-
-sub flags {
- my $self = shift;
- my $flags = shift;
-
- if ($flags) {
- my $dir = tempdir( CLEANUP => 1 );
- my $file = File::Spec->catfile( $dir, 'flags.yml' );
-
- $self->checkout(
- path => '/shipwright',
- target => $dir,
- );
-
- Shipwright::Util::DumpFile( $file, $flags );
- $self->commit( path => $file, comment => 'set flags' );
- }
- else {
- my ($out) = Shipwright::Util->run(
- [ 'svn', 'cat', $self->repository . '/shipwright/flags.yml' ] );
- return $out = Shipwright::Util::Load($out) || {};
- }
-}
-
-=item version
-
-Get or set version.
-
-=cut
-
-sub version {
- my $self = shift;
- my $version = shift;
-
- if ($version) {
- my $dir = tempdir( CLEANUP => 1 );
- my $file = File::Spec->catfile( $dir, 'version.yml' );
-
- $self->checkout(
- path => '/shipwright',
- target => $dir,
- );
-
- Shipwright::Util::DumpFile( $file, $version );
-
- $self->commit(
- path => $file,
- comment => 'set version',
- );
- }
- else {
- my ($out) = Shipwright::Util->run(
- [ 'svn', 'cat', $self->repository . '/shipwright/version.yml' ] );
- return Shipwright::Util::Load($out) || {};
- }
-}
-
=item check_repository
Check if the given repository is valid.
@@ -653,14 +269,8 @@
}
else {
-
- # every valid shipwright repo has 'shipwright' subdir;
- my $info = $self->info( path => 'shipwright' );
- return 1 if $info;
-
+ return $self->SUPER::check_repository(@_);
}
-
- return 0;
}
=item update
@@ -670,67 +280,25 @@
=cut
sub update {
- my $self = shift;
- my %args = @_;
-
- croak "need path option" unless $args{path};
-
- croak "$args{path} seems not shipwright's own file"
- unless -e File::Spec->catfile( Shipwright::Util->share_root,
- $args{path} );
-
- $args{path} = '/' . $args{path} unless $args{path} =~ m{^/};
-
- my $dir = tempdir( CLEANUP => 1 );
-
- my $file = File::Spec->catfile( $dir, $args{path} );
+ my $self = shift;
+ my %args = @_;
+ my $latest = $self->SUPER::update(@_);
if ( $args{path} =~ m{(.*)/} ) {
- $self->checkout(
- path => $1,
- target => $file,
- );
-
- copy( File::Spec->catfile( Shipwright::Util->share_root, $args{path} ),
- $file );
- $self->commit(
- path => $file,
- comment => "update $args{path}",
- );
- }
-}
-
-=item ktf
-
-Get or set known failure conditions.
-
-=cut
-
-sub ktf {
- my $self = shift;
- my $failure = shift;
-
- if ($failure) {
my $dir = tempdir( CLEANUP => 1 );
- my $file = File::Spec->catfile( $dir, 'ktf.yml' );
+ my $file = File::Spec->catfile( $dir, $args{path} );
$self->checkout(
- path => '/shipwright',
+ path => $1,
target => $dir,
);
- Shipwright::Util::DumpFile( $file, $failure );
-
+ copy( $latest, $file );
$self->commit(
path => $file,
- comment => 'set known failure',
+ comment => "update $args{path}",
);
}
- else {
- my ($out) = Shipwright::Util->run(
- [ 'svn', 'cat', $self->repository . '/shipwright/ktf.yml' ] );
- return Shipwright::Util::Load($out) || {};
- }
}
=back
More information about the Bps-public-commit
mailing list