File Coverage

perllib/Arch/Name.pm

Criterion	Covered	Total	%
statement	138	151	91.3
branch	73	94	77.6
condition	21	28	75.0
subroutine	29	31	93.5
pod	21	21	100.0
total	282	325	86.7

# Arch Perl library, Copyright (C) 2004 Mikhael Goikhman
#
# 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::Name;

my @ELEMENTS = qw(none archive category branch version revision);
my $i = -1;
my %ELEMENT_INDEX = map { $_ => $i, substr($_, 0, 1) => ++$i } @ELEMENTS;
my $ERROR = undef;  # yes, it is intentionally global

my $archive_re  = qr/[-\w]+(?:\.[-\w]+)*@[-\w.]*/;
my $category_re = qr/[a-zA-Z](?:[\w]|-[\w])*/;
my $branch_re   = $category_re;
my $version_re  = qr/\d+(?:\.\d+)*/;
my $revision_re = qr/base-0|(?:version|patch|versionfix)-\d+/;

sub new ($;$$) {
	my $class = shift;
	my $param = shift;
	my $on_error = shift || 0;
	$class = ref($class) if ref($class);

	my $self = [];
	bless $self, $class;
	if ($param) {
		$self->set($param);
	} else {
		$ERROR = "$class object constructed with empty name" if $on_error >= 0;
	}

	die "$ERROR\n" if $on_error > 1 && $ERROR;
	return $self;
}

sub set ($$) {
	my $self = shift;
	my $param = shift;

	@$self = ();
	$ERROR = undef;

	if (!$param) {
		# do nothing
	} elsif (!ref($param)) {
		# parse string
		if ($param =~ m!^($archive_re)(?:/($category_re)(?:(?:--($branch_re|))?(?:--($version_re|FIRST|LATEST)(?:--($revision_re|FIRST|LATEST))?)?)?)?$!o) {
			@$self = ($1, $2, $3, $4, $5);
			splice(@$self, @$self - 1) until defined $self->[-1];
			# handle branchless names
			$self->[$ELEMENT_INDEX{branch} - 1] ||= ""
				if defined $self->[$ELEMENT_INDEX{version} - 1];
		} else {
			$ERROR = "Can't parse name ($param)";
		}
	} elsif (UNIVERSAL::isa($param, 'Arch::Name')) {
		@$self = @$param;
	} elsif (ref($param) eq 'ARRAY') {
		$self->apply(@$param) if @$param;
	} elsif (ref($param) eq 'HASH') {
		$self->apply($param) if %$param;
	} else {
		$ERROR = "set: invalid parameter ($param), ignored";
	}
	return $self;
}

sub clone ($;@) {
	my $self = shift;
	my $clone = $self->new(undef, -1);
	@$clone = @$self;  # faster, don't perform checks
	$clone->apply(@_) if @_;
	return $clone;
}

sub apply ($;@) {
	my $self = shift;
	my $items = $_[0];

	$ERROR = undef;
	if (ref($items) eq 'HASH') {
		my %items = %$items;  # modify a copy
		my $i = 0;
		foreach my $regexp (
			$archive_re,
			$category_re,
			$branch_re,
			$version_re,
			$revision_re,
		) {
			my $elem = $ELEMENTS[$i + 1];
			next unless exists $items{$elem};
			my $item = $items{$elem};
			if (defined $item && $i > @$self) {
				$ERROR = "apply: can't change $elem without $ELEMENTS[$i]";
				last;
			}
			if (!defined $item) {
				splice(@$self, $i) if @$self > $i;
			} elsif ($elem eq "branch" && $item eq "" || $item =~ /^$regexp$/) {
				$self->[$i] = $item;
			} else {
				$ERROR = "apply: invalid $elem ($item)";
				last;
			}
			delete $items{$elem};
		} continue {
			$i++;
		}
		splice(@$self, $i) if @$self > $i;
		$ERROR ||= "apply: unknown elements (" . join(', ', keys %items) . "), ignored"
			if %items;
	} else {
		my %hash = ();
		if (ref($items) eq 'ARRAY') {
			my $level = @$self;
			$ERROR = "apply: excess of items (@$items), some but $level are ignored"
				if @$items > $level;
			$hash{$ELEMENTS[$level--] || 'none'} = $_ foreach @$items;
			shift;
		}
		my @items = @_;
		if (ref($items[0])) {
			$ERROR = "apply: unsupported arguments (@items)";
			@items = ();
		}
		my $level = @$self;
		$ERROR = "apply: excess of items (@items) for level $level, some are ignored"
			if @items >= @ELEMENTS - $level;
		$hash{$ELEMENTS[++$level] || 'none'} = $_ foreach @items;
		delete $hash{none};
		$self->apply(\%hash);
	}
	return $self;
}

sub go_up ($;$) {
	my $self = shift;
	my $level = shift || 1;
	return $self->apply([ (undef) x $level ]);
}

sub go_down ($@) {
	my $self = shift;
	return $self->apply(@_);
}

sub parent ($;$) {
	my $self = shift;
	return $self->clone->go_up(@_);
}

sub child ($@) {
	my $self = shift;
	return $self->clone->go_down(@_);
}

sub to_string ($) {
	my $self = shift;
	my $name = "";
	$name .= $self->[0] if @$self;
	$name .=  "/$self->[1]" if @$self > 1;
	$name .= "--$self->[2]" if @$self > 2 && $self->[2] ne "";
	$name .= "--$self->[3]" if @$self > 3;
	$name .= "--$self->[4]" if @$self > 4;
	return $name;
}

sub to_nonarch_string ($) {
	my $self = shift;
	my $name = $self->to_string;
	$name =~ s|^.*/||;
	return $name;
}

sub to_array ($) {
	my $self = shift;
	return wantarray? @$self: [ @$self ];
}

sub to_hash ($) {
	my $self = shift;
	my %hash = ();
	for (my $i = 0; $i < @$self; $i++) {
		$hash{$ELEMENTS[$i + 1]} = $self->[$i];
	}
	return wantarray? %hash: \%hash;
}

*fqn = *to_string; *fqn = *fqn;
*get = *to_array;  *get = *get;
*nan = *to_nonarch_string; *nan = *nan;

sub archive ($;$) {
	my $self = shift;
	return $self->[0] unless @_;
	$self->apply({ archive => shift });
}

sub category ($;$) {
	my $self = shift;
	return $self->[1] unless @_;
	$self->apply({ category => shift });
}

sub branch ($;$) {
	my $self = shift;
	return $self->[2] unless @_;
	$self->apply({ branch => shift });
}

sub version ($;$) {
	my $self = shift;
	return $self->[3] unless @_;
	$self->apply({ version => shift });
}

sub revision ($;$) {
	my $self = shift;
	return $self->[4] unless @_;
	$self->apply({ revision => shift });
}

sub error ($) {
	my $self = shift;
	return $ERROR;
}

sub level ($;$) {
	my $self = shift;
	my $stringify = shift;
	return scalar @$self unless $stringify;
	return $ELEMENTS[@$self];
}

sub cast ($$) {
	my $self = shift;
	my $elem = shift;
	my $index1 = $elem =~ /^\d+$/? $elem: $ELEMENT_INDEX{$elem};
	die "cast: invalid arg given ($elem)\n" unless defined $index1;
	return undef if $index1 > @$self;

	my $clone = $self->new(undef, -1);
	@$clone = (@$self)[0 .. $index1 - 1];
	return $clone;
}

sub is_valid ($;$$) {
	my $this = shift;
	my $self = ref($this)? $this: $this->new(shift);
	my $elem = shift;
	return @$self > 0 unless defined $elem;
	my $at_least = $elem =~ s/\+$//;
	my $index1 = $elem =~ /^\d+$/? $elem: $ELEMENT_INDEX{$elem};
	die "is_valid: invalid arg given ($elem)\n" unless defined $index1;
	return $index1 <= @$self if $at_least;
	return $index1 == @$self;
}

use overload
	'""'   => 'to_string',
	'0+'   => sub { $_[0]->level },
	'bool' => sub { $_[0]->is_valid },
	'='    => sub { $_[0]->clone },
	'+'    => sub { $_[0]->child($_[1]) },
	'-'    => sub { $_[0]->parent($_[1]) },
	'+='   => sub { $_[0]->go_down($_[1]) },
	'-='   => sub { $_[0]->go_up($_[1]) },
	'fallback' => 1;

1;

__END__