[Bps-public-commit] r10220 - bpsbuilder/BPB/lib/BPB/Backend

[sunnavy at bestpractical.com]

Author: sunnavy
Date: Tue Jan  1 10:58:51 2008
New Revision: 10220

Added:
   bpsbuilder/BPB/lib/BPB/Backend/SVN.pm

Log:
added svn backend

Added: bpsbuilder/BPB/lib/BPB/Backend/SVN.pm
==============================================================================
--- (empty file)
+++ bpsbuilder/BPB/lib/BPB/Backend/SVN.pm	Tue Jan  1 10:58:51 2008
@@ -0,0 +1,292 @@
+package BPB::Backend::SVN;
+
+use warnings;
+use strict;
+use Carp;
+use File::Spec;
+use CPAN::DistnameInfo;
+use BPB::Config;
+use File::Temp qw/tempdir/;
+
+# our project's own files will be in //local/test/main
+# all the dependance packages will be in //local/test/deps
+# the bpb's stuff will be in //local/test/bpb
+
+our %REQUIRE_OPTIONS = ( import => [qw/source/], );
+
+use base qw/Class::Accessor::Fast/;
+__PACKAGE__->mk_accessors(qw/repository/);
+
+=head2 new
+
+=cut
+
+sub new {
+    my $class = shift;
+    my %args  = @_;
+
+    bless {%args}, $class;
+}
+
+sub initialize {
+    my $self = shift;
+    my $dir = tempdir( CLEANUP => 1 );
+    for (qw/bpb dists etc bin scripts/) {
+        mkdir File::Spec->catfile( $dir, $_ );
+    }
+    open my $order, '>', File::Spec->catfile( $dir, 'bpb', 'order.yml' );
+    close $order;
+
+    open my $wrapper, '>',
+      File::Spec->catfile( $dir, 'etc', 'bpb-script-wrapper' );
+    print $wrapper $BPB::Backend::WRAPPER;
+    close $wrapper;
+
+    open my $builder, '>', File::Spec->catfile( $dir, 'bin', 'bpb-builder' );
+    print $builder $BPB::Backend::BUILDER;
+    close $builder;
+
+    $self->delete;    # clean repository in case it exists
+    $self->import( source => $dir, _initialize => 1 );
+}
+
+=head2 import
+
+=cut
+
+sub import {
+    my $self = shift;
+    return unless @_;
+    my %args = @_;
+    my $name = $args{source};
+    $name =~ s{^.*/(.+)/?$}{$1.tar.gz};
+    $name = CPAN::DistnameInfo->new($name)->dist;
+    my $cmd = $self->_cmd( import => %args, name => $name );
+    for (qw/dists scripts/) {
+        $self->delete("$_/$name");
+    }
+    $self->_run($cmd);
+    $self->_add_to_order( source => $args{source} ) unless $args{_initialize};
+}
+
+=head2 export
+
+=cut
+
+sub export {
+    my $self = shift;
+    my $cmd = $self->_cmd( export => @_ );
+    $self->_run($cmd);
+}
+
+=head2 checkout
+
+=cut
+
+sub checkout {
+    my $self = shift;
+    my $cmd = $self->_cmd( checkout => @_ );
+    $self->_run($cmd);
+}
+
+sub commit {
+    my $self = shift;
+    my $cmd = $self->_cmd( commit => @_ );
+    $self->_run($cmd);
+}
+
+sub _cmd {
+    my $self = shift;
+    my $type = shift;
+    my %args = @_;
+    $args{extra} ||= [];
+    $args{path}  ||= '';
+
+    for ( @{ $REQUIRE_OPTIONS{$type} } ) {
+        croak "$type need option $_" unless $args{$_};
+    }
+
+    my $cmd;
+
+    if ( $type eq 'checkout' ) {
+        $cmd = join ' ', 'svn', 'checkout', $self->repository . $args{path},
+          $args{target};
+    }
+    elsif ( $type eq 'import' ) {
+        push @{ $args{extra} }, '-m',
+          q{'} . ( $args{comment} || 'import' ) . q{'};
+
+        if ( $args{_initialize} ) {
+            $cmd = join ' ', 'svn', 'import', $args{source}, $self->repository;
+        }
+        else {
+
+            if ( my $script_dir = $args{build_script} ) {
+                $cmd = join ' ', 'svn', 'import', $script_dir,
+                  $self->repository . "/scripts/$args{name}/";
+            }
+            else {
+                $cmd = join ' ', 'svn', 'import', $args{source},
+                  $self->repository . "/dists/$args{name}";
+            }
+        }
+    }
+    elsif ( $type eq 'commit' ) {
+        $cmd = join ' ', 'svn', 'commit', '-m', q{'} . $args{comment} . q{'},
+          $args{path};
+    }
+    elsif ( $type eq 'delete' ) {
+        $cmd = join ' ', 'svn', 'delete', '-m',
+          q{'} . 'delete repository' . q{'}, join '/', $self->repository,
+          $args{path};
+    }
+    elsif ( $type eq 'info' ) {
+        $cmd = join ' ', 'svn', 'info', '2>/dev/null', $self->repository,
+          $args{path};
+    }
+    else {
+        croak "invalid command";
+    }
+
+    return join ' ', $cmd, @{ $args{extra} };
+}
+
+sub _add_to_order {
+    my $self = shift;
+    my %args = @_;
+    my $name = $args{source};
+
+    my $order = $self->order;
+
+    $name =~ s!^.*/(.+)/?$!$1.tar.gz!;
+    $name = CPAN::DistnameInfo->new($name)->dist;
+
+    unless ( grep { /^$name$/ } @$order ) {
+        push @$order, $name;
+        $self->order($order);
+    }
+}
+
+sub update_order {
+    my $self  = shift;
+    my $cmd   = 'svn ls ' . $self->repository . '/scripts';
+    my @dists = `$cmd`;
+    chomp @dists;
+
+    my $require;
+
+    for (@dists) {
+        s{/$}{};
+        my $cmd    = 'svn cat ' . $self->repository . "/scripts/$_/require.yml";
+        my $string = `$cmd`;
+        my $req    = BPB::Config::Load($string);
+        use Data::Dumper;
+        $require->{$_} = [ keys %$req ];
+    }
+
+    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 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   => '/bpb',
+            target => $dir,
+        );
+
+        BPB::Config::DumpFile( $file, $order );
+        $self->commit( path => $file, comment => "set order" );
+
+    }
+    else {
+        my $cmd    = 'svn cat ' . $self->repository . '/bpb/order.yml';
+        my $string = `$cmd`;
+        return BPB::Config::Load($string);
+    }
+}
+
+sub _run {
+    my $self = shift;
+    my $cmd  = shift;
+    system($cmd );
+}
+
+sub delete {
+    my $self = shift;
+    my $path = shift;
+    $self->_run( $self->_cmd( delete => path => $path ) )
+      if $self->info($path);
+}
+
+sub info {
+    my $self = shift;
+    my $path = shift;
+    my $cmd  = $self->_cmd( info => path => $path );
+    return `$cmd`;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+BPB::Backend::SVN - 
+
+
+=head1 VERSION
+
+This document describes BPB::Backend::SVK version 0.0.1
+
+
+=head1 SYNOPSIS
+
+    use BPB::Backend::SVK;
+
+=head1 DESCRIPTION
+
+
+=head1 INTERFACE
+
+
+
+=head1 DEPENDENCIES
+
+
+None.
+
+
+=head1 INCOMPATIBILITIES
+
+None reported.
+
+
+=head1 BUGS AND LIMITATIONS
+
+No bugs have been reported.
+
+=head1 AUTHOR
+
+sunnavy  C<< <sunnavy at bestpractical.com> >>
+
+
+=head1 LICENCE AND COPYRIGHT
+
+Copyright 2007 Best Practical Solutions.
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+