File Coverage

blib/lib/VCS/Lite.pm

Criterion	Covered	Total	%
statement	173	195	88.7
branch	69	96	71.8
condition	43	56	76.7
subroutine	22	24	91.6
pod	9	9	100.0
total	316	380	83.1

package VCS::Lite;

use strict;
use warnings;
our $VERSION = '0.11';

#----------------------------------------------------------------------------

=head1 NAME

VCS::Lite - Minimal version control system

=head1 SYNOPSIS

  use VCS::Lite;

  # diff

  my $lit = VCS::Lite->new('/home/me/foo1.txt');
  my $lit2 = VCS::Lite->new('/home/me/foo2.txt');
  my $difftxt = $lit->delta($lit2)->diff;
  print OUTFILE $difftxt;

  # patch

  my $delt = VCS::Lite::Delta->new('/home/me/patch.diff');
  my $lit3 = $lit->patch($delt);
  print OUTFILE $lit3->text;

  # merge

  my $lit4 = $lit->merge($lit->delta($lit2),$lit->delta($lit3));
  print OUTFILE $lit4->text;

=head1 DESCRIPTION

This module provides the functions normally associated with a version
control system, but without needing or implementing a version control
system. Applications include wikis, document management systems and
configuration management.

It makes use of the module Algorithm::Diff. It provides the facility
for basic diffing, patching and merging.

=cut

#----------------------------------------------------------------------------

#############################################################################
#Library Modules															#
#############################################################################

use Carp;
use Algorithm::Diff qw(traverse_sequences);
use VCS::Lite::Delta;

#----------------------------------------------------------------------------

#############################################################################
#Interface Methods   														#
#############################################################################

sub new {
	my ($class,$id,$sep,$src,@args) = @_;

	my %proto = ();

# Decode $sep as needed

	if (ref($sep) eq 'HASH') {
	    %proto = %$sep;
	    $sep = $proto{in};
        delete $proto{in};
	}

# DWIM logic, based on $src parameter.

# Case 0: $src missing. Use $id as file name, becomes case 3
	open $src,$id or croak("failed to open '$id': $!") unless $src;

	my $atyp = ref $src;
    $sep ||= $/;
	local $/ = $sep if $sep;
    $proto{out} ||= $\ || '';
	my $out_sep = $proto{out};
	my @contents;

# Case 1: $src is string
	if (!$atyp) {
	    @contents = split /(?=$sep)/,$src;
	}
# Case 2: $src is arrayref
	elsif ($atyp eq 'ARRAY') {
	    @contents = @$src;
	}
# Case 3: $src is globref (file handle)
	elsif ($atyp eq 'GLOB') {
	    @contents = <$src>;
	}
# Case 4: $src is coderef - callback
	elsif ($atyp eq 'CODE') {
	    while (my $item=&$src(@args)) {
		push @contents,$item;
	    }
	}
# Case otherwise is an error.
	else {
	    croak "Invalid argument";
	}

	$proto{last_line_short} = 1
		if @contents && ($contents[-1] !~ /$sep$/);

	if ($proto{chomp}) {
		s/$sep$//s for @contents;
        $proto{out} ||= $sep;
	}

	bless { id => $id,
		contents => \@contents,
		separator => $sep,
		%proto },$class;
}

sub original {
	my $self = shift;

	my $pkg = ref $self;

	exists($self->{original}) ?
		bless ({ id => $self->id,
			contents => $self->{original},
			separator => $self->{separator},
            out => $self->{out},
            chomp => $self->{chomp},
            }, $pkg ) :
		$self;
}

sub apply {
	my ($self,$other,%par) = @_;

	my $pkg = ref $self;
	my $base = $par{base};
	$base ||= 'contents';
	$base = $pkg->new( $self->id,
			$self->{separator},
			$self->{$base})
		unless ref $base;
	my $cbase = exists($other->{original}) ? $other->original : $base;
	my $mrg = $cbase->merge($base,$other);
	my $mrg2 = $base->merge($self,$mrg);
	$self->{original} ||= $self->{contents};
	$self->{contents} = [$mrg2->text];
}

sub text {
	my ($self,$sep) = @_;

	$sep ||= $self->{out} || '';

	wantarray ? @{$self->{contents}} : join $sep,@{$self->{contents}};
}

sub id {
	my $self = shift;

	@_ ? ($self->{id} = shift) : $self->{id};
}

sub delta {
	my $lite1 = shift;
	my $lite2 = shift;
	my %par = @_;

	my @wl1 = $lite1->_window($par{window});
	my @wl2 = $lite2->_window($par{window});
	my @d = map { [map { [$_->[0] . ($_->[2]{short} ? '/' : ''),
        $_->[1], $_->[2]{line} ] } @$_ ] }
	Algorithm::Diff::diff(\@wl1,\@wl2,sub { $_[0]{window}; })
		or return undef;

	VCS::Lite::Delta->new(\@d,$lite1->id,$lite2->id,$lite1->{out});
}

sub _window {
	my $self = shift;

	my $win = shift || 0;
	my ($win_from,$win_to) = ref($win) ? (-$win->[0],$win->[1]) :
						(-$win,$win);
	my @wintxt;
	my $max = $#{$self->{contents}};
	for (0..$max) {
	    my $win_lb = $_ + $win_from;
	    $win_lb = 0 if $win_lb < 0;
	    my $win_ub = $_ + $win_to;
	    $win_ub = $max if $win_ub > $max;
	    push @wintxt, join $self->{out},
	    	(@{$self->{contents}}[$win_lb .. $win_ub],
		(($win_ub < $max) || !$self->{last_line_short}) ?
		'' : ());
	}

	map { {line => $self->{contents}[$_],
        window => $wintxt[$_],
        ( $self->{last_line_short} && ($_ == $max)) ? ( short => 1 ) : (),
        } }
		(0..$max);
}

sub diff {
	my $self = shift;

	$self->delta(@_)->diff;
}

sub patch {
	my $self = shift;
	my $patch = shift;
	$patch = VCS::Lite::Delta->new($patch,@_)
		unless ref $patch eq 'VCS::Lite::Delta';
	my @out = @{$self->{contents}};
	my $id = $self->id;
	my $pkg = ref $self;
	my @pat = $patch->hunks;

	for (@pat) {
		for (@$_) {
			my ($ind,$lin,$txt) = @$_;
			next unless $ind =~ /^-/;
			_error($lin,'Patch failed'),return undef
				if $out[$lin] ne $txt;
		}
	}

	my $line_offset = 0;
    my $lls = 0;

	for (@pat) {
		my @txt1 = grep {$_->[0] =~ /^\-/} @$_;
		my @txt2 = grep {$_->[0] =~ /^\+/} @$_;
		my $base_line = @txt2 ? $txt2[0][1] : $txt1[0][1] + $line_offset;
		splice @out,$base_line,scalar(@txt1),map {$_->[2]} @txt2;
		$line_offset += @txt2 - @txt1;
        $lls += grep {$_->[0] eq '+/'} @txt2;
	}

	$pkg->new($id,{
        in => $self->{separator},
        chomp => $self->{chomp},
        out => $self->{out},
        last_line_short => $lls,
        },\@out);
}

# Equality of two array references (contents)

sub _equal {
	my ($a,$b) = @_;

	return 0 if @$a != @$b;

	foreach (0..$#$a) {
		return 0 if $a->[$_] ne $b->[$_];
	}

	1;
}

sub merge {
	my ($self,$d1,$d2) = @_;
	my $pkg = ref $self;

	my $orig = [$self->text];
	my $chg1 = [$d1->text];
	my $chg2 = [$d2->text];
	my $out_title = $d1->{id} . '|' . $d2->{id};
	my %ins1;
	my $del1 = '';

	traverse_sequences( $self->{contents}, $chg1, {
		MATCH => sub { $del1 .= ' ' },
		DISCARD_A => sub { $del1 .= '-' },
		DISCARD_B => sub { push @{$ins1{$_[0]}},$chg1->[$_[1]] },
			} );

	my %ins2;
	my $del2 = '';

	traverse_sequences( $self->{contents}, $chg2, {
		MATCH => sub { $del2 .= ' ' },
		DISCARD_A => sub { $del2 .= '-' },
		DISCARD_B => sub { push @{$ins2{$_[0]}},$chg2->[$_[1]] },
			} );

# First pass conflict detection: deletion on file 1 and insertion on file 2

	$del1 =~ s(\-+){
		my $stlin = length $`;
		my $numdel = length $&;

		my @confl = map {exists $ins2{$_} ? ($_) : ()}
			($stlin+1..$stlin+$numdel-1);
		@confl ? '*' x $numdel : $&;
	}eg;

# Now the other way round: deletion on file 2 and insertion on file 1

	$del2 =~ s(\-+){
		my $stlin = length $`;
		my $numdel = length $&;

		my @confl = map {exists $ins1{$_} ? ($_) : ()}
			($stlin+1..$stlin+$numdel-1);
		@confl ? '*' x $numdel : $&;
	}eg;

# Conflict type 1 is insert of 2 into deleted 1, Conflict type 2 is insert of 1 into deleted 2
# @defer is used to hold the 'other half' alternative for the conflict

	my $conflict = 0;
	my $conflict_type = 0;
	my @defer;

	my @out;

	for (0..@{$self->{contents}}) {

# Get details pertaining to current @f0 input line
		my $line = $self->{contents}[$_];
		my $d1 = substr $del1,$_,1;
		my $ins1 = $ins1{$_} if exists $ins1{$_};
		my $d2 = substr $del2,$_,1;
		my $ins2 = $ins2{$_} if exists $ins2{$_};

# Insert/insert conflict. This is not a conflict if both inserts are identical.

		if ($ins1 && $ins2 && !&_equal($ins1,$ins2)) {
			push @out, ('*'x20)."Start of conflict ".(++$conflict).
			"  Insert to Primary, Insert to Secondary ".('*'x60)."\n";

			push @out, @$ins1, ('*'x100)."\n", @$ins2;
			push @out, ('*'x20)."End of conflict ".$conflict.('*'x80)."\n";
		} elsif (!$conflict_type) {	#Insert/Delete conflict

# Normal insertion - may be from $ins1 or $ins2. Apply the inser and junk both $ins1 and $ins2

			$ins1 ||= $ins2;

			push @out, @$ins1 if defined $ins1;

			undef $ins1;
			undef $ins2;
		}

# Detect start of conflict 1 and 2

		if (!$conflict_type && $d1 eq '*') {
			push @out, ('*'x20)."Start of conflict ".(++$conflict).
			"  Delete from Primary, Insert to Secondary ".('*'x60)."\n";

			$conflict_type = 1;
		}

		if (!$conflict_type && $d2 eq '*') {
			push @out, ('*'x20)."Start of conflict ".(++$conflict).
			"  Delete from Secondary, Insert to Primary ".('*'x60)."\n";

			$conflict_type = 2;
		}

# Handle case where we are in an Insert/Delete conflict block already

		if ($conflict_type == 1) {
			if ($d1 eq '*') {

# Deletion block continues...
				push @defer,(@$ins2) if $ins2;
				push @defer,$line if !$d2;
			} else {

# handle end of block, dump out @defer and clear it

				push @out, ('*'x100)."\n",@defer;
				undef @defer;
				push @out, ('*'x20)."End of conflict ".$conflict.('*'x80)."\n";
				$conflict_type = 0;
			}
		}

		if ($conflict_type == 2) {
			if ($d2 eq '*') {

# Deletion block continues...
				push @defer,(@$ins1) if $ins1;
				push @defer,$line if !$d1;
			} else {

# handle end of block, dump out @defer and clear it

				push @out, ('*'x100),"\n", @defer;
				undef @defer;
				push @out, ('*'x20)."End of conflict ".$conflict.('*'x80)."\n";
				$conflict_type = 0;
			}
		}
		last unless defined $line;	# for end of file, don't want to push undef
		push @out, $line unless ($d1 eq '-' || $d2 eq '-') && !$conflict_type;
	}
	$pkg->new($out_title, undef, \@out);
}

sub _error {};

1;

__END__