File Coverage

blib/lib/SVN/Notify/Mirror.pm

Criterion	Covered	Total	%
statement	19	74	25.6
branch	0	26	0.0
condition	1	8	12.5
subroutine	5	8	62.5
pod	2	2	100.0
total	27	118	22.8

#!/usr/bin/perl -w

package SVN::Notify::Mirror;
use base qw/SVN::Notify/;
use strict;

use vars qw ($VERSION);
$VERSION = '0.040';
$VERSION = eval $VERSION;

__PACKAGE__->register_attributes(
    'ssh_host'     => 'ssh-host=s',
    'ssh_user'     => 'ssh-user:s',
    'ssh_tunnel'   => 'ssh-tunnel:s',
    'ssh_identity' => 'ssh-identity:s',
    'svn_binary'   => 'svn-binary:s',
    'tag_regex'    => 'tag-regex:s',
    'minimal'      => 'minimal',
);

sub prepare {
    my $self = shift;
    $self->prepare_recipients;
    $self->prepare_files;
}

sub execute {
    my ($self) = @_;
    return unless defined $self->to;
    $self->svn_binary( $ENV{SVN} || SVN::Notify->find_exe('svn') )
    	unless $self->svn_binary;

    foreach my $to ( $self->to ) {
	my $command = 'update';
	my @args = (
	    -r => $self->revision,
	);

	# need to swap function calls for backwards compatibility for now
	if ( defined $self->ssh_host
	     and not $self->isa('SVN::Notify::Mirror::SSH') )
	{
	    no warnings 'redefine';
	    warn "Deprecated - please use SVN::Notify::Mirror::SSH directly";
	    require SVN::Notify::Mirror::SSH;
	    *_cd_run = \&SVN::Notify::Mirror::SSH::_cd_run;
	}

	# deal with the possible switch case
	if ( defined $self->tag_regex ) {
	    $DB::single = 1;
	    $command = 'switch';
	    my $regex = $self->tag_regex;
	    my ($tag) = grep /$regex/, @{$self->{'files'}->{'A'}};
	    $tag =~ s/^.+\/tags\/(.+)/$1/;
	    return unless $tag;
	    my @message = $self->_cd_run(
		$to,
		$self->svn_binary,
		'info',
	    );
	    my $URL = (split ": ", $message[1], 2)[1];
	    if ( $URL =~ m/^(.+\/tags\/).+$/m ) {
		my $url = $1;
		$tag = $url.$tag;
	    }
	    push @args, $tag;
	}

	if ( $self->minimal ) {
	    # perform minimal update only
	    my @paths;
	    my $prefix = $self->{'handle_path'}; # simple case
	    unless ( $prefix ) {
		# hard case
		$DB::single = 1;
		my @message = $self->_cd_run($to, $self->svn_binary, 'info');
		my $URL = (split ": ", $message[1], 2)[1];
		my $ROOT = (split ": ", $message[2], 2)[1];
		$ROOT .= '/' unless $ROOT =~ m:/$:;
		($prefix = $URL) =~ s/$ROOT//;
	    }

	    foreach my $files ( values %{ $self->files } ) {
		push @paths, map { s/$prefix// && $_ } @{ $files };
	    }
	    $to .= '/'. _shortest_path(@paths);
	}

	print join("\n",
	    $self->_cd_run(
		$to,
		$self->svn_binary,
		$command,
		@args,
	    )
	);
    }
}

sub _cd_run {
    my ($self, $path, $binary, $command, @args) = @_;
    my @message;
    my $cmd ="$binary $command " . join(" ",@args);
    $self->_dbpnt("running 'cd $path; $cmd'") if $self->{verbose} > 1;

    chdir ($path) or die "Couldn't CD to $path: $!";

    open my $RUN, '-|', $cmd
      or die "Running [$cmd] failed with $?: $!";
    while (<$RUN>) {
	chomp;
	push @message, $_;
    }
    close $RUN;
    return (@message);
}

sub _shortest_path {
    my @dirs = grep { /\S/ } @_;

    # Set shortest_path to first dir
    my $shortest_path = shift(@dirs) || '';

    # Find common prefix between each dir and shortest_path
    foreach my $dir (@dirs) {
        chop $shortest_path while (index($dir, $shortest_path) != 0);
    }

    # Remove final / and anything after
    $shortest_path =~ s{/[^/]*?$}{};

    return $shortest_path;
}

1;

__END__