File Coverage

perllib/Arch/Log.pm

Criterion	Covered	Total	%
statement	65	117	55.5
branch	13	46	28.2
condition	6	15	40.0
subroutine	14	17	82.3
pod	10	11	90.9
total	108	206	52.4

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

use Arch::Changes qw(:type);
use Arch::Util qw(standardize_date parse_creator_email date2age);

sub new ($$%) {
	my $class = shift;
	my $message = shift || die "Arch::Log::new: no message\n";
	my %init = @_;

	my $self = {
		message => $message,
		headers => undef,
		hide_ids => $init{hide_ids},
	};

	return bless $self, $class;
}

sub get_message ($) {
	my $self = shift;
	return $self->{message};
}

use vars qw($SPECIAL_HEADERS);
$SPECIAL_HEADERS = {
	modified_directories => 1,
	modified_files       => 1,
	new_directories      => 1,
	new_files            => 1,
	new_patches          => -1,
	removed_directories  => 1,
	removed_files        => 1,
	renamed_directories  => 2,
	renamed_files        => 2,
};

sub get_headers ($) {
	my $self = shift;
	return $self->{headers} if defined $self->{headers};

	my $message = $self->{message};
	my ($headers_str, $body) = $message =~ /^(.*?\n)\n(.*)$/s
		or die "Incorrect message:\n\n$message\n\n- No body delimeter\n";

	my $headers = { body => $body };
	$headers_str =~ s{^([\w-]+):[ \t]*(.*\n(?:[ \t]+.*\n)*)}{
		my ($header, $value) = (lc($1), $2);
		$header =~ s/-/_/sg;
		die "Duplicate header $header in message:\n\n$message\n"
			if exists $headers->{$header};
		chomp($value);

		# handle special headers (lists, lists of pairs, files but ids)
		my $type = $SPECIAL_HEADERS->{$header};
		if ($type) {
			$value = [ split(/[ \n]+/, $value) ];
			$value = [ grep { !m:(^|/).arch-ids/: } @$value ]
				if $type > 0 && $self->{hide_ids};
			if ($type == 2) {
				my @pairs = ();
				push @pairs, [ splice @$value, 0, 2 ] while @$value;
				$value = \@pairs;
			}
		}
		$headers->{$header} = $value;
		""
	}meg;
	#print "*** $_: $headers->{$_} ***\n" foreach keys %$headers;

	return $self->{headers} = $headers;
}

sub header ($$;$) {
	my $self = shift;
	my $header = shift;
	return $self->get_headers->{$header} unless @_;
	$self->get_headers->{$header} = shift;
}

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

	my $changes = Arch::Changes->new;

	# make a workaround for tla bug: missing New-directories in import log;
	# still, there is no way to figure out empty directory added on import
	my @import_dirs = ();
	if ($self->get_revision_kind eq 'import' && !$self->header('new_directories')) {
		my %import_dirs = ();
		foreach (@{$self->header('new_files') || []}) {
			my $file = $_;
			$import_dirs{$1} = 1 while $file =~ s!^(.+)/.+$!$1!;
		}
		@import_dirs = sort keys %import_dirs;
	}

	# new dirs
	foreach my $path (@{$self->header('new_directories') || []}, @import_dirs) {
		$changes->add(ADD, 1, $path);
	}

	# new files
	foreach my $path (@{$self->header('new_files') || []}) {
		$changes->add(ADD, 0, $path);
	}

	# removed dirs
	foreach my $path (@{$self->header('removed_directories') || []}) {
		$changes->add(DELETE, 1, $path);
	}

	# removed files
	foreach my $path (@{$self->header('removed_files') || []}) {
		$changes->add(DELETE, 0, $path);
	}

	# modified dirs
	foreach my $path (@{$self->header('modified_directories') || []}) {
		# directories cannot be MODIFY'ed
		$changes->add(META_MODIFY, 1, $path);
	}

	# modified files
	foreach my $path (@{$self->header('modified_files') || []}) {
		# logs don't distinguish MODIFY and META_MODIFY
		$changes->add(MODIFY, 0, $path);
	}

	# moved dirs
	foreach my $paths (@{$self->header('renamed_directories') || []}) {
		$changes->add(RENAME, 1, @{$paths});
	}

	# moved files
	foreach my $paths (@{$self->header('renamed_files') || []}) {
		$changes->add(RENAME, 0, @{$paths});
	}

	return $changes;
}

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

	my $full_revision = $self->get_revision;
	die "Invalid archive/revision ($full_revision) in log:\n$self->{message}"
		unless $full_revision =~ /^(.+)--(.+)/;

	return ($1, $2);
}

sub get_version ($) {
	my $self = shift;
	($self->split_version)[0];
}

sub get_revision ($) {
	my $self = shift;
	$self->header('archive') . "/" . $self->header('revision');
}

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

	return $self->header('continuation_of')? 'tag':
		$self->header('revision') =~ /--base-0$/? 'import': 'cset';
}

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

	my ($version, $name) = $self->split_version;
	my $summary = $self->header('summary') || '(none)';
	my ($creator, $email, $username) = parse_creator_email($self->header('creator') || "N.O.Body");
	my $date = $self->header('standard_date') || standardize_date($self->header('date') || "no-date");
	my $age = date2age($date);
	my $kind = $self->get_revision_kind;

	return {
		name     => $name,
		version  => $version,
		summary  => $summary,
		creator  => $creator,
		email    => $email,
		username => $username,
		date     => $date,
		age      => $age,
		kind     => $kind,
	};
}

sub dump ($) {
	my $self = shift;
	my $headers = $self->get_headers;
	require Data::Dumper;
	my $dumper = Data::Dumper->new([$headers]);
	$dumper->Sortkeys(1) if $dumper->can('Sortkeys');
	return $dumper->Quotekeys(0)->Indent(1)->Terse(1)->Dump;
}

sub AUTOLOAD ($@) {
	my $self = shift;
	my @params = @_;

	my $method = $Arch::Log::AUTOLOAD;

	# remove the package name
	$method =~ s/.*://;
	# DESTROY messages should never be propagated
	return if $method eq 'DESTROY';

	if (exists $self->get_headers->{$method}) {
		$self->header($method, @_);
	} else {
		die "Arch::Log: no such header or method ($method)\n";
	}
}

1;

__END__