File Coverage

perllib/Arch/Library.pm

Criterion	Covered	Total	%
statement	24	151	15.8
branch	0	46	0.0
condition	0	41	0.0
subroutine	8	25	32.0
pod	15	16	93.7
total	47	279	16.8

# 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::Library;

use base 'Arch::Storage';

use Arch::Util qw(run_tla load_file standardize_date parse_creator_email date2age);
use Arch::Changeset;
use Arch::Log;
use Arch::Backend qw(has_revlib_patch_set_dir);
use Arch::TempFiles qw(temp_dir);

sub _default_fields ($) {
	my $this = shift;
	return (
		$this->SUPER::_default_fields,
		fallback_dir => undef,
		ready_to_add => 0,
		path => undef,
		working_revision => undef,
		revision_trees => {},
	);
}

sub archives ($) {
	my $self = shift;
	return [ run_tla('library-archives') ];
}

sub categories ($;$) {
	my $self = shift;
	my $archive = shift || $self->working_name;
	return [ run_tla('library-categories', $archive) ];
}

sub branches ($;$) {
	my $self = shift;
	my $full_category = shift || $self->working_name;
	return [ run_tla('library-branches', $full_category) ];
}

sub versions ($;$) {
	my $self = shift;
	my $full_branch = shift || $self->working_name;
	return [ run_tla('library-versions', $full_branch) ];
}

sub revisions ($;$) {
	my $self = shift;
	my $full_version = shift || $self->working_name;
	return [ run_tla('library-revisions', $full_version) ];
}

sub get_revision_descs ($;$) {
	my $self = shift;
	my $full_version = shift || $self->working_name;
	my @lines = run_tla('library-revisions -Dcs', $full_version);

	my @revision_descs = ();
	while (@lines) {
		my ($name, $date, $creator) = splice @lines, 0, 3;
		die "Unexpected date line ($date) in tla library-revisions -Dcs\n"
			unless $date =~ s/^    //;
		die "Unexpected creator line ($creator) in tla library-revisions -Dcs\n"
			unless $creator =~ s/^    //;

		my @summary_lines = ();
		push @summary_lines, shift @lines while @lines && $lines[0] =~ /^    |^\t/;
		my $summary = join("\n", @summary_lines);
		$summary =~ s/^    |^\t//mg;

		$date = standardize_date($date);
		my $age = date2age($date);
		my ($creator1, $email, $username) = parse_creator_email($creator);

		push @revision_descs, {
			name     => $name,
			summary  => $summary,
			creator  => $creator1,
			email    => $email,
			username => $username,
			date     => $date,
			age      => $age,
			kind     => 'lib',
		};
	}
	return \@revision_descs;
}

*revision_details = *get_revision_descs; *revision_details = *revision_details;

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

	my $old_working_name = $self->working_name;
	my $archive_name = shift || $old_working_name;
	$self->working_name($archive_name);
	my ($archive, $category0, $branch0) = $self->working_names;
	my $full_listing = shift || 0;

	my $infos = [];
	$self->working_names($archive);
	foreach my $category ($category0? ($category0): @{$self->categories}) {
		$self->working_names($archive, $category);
		push @$infos, [ $category, [] ];
		foreach my $branch ($branch0? ("$category--$branch0"): @{$self->branches}) {
			$branch = "" unless $branch =~ s/^\Q$category\E--//;
			$self->working_names($archive, $category, $branch);
			push @{$infos->[-1]->[1]}, [ $branch, [] ];
			foreach my $version (@{$self->versions}) {
				die unless $version =~ s/^\Q$category\E(?:--)?\Q$branch\E--//;
				$self->working_names($archive, $category, $branch, $version);
				my $revisions = $self->revisions;
				my $revisions2 = [];
				if ($full_listing) {
					$revisions2 = $revisions;
				} else {
					my $revision0 = $revisions->[0] || '';
					my $revisionl = $revisions->[-1] || '';
					$revisionl = '' if $revision0 eq $revisionl;
					push @$revisions2, $revision0, $revisionl;
				}
				push @{$infos->[-1]->[1]->[-1]->[1]}, [ $version, @$revisions2 ];
			}
		}
	}

	$self->working_name($old_working_name);
	return $infos;
}

sub fallback_dir ($;$) {
	my $self = shift;
	if (@_) {
		my $dir = shift;
		$self->{fallback_dir} = $dir;
	}
	return $self->{fallback_dir};
}

sub working_revision ($;$) {
	my $self = shift;
	if (@_) {
		my $revision = shift;
		$self->{working_revision} = $revision;
	}
	return $self->{working_revision};
}

sub add_revision ($$) {
	my $self = shift;
	my $revision = shift;
	unless ($self->{ready_to_add}) {
		($self->{path}) = run_tla("my-revision-library --silent --add");
		my $fallback_dir = $self->{fallback_dir};
		if (!$self->{path} && $fallback_dir) {
			# don't create more than one directory level to avoid typos
			mkdir($fallback_dir, 0777) unless -d $fallback_dir;
			run_tla("my-revision-library $fallback_dir");
			($self->{path}) = run_tla("my-revision-library --silent --add");
		}
		$self->{ready_to_add} = 1 if $self->{path};
	}
	die "Can't attempt to add revision. No revision-library is defined?\n"
		unless $self->{ready_to_add};
	run_tla("library-add --sparse $revision");
	my $dir = $self->find_revision_tree($revision);
	die "Adding revision $revision to library failed.\nBad permissions or corrupt archive?\n"
		unless $dir;
	return $dir;
}

sub find_revision_tree ($$;$) {
	my $self = shift;
	my $revision = shift || die "find_revision_tree: No revision given\n";
	my $auto_add = shift || 0;
	return $self->{revision_trees}->{$revision} if $self->{revision_tree};
	my ($dir) = run_tla("library-find -s $revision");
	if (!$dir && $auto_add) {
		$dir = $self->add_revision($revision);
	}
	return $self->{revision_trees}->{$revision} = $dir;
}

sub find_tree ($;$) {
	my $self = shift;
	$self->find_revision_tree($self->{working_revision}, @_);
}

sub get_revision_changeset ($$) {
	my $self = shift;
	my $revision = shift || die "get_revision_changeset: No revision given\n";

	my $dir;
	if (has_revlib_patch_set_dir()) {
		my $tree_root = $self->find_revision_tree($revision);
		die "No revision $revision found in library\n" unless $tree_root;

		$dir = "$tree_root/,,patch-set";
	} else {
		$dir = temp_dir();
		run_tla('get-changeset', $revision, $dir);
	}

	return Arch::Changeset->new($revision, $dir);
}

sub get_changeset ($) {
	my $self = shift;
	$self->get_revision_changeset($self->{working_revision}, @_);
}

sub get_revision_log ($$) {
	my $self = shift;
	my $revision = shift || die "get_revision_log: No revision given\n";

	my $message;
	if (has_revlib_patch_set_dir()) {
		my $tree_root = $self->find_revision_tree($revision);
		die "No revision $revision found in library\n" unless $tree_root;

		my $log_file = "$tree_root/,,patch-set/=log.txt";
		die "Missing log $log_file in revision library\n" unless -f $log_file;
		$message = load_file($log_file);
	} else {
		$message = run_tla('library-log', $revision);
	}

	return Arch::Log->new($message);
}

sub get_log ($) {
	my $self = shift;
	$self->get_revision_log($self->{working_revision}, @_);
}

1;

__END__