File Coverage

blib/lib/Shipwright/Backend/SVN.pm

Criterion	Covered	Total	%
statement	23	110	20.9
branch	3	52	5.7
condition	0	14	0.0
subroutine	8	17	47.0
pod	4	4	100.0
total	38	197	19.2

package Shipwright::Backend::SVN;

use warnings;
use strict;
use File::Spec::Functions qw/catfile/;
use Shipwright::Util;
use File::Copy::Recursive qw/rcopy/;

our %REQUIRE_OPTIONS = ( import => [qw/source/] );

use base qw/Shipwright::Backend::Base/;

=head1 NAME

Shipwright::Backend::SVN - SVN repository backend

=head1 SYNOPSIS

    svnadmin create /home/me/shipwright/my_proj
    shipwright create -r svn:file:///home/me/shipwright/my_proj

=head1 DESCRIPTION

This module implements a SVN based backend
for Shipwright L.

=head1 ENVIRONMENT VARIABLES

=over 4

=item SHIPWRIGHT_SVN - path of F command, default value is F.
F command is expected to be in the same directory as F.

=back

=head1 METHODS

=over 4

=item build

=cut



sub build {
    my $self = shift;
    $self->strip_repository
        if $self->repository =~ m{^svn:[a-z]+(?:\+[a-z]+)?://};
    $self->SUPER::build(@_);
}

=item initialize

initialize a project.

=cut

sub initialize {
    my $self = shift;
    my $dir  = $self->SUPER::initialize(@_);

    $self->delete;    # clean repository in case it exists
    $self->import(
        source      => $dir,
        _initialize => 1,
        comment     => 'created project',
    );
    $self->_initialize_local_dir();

}

=item import

=cut

sub import {
    my $self = shift;
    return unless ref $self; # get rid of class->import
    return $self->SUPER::import( @_, delete => 1 );
}

# a cmd generating factory
sub _cmd {
    my $self = shift;
    my $type = shift;
    my %args = @_;
    $args{path}    ||= '';
    $args{comment} ||= '';

    for ( @{ $REQUIRE_OPTIONS{$type} } ) {
        confess_or_die "$type need option $_" unless $args{$_};
    }

    my @cmd;

    if ( $type eq 'checkout' ) {
        @cmd =
          [ $ENV{'SHIPWRIGHT_SVN'}, 'checkout', $self->repository . $args{path}, $args{target} ];
    }
    elsif ( $type eq 'export' ) {
        @cmd =
          [ $ENV{'SHIPWRIGHT_SVN'}, 'export', $self->repository . $args{path}, $args{target} ];
    }
    elsif ( $type eq 'import' ) {
        if ( $args{_initialize} ) {
            @cmd = [
                $ENV{'SHIPWRIGHT_SVN'}, 'import', $args{source},
                $self->repository . ( $args{path} || '' ),
                '-m', $args{comment},
            ];
        }
        elsif ( $args{_extra_tests} ) {
            @cmd = [
                $ENV{'SHIPWRIGHT_SVN'},         'import',
                $args{source}, $self->repository . '/t/extra',
                '-m',          $args{comment},
            ];
        }
        else {
            if ( my $script_dir = $args{build_script} ) {
                @cmd = [
                    $ENV{'SHIPWRIGHT_SVN'},       'import',
                    $script_dir, $self->repository . "/scripts/$args{name}/",
                    '-m',        $args{comment},
                ];
            }
            else {
                if ( $self->has_branch_support ) {
                    @cmd = [
                        $ENV{'SHIPWRIGHT_SVN'},
                        'import',
                        $args{source},
                        $self->repository . "/sources/$args{name}/$args{as}",
                        '-m',
                        $args{comment},
                    ];
                }
                else {
                    @cmd = [
                        $ENV{'SHIPWRIGHT_SVN'},
                        'import',
                        $args{source},
                        $self->repository . "/dists/$args{name}",
                        '-m',
                        $args{comment},
                    ];

                }
            }
        }
    }
    elsif ( $type eq 'list' ) {
        @cmd = [ $ENV{'SHIPWRIGHT_SVN'}, 'list', $self->repository . $args{path} ];
    }
    elsif ( $type eq 'commit' ) {
        @cmd =
          [ $ENV{'SHIPWRIGHT_SVN'}, 'commit', '-m', $args{comment}, $args{path} ];
    }
    elsif ( $type eq 'delete' ) {
        @cmd = [
            $ENV{'SHIPWRIGHT_SVN'}, 'delete',
            '-m',                   'delete ' . $args{path},
            $self->repository . $args{path},
        ];
    }
    elsif ( $type eq 'move' ) {
        @cmd = [
            $ENV{'SHIPWRIGHT_SVN'},
            'move',
            '-m',
            "move $args{path} to $args{new_path}",
            $self->repository . $args{path},
            $self->repository . $args{new_path}
        ];
    }
    elsif ( $type eq 'info' ) {
        @cmd = [ $ENV{'SHIPWRIGHT_SVN'}, 'info', $self->repository . $args{path} ];
    }
    elsif ( $type eq 'cat' ) {
        @cmd = [ $ENV{'SHIPWRIGHT_SVN'}, 'cat', $self->repository . $args{path} ];
    }
    else {
        confess_or_die "invalid command: $type";
    }

    return @cmd;
}

sub _yml {
    my $self = shift;
    my $path = shift;
    my $yml  = shift;

    my $file = $self->local_dir . $path;

    if ($yml) {
        if ( $path =~ /scripts/ ) {
            $self->_sync_local_dir('/scripts');
        }
        else {
            $self->_sync_local_dir($path);
        }
        dump_yaml_file( $file, $yml );
        $self->commit( path => $file, comment => "updated $path" );
    }
    else {
        my ($out) = run_cmd(
            [ $ENV{'SHIPWRIGHT_SVN'}, 'cat', $self->repository . $path ] );
        return load_yaml($out);
    }
}

=item info

a wrapper around svn's info command.

=cut

sub info {
    my $self = shift;
    my ( $info, $err ) = $self->SUPER::info(@_);

    if (wantarray) {
        return $info, $err;
    }
    else {
        if ($err) {
            $err =~ s/\s+$//;
            $self->log->warn($err);
            return;
        }
        return $info;
    }
}

=item check_repository

check if the given repository is valid.

=cut

sub check_repository {
    my $self = shift;
    my %args = @_;

    if ( $args{action} eq 'create' ) {

        my ( $info, $err ) = $self->info;

        my $repo = $self->repository;

        # $err like
        # file:///tmp/svn/foo:  (Not a valid URL)
        # usually means foo doesn't exist, which is valid for create
        if ($info) {
            return 1 if $args{force} || $info =~ /Revision: 0/;
            $self->log->fatal("$repo has commits already");
            return;
        }
        return 1 if $err && $err =~ m{^\Q$repo\E:}m;
    }
    else {
        return $self->SUPER::check_repository(@_);
    }
    return;
}

sub _update_file {
    my $self   = shift;
    my $path   = shift;
    my $latest = shift;

    $self->_sync_local_dir( $path );
    my $file = $self->local_dir . $path;
    rcopy( $latest, $file ) or confess_or_die "can't copy $latest to $file: $!";
    $self->commit(
        path => $file,
        comment => "updated $path",
    );
}

sub _update_dir {
    my $self   = shift;
    my $path   = shift;
    my $latest = shift;

    $self->delete( path => $path );
    $self->import( path => $path, source => $latest, _initialize => 1 );
}

sub _initialize_local_dir {
    my $self = shift;
    # the 0 is very important, or it may results in recursion
    my $target = $self->local_dir( 0 );
    remove_tree( $target ) if -e $target;

    run_cmd(
        [ $ENV{'SHIPWRIGHT_SVN'}, 'checkout', $self->repository, $target ] );
    return $target;
}

sub _sync_local_dir {
    my $self = shift;
    my $path = shift || '';
    run_cmd(
        [ $ENV{'SHIPWRIGHT_SVN'}, 'update', $self->local_dir . $path ], 1 );
}

=back

=cut

1;

__END__