File Coverage

perllib/Arch/Tree.pm

Criterion	Covered	Total	%
statement	65	433	15.0
branch	15	244	6.1
condition	21	114	18.4
subroutine	15	49	30.6
pod	30	32	93.7
total	146	872	16.7

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

use Arch::Util qw(run_tla load_file _parse_revision_descs adjacent_revision);
use Arch::Backend qw(
	is_baz has_tree_version_dir_opt has_tree_id_cmd has_set_tree_version_cmd
	has_file_diffs_cmd has_commit_version_arg has_commit_files_separator
);
use Arch::Session;
use Arch::Name;
use Arch::Log;
use Arch::Inventory;
use Arch::Changes qw(:type);
use Arch::Changeset;

use Cwd;

sub new ($;$%) {
	my $class = shift;
	my $dir = shift || ".";
	die "No tree dir $dir\n" unless -d $dir;
	my ($root) = run_tla("tree-root", $dir);
	die "No tree root for dir $dir\n" unless $root;
	my %init = @_;

	my $self = {
		dir => $root,
		own_logs => $init{own_logs},
		hide_ids => $init{hide_ids},
		cache_logs => $init{cache_logs},
	};

	bless $self, $class;
	$self->clear_cache;
	return $self;
}

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

	return $self->{dir};
}

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

	($self->{id_tagging_method}) = run_tla("id-tagging-method", "-d", $self->{dir})
		unless $self->{id_tagging_method};

	return $self->{id_tagging_method};
}

sub get_version ($) {
	my $self = shift;
	return $self->{version} if $self->{version};
	my @add_params = has_tree_version_dir_opt()? ("-d"): ();
	my ($version) = run_tla("tree-version", @add_params, $self->{dir});
	return $self->{version} = $version;
}

sub get_revision ($) {
	my $self = shift;
	#return $self->{revision} if $self->{revision};
	my $cmd = has_tree_id_cmd()? "tree-id": "logs -frd";
	my ($revision) = run_tla($cmd, $self->{dir});
	return $self->{revision} = $revision;
}

sub set_version ($$) {
	my $self = shift;
	my $version = shift;

	delete $self->{version};
	my $cmd = has_set_tree_version_cmd()? "set-tree-version": "tree-version";
	run_tla($cmd, "-d", $self->{dir}, $version);

	return $?;
}

sub get_log_versions ($) {
	my $self = shift;
	my @versions = run_tla("log-versions", "-d", $self->{dir});
	return wantarray? @versions: \@versions;
}

sub add_log_version ($$) {
	my $self = shift;
	my $version = shift;

	run_tla("add-log-version", "-d", $self->{dir}, $version);

	return $?;
}

sub get_log_revisions ($;$) {
	my $self = shift;
	my $version = shift || $self->get_version;
	$version =~ s!-(SOURCE|MIRROR)/!/!;
	my @revisions = run_tla("logs", "-f", "-d", $self->{dir}, $version);
	return wantarray? @revisions: \@revisions;
}

sub get_log ($$) {
	my $self = shift;
	my $revision = shift || die;

	return $self->{cached_logs}->{$revision}
		if $self->{cached_logs}->{$revision};

	my $message;
	if ($self->{own_logs}) {
		my $name = Arch::Name->new($revision);
		$name->is_valid('revision') or die "Invalid revision $revision\n";
		my @n = $name->get;
		my $version_subdir = $n[2] ne ""?
			"$n[1]--$n[2]/$n[1]--$n[2]--$n[3]": "$n[1]/$n[1]--$n[3]";
		my $subdir = "{arch}/$n[1]/$version_subdir/$n[0]/patch-log/$n[4]";
		my $file = "$self->{dir}/$subdir";
		$message = load_file($file) if -f $file;
	} else {
		$message = run_tla("cat-log", "-d", $self->{dir}, $revision);
	}
	return undef unless $message;

	my $log = Arch::Log->new($message, hide_ids => $self->{hide_ids});
	$self->{cached_logs}->{$revision} = $log
		if $self->{cache_logs};
	return $log;
}

sub get_logs ($;$) {
	my $self = shift;
	my $version = shift || $self->get_version;
	my $versions = ref($version) eq 'ARRAY'? $version:
		$version eq '*'? $self->get_log_versions: [ $version ];

	my @logs = ();
	foreach (@$versions) {
		my $revisions = $self->get_log_revisions($_);
		foreach my $revision (@$revisions) {
			push @logs, $self->get_log($revision);
		}
	}
	return wantarray? @logs: \@logs;
}

sub get_log_revision_descs ($;$) {
	my $self = shift;
	my $version = shift;

	my $logs = $self->get_logs($version);
	my $revision_descs = [];
	foreach my $log (@$logs) {
		push @$revision_descs, $log->get_revision_desc;
	}
	return $revision_descs;
}

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

	return Arch::Inventory->new($self->root);
}

# TODO: properly support file name escaping
sub get_changes ($) {
	my $self = shift;
	my $is_baz = is_baz();
	my @args = $is_baz ? qw(status) : qw(changes -d);
	my @lines = run_tla(@args, $self->{dir});

	return undef
		if ($? >> 8) == 2;

	my $baz_1_1_conversion_table;
	$baz_1_1_conversion_table = {
		'A ' => [ 'A ', 'A/' ],
		'D ' => [ 'D ', 'D/' ],
		'R ' => [ '=>', '/>' ],
		' M' => [ 'M ', '??' ],
		' P' => [ '--', '-/' ],
	} if $is_baz;

	my $changes = Arch::Changes->new;
	foreach my $line (@lines) {
		next if $line =~ /^\*/;
		next if $line eq "";

		# work around baz-1.1 tree-lint messages
		last if $line =~ /^These files would be source but lack inventory ids/;

		# support baz
		if ($is_baz && $line =~ /^([ADR ][ MP])  (.+?)(?: => (.+))?$/) {
			my $tla_prefix = $baz_1_1_conversion_table->{$1};
			die "Unknown 'baz status' line: $line\n" unless $tla_prefix;
			# baz-1.1 lacks info about dirs, so stat file (may not work)
			my $is_dir = $1 eq 'R '
				? -d "$self->{dir}/$3"
				: -d "$self->{dir}/$2";
			$line = $tla_prefix->[$is_dir ? 1 : 0] . " $2";
			$line .= "\t$3" if $3;
		}

		$line =~ m!^([ADM=/-])([ />b-]) ([^\t]+)(?:\t([^\t]+))?$!
			or die("Unrecognized changes line: $line\n");

		my $type   = $1;
		my $is_dir = ($1 eq '/') || ($2 eq '/');
		my @args   = ($3, $4);

		# fix tla changes inconsistency with renamed directories ('/>' vs '=/')
		$type = '=' if $type eq '/';

		$changes->add($type, $is_dir, @args);
	}

	return $changes;
}

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

	die("Directory already exists: $dir\n")
		if (-d $dir);

	my $cmd = is_baz()? "diff": "changes";
	run_tla($cmd, "-d", $self->{dir}, "-o", $dir);

	return -f "$dir/mod-dirs-index"
		? Arch::Changeset->new("changes.".$self->get_version(), $dir)
		: undef;
}

sub get_merged_log_text ($) {
	my $self = shift;
	my $text = run_tla("log-for-merge", "-d", $self->{dir});
	return $text;
}

sub get_merged_revision_summaries ($) {
	my $self = shift;
	my $text = $self->get_merged_log_text;
	my @hash = ();

	$text eq "" or $text =~ s/^Patches applied:\n\n//
		or die "Unexpected merged log output:\n$text\n";

	while ($text =~ s/^ \* (.*)\n(.+\n)*\n//) {
		push @hash, $1;
		my $summary = $2;
		$summary =~ s/^   //g;
		$summary =~ s/\n$//;
		push @hash, $summary;
	}
	die "Unexpected merged log sub-output:\n$text\n" if $text ne "";

	return @hash if wantarray;
	my %hash = @hash;
	return \%hash;
}

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

	my $revision_summaries = $self->get_merged_revision_summaries;
	my @array = sort keys %$revision_summaries;
	return wantarray ? @array : \@array;
}

sub get_missing_revisions ($;$) {
	my $self = shift;
	my $version = shift || $self->get_version;

	$self->{missing_revisions}->{$version} ||= [
		run_tla("missing", "-d", $self->{dir}, $version)
	];
	my $array = $self->{missing_revisions}->{$version};
	return wantarray ? @$array : $array;
}

sub get_missing_revision_descs ($;$) {
	my $self = shift;
	my $version = shift || $self->get_version;

	unless ($self->{missing_revision_descs}->{$version}) {
		my @revision_lines =
			map { /^\S/? (undef, $_): $_ }
			run_tla("missing -scD", "-d", $self->{dir}, $version);
		shift @revision_lines;  # throw away first undef

		my $revision_descs = _parse_revision_descs(4, \@revision_lines);
		$self->{missing_revision_descs}->{$version} = $revision_descs;
		$self->{missing_revisions}->{$version} =
			[ map { $_->{name} } @$revision_descs ];
	}
	return $self->{missing_revision_descs}->{$version};
}

# for compatibility only, may be removed after summer 2005
*get_missing_revision_details = *get_missing_revision_descs;
*get_missing_revision_details = *get_missing_revision_details;

sub get_previous_revision ($;$) {
	my $self = shift;
	my $revision = shift || $self->get_revision;

	return adjacent_revision($revision, -1)
		unless $revision =~ /^(.*)--version-0$/;

	# handle version-0 case specially, can't be guessed from the name alone
	my $revisions = $self->get_log_revisions($1);
	until (pop @$revisions eq $revision) {
	}
	return $revisions->[-1];
}

sub get_ancestry_logs ($%) {
	my $self = shift;
	my %args = @_;

	my $limit = $args{limit} || 0;
	my $callback = $args{callback};
	my $one_version = $args{one_version} || 0;
	my $no_continuation = $args{no_continuation} || 0;

	my @collected = ();
	my $version = $self->get_version if $one_version;
	my $revision = $self->get_revision;
	while ($revision) {
		my $log = $self->get_log($revision);

		# handle removed logs
		unless ($log) {
			$revision = $self->get_previous_revision($revision);
			next;
		}

		my $kind = $log->get_revision_kind;
		if ($kind eq 'import') {
			$revision = undef;
		} elsif ($kind eq 'tag') {
			$revision = $no_continuation
				? undef
				: $log->continuation_of;
			$revision &&= undef
				if $one_version && $revision !~ /^\Q$version--/;
		} else {
			$revision = $self->get_previous_revision($revision);
		}
		push @collected, $callback? $callback->($log): $log;
		last unless --$limit && $log;  # undefined by callback
	}
	return \@collected;
}

# for compatibility only, may be removed after summer 2005
sub iterate_ancestry_logs ($;$$) {
	my $self = shift;
	my $cb = shift;
	my $nc = shift || 0;
	return $self->get_ancestry_logs(callback => $cb, no_continuation => $nc);
}

sub get_history_revision_descs ($;$%) {
	my $self = shift;
	my $filepath = shift;
	@_ = (one_version => $_[0]) if @_ == 1;  # be compatible until summer 2005
	my %args = @_;

	my $limit = delete $args{limit} || 0;
	my $callback = delete $args{callback};

	my ($is_dir, $changed);
	if (defined $filepath) {
		my $full_filepath = "$self->{dir}/$filepath";
		# currently stat the existing tree file/dir
		$is_dir = -l $full_filepath? 0: -d _? 1: -f _? 0:
			die "No tree file or dir ($full_filepath)\n";
		$filepath =~ s!/{2,}!/!g;
		$filepath =~ s!^/|/$!!g;
		$filepath = "." if $filepath eq "";  # avoid invalid input die
	}

	return $self->get_ancestry_logs(%args, callback => sub {
		my $log = $_[0];
		if (defined $filepath) {
			$changed = $log->get_changes->is_changed("to", $filepath, $is_dir);
			return unless defined $changed;
		}
		my $revision_desc = $log->get_revision_desc;

		if (defined $filepath) {
			$revision_desc->{filepath} = $filepath;
			$revision_desc->{is_filepath_added}    = $changed->{&ADD}?    1: 0;
			$revision_desc->{is_filepath_renamed}  = $changed->{&RENAME}? 1: 0;
			$revision_desc->{is_filepath_modified} = $changed->{&MODIFY}? 1: 0;

			$revision_desc->{orig_filepath} = $filepath = $changed->{&RENAME}
				if $revision_desc->{is_filepath_renamed};
			$_[0] = undef
				if $revision_desc->{is_filepath_added};
		}

		my @returned = $callback
			? $callback->($revision_desc, $log)
			: $revision_desc;

		$_[0] = undef unless --$limit && $revision_desc;  # undefined by callback
		return @returned;
	});
}

# for compatibility only, may be removed after 2005
*get_ancestry_revision_descs = *get_history_revision_descs;
*get_ancestry_revision_descs = *get_ancestry_revision_descs;

# parse input like "3-5,8" or [ 3..5, 8 ] or { 3 => 1, 4 => 1, 5 => 1, 8 => 1 }
sub _get_skip_hash_from_linenums ($$) {
	my $linenums = shift;
	my $max_linenum = shift;

	my %skip_linenums = ();
	if (defined $linenums) {
		%skip_linenums = map { $_ => 1 } 1 .. $max_linenum;
		if (!ref($linenums)) {
			$linenums = [ map {
				die "Invalid line range ($_)\n" unless /^(\d+)?(-|\.\.)?(\d+)?$/;
				$2? ($1 || 1) .. ($3 || $max_linenum): $1
			} split(',', $linenums) ];
		}
		if (ref($linenums) eq 'ARRAY') {
			$linenums = { map { $_ => 1 } @$linenums };
		}
		if (ref($linenums) eq 'HASH') {
			delete $skip_linenums{$_} foreach keys %$linenums;
		}
	}
	return \%skip_linenums;
}

sub _eq ($$) {
	my $value1 = shift;
	my $value2 = shift;
	return defined $value1 && defined $value2 && $value1 == $value2
		|| !defined $value1 && !defined $value2;
}

# see tests/tree-annotate-1 to understand input and output
sub _group_annotated_lines ($$) {
	my $lines = shift;
	my $line_rd_indexes = shift;

	my $last_line_index = undef;
	my $last_rd_index = -1;
	for (my $i = @$lines; @$lines && $i >= 0; $i--) {
		if ($i == 0 || !_eq($last_rd_index, -1) && !_eq($line_rd_indexes->[$i - 1], $last_rd_index)) {
			splice(@$line_rd_indexes, $i + 1, $last_line_index - $i);
			splice(@$lines, $i, $last_line_index - $i + 1, [ @$lines[$i .. $last_line_index] ]);
		}
		if ($i > 0 && (_eq($last_rd_index, -1) || !_eq($line_rd_indexes->[$i - 1], $last_rd_index))) {
			$last_line_index = $i - 1;
			$last_rd_index = $line_rd_indexes->[$i - 1];
		}
	}
}

sub get_annotate_revision_descs ($$;%) {
	my $self = shift;
	my $filepath = shift || die "No file to annotate\n";
	my %args = @_;

	my $prefetch_callback = delete $args{prefetch_callback};
	my $callback = delete $args{callback};
	my $linenums = delete $args{linenums};
	my $match_re = delete $args{match_re};
	my $highlight = delete $args{highlight};
	my $full_history = delete $args{full_history};
	$linenums ||= [] if $match_re;  # no lines by default if regexp given

	my $full_filepath = "$self->{dir}/$filepath";
	die "No file $full_filepath to annotate\n" unless -f $full_filepath;

	require Arch::DiffParser;
	my $diff_parser = Arch::DiffParser->new;
	my @lines;
	load_file($full_filepath, \@lines);

	if ($highlight) {
		require Arch::FileHighlighter;
		my $fh = Arch::FileHighlighter->instance;
		my $html_ref = $fh->highlight($full_filepath);
		chomp($$html_ref);
		@lines = split(/\n/, $$html_ref, -1);
	}

	my @line_rd_indexes = (undef) x @lines;
	my @line_rd_index_refs = map { \$_ } @line_rd_indexes;

	my $num_unannotated_lines = @lines;
	my $num_revision_descs = 0;
	my $session = Arch::Session->instance;

	# limit to certain lines only if requested, like "12-24,50-75,100-"
	my $skip_linenums = _get_skip_hash_from_linenums($linenums, 0 + @lines);
	if ($match_re) {
		my $re = eval { qr/$match_re/ };
		die "get_annotate_revision_descs: invalid regexp /$match_re/: $@" unless defined $re;
		$lines[$_ - 1] =~ $re && delete $skip_linenums->{$_} for 1 .. @lines;
	}
	$num_unannotated_lines -= keys %$skip_linenums;
	$line_rd_index_refs[$_ - 1] = undef foreach keys %$skip_linenums;

	my $revision_descs = $num_unannotated_lines == 0? []:
	$self->get_history_revision_descs($filepath, %args, callback => sub {
		my ($revision_desc, $log) = @_;

		goto FINISH if $num_unannotated_lines == 0;
		my $old_num_unannotated_lines = $num_unannotated_lines;

		# there is no diff on import, so include all lines manually
		if ($log->get_revision_kind eq 'import') {
			for (my $i = 1; $i <= @line_rd_index_refs; $i++) {
				my $ref = $line_rd_index_refs[$i - 1];
				if ($ref && !$$ref) {
					$$ref = $num_revision_descs;
					$num_unannotated_lines--;
				}
			}
			goto FINISH;
		}

		# only interested in file addition and modification
		goto FINISH unless $revision_desc->{is_filepath_modified}
			|| $revision_desc->{is_filepath_added};

		# fetch changeset first
		my $revision = Arch::Name->new($revision_desc->{version})
			->apply($revision_desc->{name});
		my $filepath = $revision_desc->{filepath};
		$prefetch_callback->($revision, $filepath) if $prefetch_callback;
		my $changeset = eval {
			$session->get_revision_changeset($revision);
		};
		# stop if some ancestry archive is not registered or accessible
		unless ($changeset) {
			$_[0] = undef;
			return ();
		}
		# get file diff if any
		my $diff = $changeset->get_patch($filepath);
		# ignore metadata modification
		goto FINISH if $diff =~ /^\*/;

		# calculate annotate data for file lines affected in diff
		my $changes = $diff_parser->parse($diff)->changes;
		foreach my $change (reverse @$changes) {
			my ($ln1, $size1, $ln2, $size2) = @$change;
			for (my $i = $ln2; $i < $ln2 + $size2; $i++) {
				die "get_annotate_revision_descs: inconsistent source line #$i in diff:\n"
					. "    $revision\n    $filepath\n"
					. "    ($ln1, $size1, $ln2, $size2)\n"
					if $i > @line_rd_index_refs;
				my $ref = $line_rd_index_refs[$i - 1];
				if ($ref && !$$ref) {
					$$ref = $num_revision_descs;
					$num_unannotated_lines--;
				}
			}
			splice(@line_rd_index_refs, $ln2 - 1, $size2, (undef) x $size1);
		}

		FINISH:
		die "get_annotate_revision_descs: inconsistency (some lines left)\n"
			if $revision_desc->{is_filepath_added} && $num_unannotated_lines > 0;
		die "get_annotate_revision_descs: inconsistency (got extra lines)\n"
			if $num_unannotated_lines < 0;

		# stop "history" processing if all lines are annotated
		$_[0] = undef
			if !$full_history && $num_unannotated_lines == 0;

		# skip "history" revision that does not belong to "annotate"
		return () if !$full_history
			&& $old_num_unannotated_lines == $num_unannotated_lines;

		$num_revision_descs++;

		my @returned = $callback
			? $callback->($revision_desc, $log)
			: $revision_desc;

		$_[0] = undef unless $revision_desc;  # undefined by callback
		return @returned;
	});

	return $revision_descs unless wantarray;

	_group_annotated_lines(\@lines, \@line_rd_indexes) if $args{group};
	return (\@lines, \@line_rd_indexes, $revision_descs);
}

sub clear_cache ($;@) {
	my $self = shift;
	my @keys = @_;

	@keys = qw(missing_revision_descs missing_revisions cached_logs)
		unless @keys;

	foreach (@keys) {
		if (@_ && !exist $self->{$_}) {
			warn __PACKAGE__ . "::clear_cache: unknown key ($_), ignoring\n";
			next;
		}
		$self->{$_} = {};
	}

	return $self;
}

sub get_file_diff ($$) {
	my $self = shift;
	my $path = shift;

	my $cwd = getcwd;
	chdir($self->{dir});
	my $cmd = has_file_diffs_cmd()? "file-diffs": "file-diff";
	my $diff = run_tla($cmd, "-N", $path);
	chdir($cwd);

	return $diff;
}

sub add ($;@) {
	my $self = shift;
	my $opts = shift if ref($_[0]) eq 'HASH';
	my @files = @_;

	my @args = ();
	push @args, "--id", $opts->{id} if $opts->{id};
	push @args, @files;

	my $cwd = getcwd();
	chdir($self->{dir}) && run_tla("add-id", @args);
	chdir($cwd);

	return $?;
}

sub delete ($;@) {
	my $self = shift;
	my @files = @_;

	my $cwd = getcwd();
	chdir($self->{dir}) && run_tla("delete-id", @files);
	chdir($cwd);

	return $?;
}

sub move ($;@) {
	my $self = shift;
	my @files = @_;

	my $cwd = getcwd();
	chdir($self->{dir}) && run_tla("move-id", @files);
	chdir($cwd);

	return $?;
}

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

	my ($file) = run_tla("make-log", "-d", $self->{dir});
	return $file;
}

sub import ($;$@) {
	my $self = shift;
	return unless ref($self);  # ignore perl's import() method
	my $opts = shift if ref($_[0]) eq 'HASH';
	my $version = shift || $self->get_version;

	my $is_baz = is_baz();
	my @args = ();
	foreach my $opt (qw(archive log summary log-message)) {
		push @args, "--$opt", $opts->{$opt} if $opts->{$opt};
	}
	push @args, "--setup" unless $is_baz || $opts->{nosetup};
	push @args, "--dir" unless $is_baz;
	push @args, $opts->{dir} || $self->{dir};

	# baz-1.2 advertizes but does not actually support directory argument
	# this block may be deleted later (the bug is fixed in baz-1.3)
	if ($is_baz) {
		my $cwd = getcwd();
		my $dir = pop @args;
		chdir($dir) && run_tla("import", @args, $version);
		chdir($cwd);
		return $?;
	}

	run_tla("import", @args, $version);

	return $?;
}

sub commit ($;$) {
	my $self = shift;
	my $opts = shift if ref($_[0]) eq 'HASH';
	my $version = shift;

	my @args = ();
	push @args, "--dir", $self->{dir} unless $opts->{dir};
	foreach my $opt (qw(archive dir log summary log-message file-list)) {
		my $_opt = $opt; $_opt =~ s/-/_/g;
		push @args, "--$opt", $opts->{$_opt} if $opts->{$_opt};
	}
	foreach my $opt (qw(strict seal fix out-of-date-ok)) {
		my $_opt = $opt; $_opt =~ s/-/_/g;
		push @args, "--$opt" if $opts->{$_opt};
	}

	if (has_commit_version_arg()) {
		push @args, $version || $self->get_version;
	} elsif ($version) {
		warn "This arch backend's commit does not support version arg\n";
	}

	my $files = $opts->{files};
	if ($files) {
		die "commit: files is not ARRAY ($files)\n"
			unless ref($files) eq 'ARRAY';
		push @args, "--" if has_commit_files_separator();
		push @args, @$files;
	}

	run_tla("commit", @args);

	return $?;
}

1;

__END__