[Bps-public-commit] r13659 - in Shipwright/trunk: lib/Shipwright/Backend

sunnavy at bestpractical.com sunnavy at bestpractical.com
Fri Jun 27 14:14:39 EDT 2008


Author: sunnavy
Date: Fri Jun 27 14:14:38 2008
New Revision: 13659

Added:
   Shipwright/trunk/lib/Shipwright/Backend/Base.pm
Modified:
   Shipwright/trunk/   (props changed)

Log:
 r13894 at sunnavys-mb:  sunnavy | 2008-06-28 01:29:16 +0800
 added Backend/Base.pm


Added: Shipwright/trunk/lib/Shipwright/Backend/Base.pm
==============================================================================
--- (empty file)
+++ Shipwright/trunk/lib/Shipwright/Backend/Base.pm	Fri Jun 27 14:14:38 2008
@@ -0,0 +1,506 @@
+package Shipwright::Backend::Base;
+
+use warnings;
+use strict;
+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/;
+
+our %REQUIRE_OPTIONS = ( import => [qw/source/] );
+
+use base qw/Class::Accessor::Fast/;
+__PACKAGE__->mk_accessors(qw/repository log/);
+
+=head1 NAME
+
+Shipwright::Backend::Base - Base Backend Class
+
+=head1 DESCRIPTION
+
+Base Backend Class
+
+=head1 METHODS
+
+=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;
+}
+
+sub _subclass_method {
+    my $method = ( caller(0) )[3];
+    die "your should subclass $method\n";
+}
+
+=item initialize
+
+Initialize a project.
+you should subclass this method, and call this to get the dir with content initialized
+
+=cut
+
+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' ) );
+
+    return $dir;
+}
+
+=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{_extra_tests} ) {
+            $self->delete( path => "t/extra" ) if $args{delete};
+
+            $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" ) if $args{delete};
+
+                $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" ) if $args{delete};
+                $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
+
+
+=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
+
+=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 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 );
+}
+
+
+# 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) {
+        @dists = $self->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 );
+    }
+}
+
+sub _yml {
+    my $self = shift;
+    my $path = shift;
+    my $yml  = shift;
+
+    my $file = File::Spec->catfile( $self->repository, $path );
+    if ($yml) {
+
+        Shipwright::Util::DumpFile( $file, $yml );
+    }
+    else {
+        Shipwright::Util::LoadFile($file);
+    }
+}
+
+=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 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 ktf
+
+Get or set known failure conditions.
+
+=cut
+
+sub ktf {
+    my $self = shift;
+    my $ktf  = shift;
+    my $path = File::Spec->catfile( 'shipwright', 'ktf.yml' );
+
+    return $self->_yml( $path, $ktf );
+}
+
+=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 list
+
+
+=cut
+
+sub list {
+    my $self = shift;
+    my %args = @_;
+    my $path = $args{path} || '';
+    if ( $self->info( path => $path ) ) {
+        my $out = Shipwright::Util->run( $self->_cmd( list => path => $path ) );
+        return $out;
+    }
+}
+
+=item dists
+
+
+=cut
+
+sub dists {
+    my $self = shift;
+    my %args = @_;
+    my $out  = $self->list( path => 'scripts' );
+    return split /\s+/, $out;
+}
+
+=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
+
+=cut
+
+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;
+
+    if (wantarray) {
+        return $info, $err;
+    }
+    else {
+        return $info;
+    }
+}
+
+=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 check_repository
+
+Check if the given repository is valid.
+
+=cut
+
+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;
+}
+
+=head2 update
+
+you should subclass this method, and run this to get the file path with latest version
+
+=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{^/};
+
+    return File::Spec->catfile( Shipwright::Util->share_root, $args{path} ),;
+}
+
+*_cmd = *update = *test_script = *propset = *_subclass_method;
+
+=back
+
+=cut
+
+1;



More information about the Bps-public-commit mailing list