File Coverage

perllib/Arch/Test/Tree.pm

Criterion	Covered	Total	%
statement	17	109	15.6
branch	1	28	3.5
condition	0	26	0.0
subroutine	6	22	27.2
pod	14	16	87.5
total	38	201	18.9

# Arch Perl library, Copyright (C) 2005 Enno Cramer
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA

use 5.005;
use strict;

package Arch::Test::Tree;

use Arch::TempFiles qw();
use Arch::Util qw();

use POSIX qw(getcwd);

sub new {
	my $class = shift;
	my $fw = shift;
	my $path = shift;

	my $self = {
		root      => $path,
		framework => $fw,
		files     => {
		}
	};

	bless $self, $class;

	return $self;
}

sub root ($) {
	my $self = shift;

	return $self->{root};
}

sub framework ($) {
	my $self = shift;

	return $self->{framework};
}

sub run_tla ($@) {
	my $self = shift;

	my $cwd = getcwd;
	chdir($self->root);
	my @ret = $self->framework->run_tla(@_);
	chdir($cwd);

	return wantarray ? @ret : $ret[0];
}

sub run_cmd ($@) {
	my $self = shift;

	my $cwd = getcwd;
	chdir($self->root);
	my @ret = Arch::Util::run_cmd(@_);
	chdir($cwd);

	die "run_cmd(".join(' ', @_).") failed: $?\n"
		if $?;

	return wantarray ? @ret : $ret[0];
}

sub gen_id ($$) {
	my $self = shift;
	my $parent = shift;

	$self->{files}->{$parent} = 0
		unless exists $self->{files}->{$parent};

	return $self->{files}->{$parent}++;
}

sub add_file ($;$$$) {
	my $self = shift;
	my $dir  = shift || '.';
	my $name = shift || 'file-' . $self->gen_id($dir);
	my $cont = shift || "Content for $name.\n";

	my $fname = "$dir/$name";

	my $path = $self->root . "/$fname";
	Arch::Util::save_file($path, $cont);

	$self->run_tla('add-id', $fname);

	return $fname;
}

sub add_dir ($;$$) {
	my $self = shift;
	my $dir  = shift || '.';
	my $name = shift || 'dir-' . $self->gen_id($dir);

	my $fname = "$dir/$name";

	my $path = $self->root . "/$fname";
	mkdir($path) || die "mkdir($path) failed: $!\n";

	$self->run_tla('add-id', $fname);

	return $fname;
}

sub add_link ($;$$$) {
	my $self = shift;
	my $dir  = shift || '.';
	my $name = shift || 'file-' . $self->gen_id($dir);
	my $cont = shift || "Link-target-for-$name";

	my $fname = "$dir/$name";

	$self->run_cmd('/bin/ln', '-s', $cont, $fname);
	$self->run_tla('add-id', $fname);

	return $fname;
}

sub modify_file($$;$) {
	my $self = shift;
	my $file = shift;
	my $content = shift || Arch::Util::load_file($self->root . "/$file")
		. "Has been modified.\n";

	Arch::Util::save_file($self->root . "/$file", $content);
}

sub rename_file ($$$) {
	my $self = shift;
	my ($old, $new) = @_;

	my $ret = $new;

	if (-d $self->root . "/$new") {
		(my $name = $old) =~ s,(.+/),,;
		$ret .= "/$name";
	}

	$ret = './' . $ret
		unless $ret =~ /^\.\//;

	$self->run_tla('mv', $old, $new);

	return $ret;
}

sub rename_dir ($$$) {
	my $self = shift;
	my ($old, $new) = @_;

	my $ret = $new;

	if (-d $self->root . "/$new") {
		(my $name = $old) =~ s,(.+/),,;
		$ret .= "/$name";
	}

	$ret = './' . $ret
		unless $ret =~ /^\.\//;

	$self->run_cmd('mv', $old, $new);

	return $ret;
}

sub remove_file ($$) {
	my $self = shift;
	my $file = shift;

	$self->run_tla('rm', $file);
}

sub remove_dir ($$) {
	my $self = shift;
	my $dir = shift;

	Arch::Util::remove_dir($self->root . "/$dir");
}

sub inventory ($;$) {
	my $self = shift;
	my $flags = shift || '-Bs';

	return $self->run_tla('inventory', $flags);
}

# this fails in baz-1.2 (that is broken), but not in baz-1.1 and baz-1.3
sub import ($;$$) {
	my $self = shift;
	return unless ref($self);  # this is not for "use"

	my @opts = ('-d', $self->root);

	push @opts, ('-s', shift)
		if @_;

	push @opts, ('-L', shift)
		if @_;

	$self->run_tla('import', @opts);
}

sub commit ($;$$) {
	my $self = shift;

	my @opts = ('-d', $self->root);

	push @opts, ('-s', shift)
		if @_;

	push @opts, ('-L', shift)
		if @_;

	$self->run_tla('commit', @opts);
}

1;

__END__