libarch-perl 0.5.2-1 / usr / share / perl5 / Arch / Log.pm

# 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__

=head1 NAME

Arch::Log - class representing Arch patch-log

=head1 SYNOPSIS 

    use Arch::Log;
    my $log = Arch::Log->new($rfc2822_message_string);
    printf "Patch log date: %s\n", $log->header('standard_date');
    print $log->dump;
    my $first_new_file = $log->get_headers->{new_files}->[0];

=head1 DESCRIPTION

This class represents the patch-log concept in Arch and provides some
useful methods.

=head1 METHODS

The following class methods are available:

B<get_message>,
B<get_headers>,
B<header>,
B<get_changes>,
B<split_version>,
B<get_version>,
B<get_revision>,
B<get_revision_kind>,
B<get_revision_desc>,
B<dump>.

=over 4

=item B<get_message>

Return the original message with that the object was constructed.

=item B<get_headers>

Return the hashref of all headers including body, see also C<header> method.

=item B<header> name

=item B<header> name [new_value]

Get or set the named header. The special name 'body' represents the
message body (the text following the headers).

=item B<body> [new_value]

=item existing_header_name [new_value]

This is just a shortcut for C<header>('I<method>'). However unlike
C<header>('I<method>'), I<method> fails instead of returning undef if the log
does not have the given header name.

=item B<get_changes>

Return a list of changes in the corresponding changeset.

B<ATTENTION!> Patch logs do not distinguish metadata (ie permission)
changes from ordinary content changes. Permission changes will be
represented with a change type of 'M'. This is different from
L<Arch::Changeset>::B<get_changes> and L<Arch::Tree>::B<get_changes>.

=item B<split_version>

Return a list of 2 strings: full version and patch-level.

=item B<get_version>

Return the full version name, not unlike B<split_version>.

=item B<get_revision>

Return the full revision name.  This is currently a concatination of
headers Archive and Revision with '/' separator.

=item B<get_revision_kind>

Return one of the strings 'tag', 'import' or 'cset' depending on the
revision kind this log represents.

=item B<get_revision_desc>

Return revision description hashref with the keys:
name, version, summary, creator, email, date, kind.

=item B<dump>

Returns the object dump using L<Data::Dumper>.

=back

=head1 BUGS

Awaiting for your reports.

=head1 AUTHORS

Mikhael Goikhman (migo@homemail.com--Perl-GPL/arch-perl--devel).

=head1 SEE ALSO

For more information, see L<tla>, L<Arch::Session>, L<Arch::Library>,
L<Arch::Changes>.

=cut