File Coverage

perllib/Arch/Changes.pm

Criterion	Covered	Total	%
statement	80	89	89.8
branch	12	20	60.0
condition	9	17	52.9
subroutine	20	21	95.2
pod	9	9	100.0
total	130	156	83.3

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

use Exporter;
BEGIN { *Arch::Changes::import = *Exporter::import; }
use vars qw(@EXPORT_OK %EXPORT_TAGS);

@EXPORT_OK = qw(
	ADD DELETE REMOVE MODIFY META_MODIFY RENAME
);
%EXPORT_TAGS = (
	type => [ qw(ADD DELETE REMOVE MODIFY META_MODIFY RENAME) ],
);


use Arch::Util qw(run_tla);

use constant ADD         => 'A';
use constant DELETE      => 'D';
use constant REMOVE      => 'D';  # obsolete, may be removed after summer 2005
use constant MODIFY      => 'M';
use constant META_MODIFY => '-';
use constant RENAME      => '=';

sub new ($$) {
	my $class = shift;

	my $self = {
		changes => [],
	};

	return bless $self, $class;
}

sub add ($$$@) {
	my $self = shift;
	my ($type, $is_dir, @args) = @_;

	push @{$self->{changes}}, {
		type      => $type,
		is_dir    => $is_dir ? 1 : 0,
		arguments => [ @args ],
	};
}

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

	return scalar @{$self->{changes}};
}

sub get ($;$) {
	my $self = shift;
	my $num  = shift;

	return $self->{changes}->[$num]
		if defined $num;

	return @{$self->{changes}};
}

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

	my $ret = '';
	foreach my $change ($self->get) {
		$ret .= Arch::Changes->to_string($change);
		$ret .= "\n";
	}

	return $ret;
}

sub is_changed ($$$;$) {
	my $self = shift;
	my $to = { qw(0 0 1 1 from 0 to 1) }->{shift()};
	die "No 0/1/from/to param" unless defined $to;
	my $filepath = shift || die "No file/dir name";
	my $is_dir = shift;

	my $changed = {};
	foreach my $change (reverse $self->get) {
		my $dst_filepath = $change->{arguments}->[$to - 1];
		my $src_filepath = $change->{arguments}->[0 - $to];

		# support larch "features"
		$dst_filepath =~ s!^\./!!;
		$src_filepath =~ s!^\./!!;

		# flag the file change if matching
		if ($src_filepath eq $filepath
			&& (!defined $is_dir || $change->{is_dir} == $is_dir)
		) {
			$changed->{$change->{type}} =
				$change->{type} ne RENAME? 1: $dst_filepath;
		}

		# handle renames of parent directories (the most close change)
		if ($change->{type} eq RENAME && $change->{is_dir}
			&& $filepath =~ m!^\Q$src_filepath\E(/.+)$!
			&& !exists $changed->{RENAME()}
		) {
			$changed->{$change->{type}} = "$dst_filepath$1";
		}
	}
	$changed = undef unless %$changed;

	return $changed;
}

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

	require Data::Dumper;
	my $dumper = Data::Dumper->new([$self->get]);
	$dumper->Sortkeys(1) if $dumper->can('Sortkeys');
	$dumper->Quotekeys(0);
	$dumper->Indent(1);
	$dumper->Terse(1);

	return $dumper->Dump;
}

my %TYPE_EXT = (
	ADD()         => ' ',
	DELETE()      => ' ',
	MODIFY()      => ' ',
	META_MODIFY() => '-',
	RENAME()      => '>',
);

sub type_string ($$) {
	my $class = shift;
	my $change = shift;

	if ($change->{is_dir}) {
		return $change->{type} eq RENAME
			? '/>'
			: $change->{type} . '/';
	} else {
		return $change->{type} . $TYPE_EXT{$change->{type}};
	}
}

sub to_string ($$) {
	my $class = shift;
	my $change = shift;

	return sprintf("%s %s",
		Arch::Changes->type_string($change),
		join("\t", @{$change->{arguments}}),
	);
}

1;

__END__