view release on metacpan or  search on metacpan

lib/SVK/Test.pm  view on Meta::CPAN

use SVK::Path::Checkout;

# Fake standard input
our $answer = [];
our $output;

our $show_prompt = 0;

BEGIN {
    no warnings 'redefine';
    # override get_prompt in XD so devel::cover is happy for
    # already-exported symbols being overridden
    *SVK::Util::get_prompt = *SVK::XD::get_prompt = sub {
	local $| = 1;
	print "$_[0]\n" if $show_prompt;
	$logger->debug("$_[0]");
	return $answer unless ref($answer); # compat
	die "expecting input" unless @$answer;
	my $ans = shift @$answer;
	$logger->debug("-> ".($answer->[0]||''));
	return $ans unless ref($ans);
	
	if (ref($ans->[0]) eq 'Regexp') {
	    Carp::cluck "prompt mismatch ($_[0]) vs ($ans->[0])" unless $_[0] =~ m/$ans->[0]/s;
	}
	else {
	    Carp::cluck "prompt mismatch ($_[0]) vs ($ans->[0])" if $_[0] ne $ans->[0];
	}
	return $ans->[1];
    } unless $ENV{DEBUG_INTERACTIVE};

#    chdir catdir(abs_path(dirname(__FILE__)), '..' );
}

sub plan_svm {
    unless (HAS_SVN_MIRROR) {
	plan skip_all => "SVN::Mirror not installed";
	exit;
    };
    plan @_;
}

use Carp;
use SVK;
use SVK::XD;

END {
    return unless $$ == $pid;
    $SIG{__WARN__} = sub { 1 };
    cleanup_test($_) for @TOCLEAN;
}

for (qw/SVKRESOLVE SVKMERGE SVKDIFF SVKPGP SVKLOGOUTPUT LC_CTYPE LC_ALL LANG LC_MESSAGES/) {
    $ENV{$_} = '' if $ENV{$_};
}
$ENV{LANGUAGE} = $ENV{LANGUAGES} = 'i-default';

$ENV{SVKRESOLVE} = 's'; # default for test
$ENV{HOME} ||= (
    $ENV{HOMEDRIVE} ? catdir(@ENV{qw( HOMEDRIVE HOMEPATH )}) : ''
) || (getpwuid($<))[7];
$ENV{USER} ||= (
    (defined &Win32::LoginName) ? Win32::LoginName() : ''
) || $ENV{USERNAME} || (getpwuid($<))[0];

# Make "prove -l" happy; abs_path() returns "undef" if the path 
# does not exist. This makes perl very unhappy.
@INC = grep defined, map abs_path($_), @INC;

if ($ENV{DEBUG}) {
    {
        package Tie::StdScalar::Tee;
        require Tie::Scalar;
        our @ISA = 'Tie::StdScalar';
        sub STORE { print STDOUT $_[1] ; ${$_[0]} = $_[1]; }
    }
    tie $output => 'Tie::StdScalar::Tee';
}

my $pool = SVN::Pool->new_default;

sub new_repos {
    my $repospath = catdir(tmpdir(), "svk-$$");
    my $reposbase = $repospath;
    my $repos;
    my $i = 0;
    while (-e $repospath) {
	$repospath = $reposbase . '-'. (++$i);
    }
    my $pool = SVN::Pool->new_default;
    $repos = SVN::Repos::create("$repospath", undef, undef, undef,
				{'fs-type' => $ENV{SVNFSTYPE} || 'fsfs'})
	or die "failed to create repository at $repospath";
    return $repospath;
}

sub build_test {
    my (@depot) = @_;

    my $depotmap = {map {$_ => (new_repos())[0]} '',@depot};
    my $xd = SVK::XD->new (depotmap => $depotmap,
			   svkpath => $depotmap->{''});
    my $svk = SVK->new (xd => $xd, $ENV{DEBUG_INTERACTIVE} ? () : (output => \$output));
    push @TOCLEAN, [$xd, $svk];
    return ($xd, $svk);
}

sub build_floating_test {
    my ($directory) = @_;

    my $svkpath = File::Spec->catfile($directory, '.svk');
    my $xd = SVK::XD->new (statefile => File::Spec->catfile($svkpath, 'config'),
			   giantlock => File::Spec->catfile($svkpath, 'lock'),
			   svkpath => $svkpath,
			   floating => $directory);
    $xd->load;
    my $svk = SVK->new (xd => $xd, $ENV{DEBUG_INTERACTIVE} ? () : (output => \$output));
    push @TOCLEAN, [$xd, $svk];
    return ($xd, $svk);
}

sub get_copath {
    my ($name) = @_;
    unless ($name) {