File Coverage

perllib/Arch/Test/Archive.pm

Criterion	Covered	Total	%
statement	9	64	14.0
branch	0	28	0.0
condition	0	4	0.0
subroutine	3	13	23.0
pod	7	10	70.0
total	19	119	15.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::Archive;

use Arch::Backend qw(has_archive_setup_cmd);

sub new ($$$) {
	my $class = shift;
	my ($fw, $name) = @_;

	my $self = {
		name      => $name,
		framework => $fw,
		structure => {
		}
	};

	bless $self, $class;

	return $self;
}

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

	return $self->{name};
}

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

	return $self->{framework};
}

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

	$self->framework->run_tla(@_);
}

# name generation
sub gen_id ($;@) {
	my $self = shift;
	my @tree = @_;

	die "gen_id is private"
		if caller ne __PACKAGE__;

	my $ref = $self->{structure};
	foreach my $key (@tree) {
		$ref->{$key} = { '=count' => 0 }
			unless exists $ref->{$key};

		$ref = $ref->{$key};
	}

	return $ref->{'=count'}++;
}

sub split_arch_name ($$$) {
	my $self = shift;
	my $name = shift || '';
	my $maxlen = shift || 3;

	if ($name =~ s,^(.+)/,,) {
		die "Prefix from different archive: $1\n"
			if $1 ne $self->name;
	}

	my @parts = $name ? split /--/, $name : ();

	die "Arch name $name too long\n"
		if @parts > $maxlen;

	return @parts;
}

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

	return join '--', @_;
}


sub make_category ($;$) {
	my $self = shift;
	my @prefix = @_;

	unshift @prefix, $self->split_arch_name(shift @prefix, 1);

	if (@prefix < 1) {
		push @prefix, "category-" . $self->gen_id(@prefix);
	}

	my $name = $self->join_arch_name(@prefix);
	$self->run_tla('archive-setup', '-A', $self->name, $name)
		if has_archive_setup_cmd();

	return $self->name . "/$name";
}

sub make_branch ($;$$) {
	my $self = shift;
	my @prefix = @_;

	unshift @prefix, $self->split_arch_name(shift @prefix, 2);

	if (@prefix < 2) {
		@prefix = $self->split_arch_name($self->make_category(@prefix), 1)
			if @prefix < 1;

		push @prefix, 'branch-' . $self->gen_id(@prefix);
	}

	my $name = $self->join_arch_name(@prefix);
	$self->run_tla('archive-setup', '-A', $self->name, $name)
		if has_archive_setup_cmd();

	return $self->name . "/$name";
}

sub make_version ($;$$$) {
	my $self = shift;
	my @prefix = @_;

	unshift @prefix, $self->split_arch_name(shift @prefix, 3);

	if (@prefix < 3) {
		@prefix = $self->split_arch_name($self->make_branch(@prefix), 2)
			if @prefix < 2;

		push @prefix, $self->gen_id(@prefix);
	}

	my $name = $self->join_arch_name(@prefix);
	$self->run_tla('archive-setup', '-A', $self->name, $name)
		if has_archive_setup_cmd();

	return $self->name . "/$name";
}


1;

__END__