Algorithm-Diff
view release on metacpan or search on metacpan
lib/Algorithm/Diff.pm view on Meta::CPAN
package Algorithm::Diff;
# Skip to first "=head" line for documentation.
use strict;
use integer; # see below in _replaceNextLargerWith() for mod to make
# if you don't use this
use vars qw( $VERSION @EXPORT_OK );
$VERSION = 1.19_03;
# ^ ^^ ^^-- Incremented at will
# | \+----- Incremented for non-trivial changes to features
# \-------- Incremented for fundamental changes
require Exporter;
*import = \&Exporter::import;
@EXPORT_OK = qw(
prepare LCS LCSidx LCS_length
diff sdiff compact_diff
traverse_sequences traverse_balanced
);
# McIlroy-Hunt diff algorithm
# Adapted from the Smalltalk code of Mario I. Wolczko, <mario@wolczko.com>
# by Ned Konz, perl@bike-nomad.com
# Updates by Tye McQueen, http://perlmonks.org/?node=tye
# Create a hash that maps each element of $aCollection to the set of
# positions it occupies in $aCollection, restricted to the elements
# within the range of indexes specified by $start and $end.
# The fourth parameter is a subroutine reference that will be called to
# generate a string to use as a key.
# Additional parameters, if any, will be passed to this subroutine.
#
# my $hashRef = _withPositionsOfInInterval( \@array, $start, $end, $keyGen );
sub _withPositionsOfInInterval
{
my $aCollection = shift; # array ref
my $start = shift;
my $end = shift;
my $keyGen = shift;
my %d;
my $index;
for ( $index = $start ; $index <= $end ; $index++ )
{
my $element = $aCollection->[$index];
my $key = &$keyGen( $element, @_ );
if ( exists( $d{$key} ) )
{
unshift ( @{ $d{$key} }, $index );
}
else
{
$d{$key} = [$index];
}
}
return wantarray ? %d : \%d;
}
# Find the place at which aValue would normally be inserted into the
# array. If that place is already occupied by aValue, do nothing, and
# return undef. If the place does not exist (i.e., it is off the end of
# the array), add it to the end, otherwise replace the element at that
# point with aValue. It is assumed that the array's values are numeric.
# This is where the bulk (75%) of the time is spent in this module, so
# try to make it fast!
sub _replaceNextLargerWith
{
my ( $array, $aValue, $high ) = @_;
$high ||= $#$array;
# off the end?
if ( $high == -1 || $aValue > $array->[-1] )
{
push ( @$array, $aValue );
return $high + 1;
lib/Algorithm/Diff.pm view on Meta::CPAN
while ( $ai <= $lastA || $bi <= $lastB )
{
if ( $ai <= $lastA && $bi <= $lastB )
{
# Change
if ( defined $changeCallback )
{
&$changeCallback( $ai++, $bi++, @_ );
}
else
{
&$discardACallback( $ai++, $bi, @_ );
&$discardBCallback( $ai, $bi++, @_ );
}
}
elsif ( $ai <= $lastA )
{
&$discardACallback( $ai++, $bi, @_ );
}
else
{
# $bi <= $lastB
&$discardBCallback( $ai, $bi++, @_ );
}
}
return 1;
}
sub prepare
{
my $a = shift; # array ref
my $keyGen = shift; # code ref
# set up code ref
$keyGen = sub { $_[0] } unless defined($keyGen);
return scalar _withPositionsOfInInterval( $a, 0, $#$a, $keyGen, @_ );
}
sub LCS
{
my $a = shift; # array ref
my $b = shift; # array ref or hash ref
my $matchVector = _longestCommonSubsequence( $a, $b, 0, @_ );
my @retval;
my $i;
for ( $i = 0 ; $i <= $#$matchVector ; $i++ )
{
if ( defined( $matchVector->[$i] ) )
{
push ( @retval, $a->[$i] );
}
}
return wantarray ? @retval : \@retval;
}
sub LCS_length
{
my $a = shift; # array ref
my $b = shift; # array ref or hash ref
return _longestCommonSubsequence( $a, $b, 1, @_ );
}
sub LCSidx
{
my $a= shift @_;
my $b= shift @_;
my $match= _longestCommonSubsequence( $a, $b, 0, @_ );
my @am= grep defined $match->[$_], 0..$#$match;
my @bm= @{$match}[@am];
return \@am, \@bm;
}
sub compact_diff
{
my $a= shift @_;
my $b= shift @_;
my( $am, $bm )= LCSidx( $a, $b, @_ );
my @cdiff;
my( $ai, $bi )= ( 0, 0 );
push @cdiff, $ai, $bi;
while( 1 ) {
while( @$am && $ai == $am->[0] && $bi == $bm->[0] ) {
shift @$am;
shift @$bm;
++$ai, ++$bi;
}
push @cdiff, $ai, $bi;
last if ! @$am;
$ai = $am->[0];
$bi = $bm->[0];
push @cdiff, $ai, $bi;
}
push @cdiff, 0+@$a, 0+@$b
if $ai < @$a || $bi < @$b;
return wantarray ? @cdiff : \@cdiff;
}
sub diff
{
my $a = shift; # array ref
my $b = shift; # array ref
my $retval = [];
my $hunk = [];
my $discard = sub {
push @$hunk, [ '-', $_[0], $a->[ $_[0] ] ];
};
my $add = sub {
push @$hunk, [ '+', $_[1], $b->[ $_[1] ] ];
};
my $match = sub {
push @$retval, $hunk
if 0 < @$hunk;
$hunk = []
};
traverse_sequences( $a, $b,
{ MATCH => $match, DISCARD_A => $discard, DISCARD_B => $add }, @_ );
lib/Algorithm/Diff.pm view on Meta::CPAN
if( !wantarray ) {
return $me->[_Idx][ $off ]
- $me->[_Idx][ $off + _Min ];
}
$base= $me->[_Base] if !defined $base;
return ( $base + $me->[_Idx][ $off + _Min ] )
.. ( $base + $me->[_Idx][ $off ] - 1 );
}
sub Items {
my( $me, $seq )= @_;
$me->_ChkPos();
my $off = $me->_ChkSeq($seq);
if( !wantarray ) {
return $me->[_Idx][ $off ]
- $me->[_Idx][ $off + _Min ];
}
return
@{$me->[$seq]}[
$me->[_Idx][ $off + _Min ]
.. ( $me->[_Idx][ $off ] - 1 )
];
}
sub Same {
my( $me )= @_;
$me->_ChkPos();
return wantarray ? () : 0
if $me->[_Same] != ( 1 & $me->[_Pos] );
return $me->Items(1);
}
my %getName;
BEGIN {
%getName= (
same => \&Same,
diff => \&Diff,
base => \&Base,
min => \&Min,
max => \&Max,
range=> \&Range,
items=> \&Items, # same thing
);
}
sub Get
{
my $me= shift @_;
$me->_ChkPos();
my @value;
for my $arg ( @_ ) {
for my $word ( split ' ', $arg ) {
my $meth;
if( $word !~ /^(-?\d+)?([a-zA-Z]+)([12])?$/
|| not $meth= $getName{ lc $2 }
) {
Die( $Root, ", Get: Invalid request ($word)" );
}
my( $base, $name, $seq )= ( $1, $2, $3 );
push @value, scalar(
4 == length($name)
? $meth->( $me )
: $meth->( $me, $seq, $base )
);
}
}
if( wantarray ) {
return @value;
} elsif( 1 == @value ) {
return $value[0];
}
Die( 0+@value, " values requested from ",
$Root, "'s Get in scalar context" );
}
my $Obj= getObjPkg($Root);
no strict 'refs';
for my $meth ( qw( new getObjPkg ) ) {
*{$Root."::".$meth} = \&{$meth};
*{$Obj ."::".$meth} = \&{$meth};
}
for my $meth ( qw(
Next Prev Reset Copy Base Diff
Same Items Range Min Max Get
_ChkPos _ChkSeq
) ) {
*{$Obj."::".$meth} = \&{$meth};
}
1;
__END__
=head1 NAME
Algorithm::Diff - Compute `intelligent' differences between two files / lists
=head1 SYNOPSIS
require Algorithm::Diff;
# This example produces traditional 'diff' output:
my $diff = Algorithm::Diff->new( \@seq1, \@seq2 );
$diff->Base( 1 ); # Return line numbers, not indices
while( $diff->Next() ) {
next if $diff->Same();
my $sep = '';
if( ! $diff->Items(2) ) {
printf "%d,%dd%d\n",
$diff->Get(qw( Min1 Max1 Max2 ));
} elsif( ! $diff->Items(1) ) {
printf "%da%d,%d\n",
$diff->Get(qw( Max1 Min2 Max2 ));
} else {
$sep = "---\n";
printf "%d,%dc%d,%d\n",
$diff->Get(qw( Min1 Max1 Min2 Max2 ));
}
print "< $_" for $diff->Items(1);
print $sep;
print "> $_" for $diff->Items(2);
}
# Alternate interfaces:
use Algorithm::Diff qw(
LCS LCS_length LCSidx
diff sdiff compact_diff
traverse_sequences traverse_balanced );
@lcs = LCS( \@seq1, \@seq2 );
$lcsref = LCS( \@seq1, \@seq2 );
$count = LCS_length( \@seq1, \@seq2 );
( $seq1idxref, $seq2idxref ) = LCSidx( \@seq1, \@seq2 );
# Complicated interfaces:
@diffs = diff( \@seq1, \@seq2 );
@sdiffs = sdiff( \@seq1, \@seq2 );
@cdiffs = compact_diff( \@seq1, \@seq2 );
traverse_sequences(
\@seq1,
\@seq2,
{ MATCH => \&callback1,
DISCARD_A => \&callback2,
DISCARD_B => \&callback3,
},
\&key_generator,
@extra_args,
);
traverse_balanced(
\@seq1,
\@seq2,
{ MATCH => \&callback1,
DISCARD_A => \&callback2,
DISCARD_B => \&callback3,
CHANGE => \&callback4,
},
\&key_generator,
@extra_args,
);
=head1 INTRODUCTION
(by Mark-Jason Dominus)
I once read an article written by the authors of C<diff>; they said
that they worked very hard on the algorithm until they found the
right one.
I think what they ended up using (and I hope someone will correct me,
because I am not very confident about this) was the `longest common
subsequence' method. In the LCS problem, you have two sequences of
items:
a b c d f g h j q z
a b c d e f g i j k r x y z
and you want to find the longest sequence of items that is present in
both original sequences in the same order. That is, you want to find
a new sequence I<S> which can be obtained from the first sequence by
deleting some items, and from the second sequence by deleting other
items. You also want I<S> to be as long as possible. In this case I<S>
is
a b c d f g j z
From there it's only a small step to get diff-like output:
e h i k q r x y
+ - + + - + + +
This module solves the LCS problem. It also includes a canned function
to generate C<diff>-like output.
It might seem from the example above that the LCS of two sequences is
always pretty obvious, but that's not always the case, especially when
the two sequences have many repeated elements. For example, consider
a x b y c z p d q
a b c a x b y c z
A naive approach might start by matching up the C<a> and C<b> that
appear at the beginning of each sequence, like this:
a x b y c z p d q
a b c a b y c z
This finds the common subsequence C<a b c z>. But actually, the LCS
is C<a x b y c z>:
a x b y c z p d q
a b c a x b y c z
or
a x b y c z p d q
a b c a x b y c z
=head1 USAGE
(See also the README file and several example
scripts include with this module.)
This module now provides an object-oriented interface that uses less
memory and is easier to use than most of the previous procedural
interfaces. It also still provides several exportable functions. We'll
deal with these in ascending order of difficulty: C<LCS>,
C<LCS_length>, C<LCSidx>, OO interface, C<prepare>, C<diff>, C<sdiff>,
C<traverse_sequences>, and C<traverse_balanced>.
=head2 C<LCS>
Given references to two lists of items, LCS returns an array containing
their longest common subsequence. In scalar context, it returns a
reference to such a list.
@lcs = LCS( \@seq1, \@seq2 );
$lcsref = LCS( \@seq1, \@seq2 );
C<LCS> may be passed an optional third parameter; this is a CODE
reference to a key generation function. See L</KEY GENERATION
FUNCTIONS>.
@lcs = LCS( \@seq1, \@seq2, \&keyGen, @args );
$lcsref = LCS( \@seq1, \@seq2, \&keyGen, @args );
Additional parameters, if any, will be passed to the key generation
routine.
=head2 C<LCS_length>
This is just like C<LCS> except it only returns the length of the
longest common subsequence. This provides a performance gain of about
9% compared to C<LCS>.
=head2 C<LCSidx>
Like C<LCS> except it returns references to two arrays. The first array
contains the indices into @seq1 where the LCS items are located. The
second array contains the indices into @seq2 where the LCS items are located.
Therefore, the following three lists will contain the same values:
my( $idx1, $idx2 ) = LCSidx( \@seq1, \@seq2 );
my @list1 = @seq1[ @$idx1 ];
my @list2 = @seq2[ @$idx2 ];
my @list3 = LCS( \@seq1, \@seq2 );
=head2 C<new>
$diff = Algorithm::Diffs->new( \@seq1, \@seq2 );
$diff = Algorithm::Diffs->new( \@seq1, \@seq2, \%opts );
C<new> computes the smallest set of additions and deletions necessary
to turn the first sequence into the second and compactly records them
in the object.
You use the object to iterate over I<hunks>, where each hunk represents
a contiguous section of items which should be added, deleted, replaced,
or left unchanged.
=over 4
The following summary of all of the methods looks a lot like Perl code
but some of the symbols have different meanings:
[ ] Encloses optional arguments
: Is followed by the default value for an optional argument
| Separates alternate return results
Method summary:
$obj = Algorithm::Diff->new( \@seq1, \@seq2, [ \%opts ] );
$pos = $obj->Next( [ $count : 1 ] );
$revPos = $obj->Prev( [ $count : 1 ] );
$obj = $obj->Reset( [ $pos : 0 ] );
$copy = $obj->Copy( [ $pos, [ $newBase ] ] );
$oldBase = $obj->Base( [ $newBase ] );
Note that all of the following methods C<die> if used on an object that
is "reset" (not currently pointing at any hunk).
$bits = $obj->Diff( );
@items|$cnt = $obj->Same( );
@items|$cnt = $obj->Items( $seqNum );
@idxs |$cnt = $obj->Range( $seqNum, [ $base ] );
$minIdx = $obj->Min( $seqNum, [ $base ] );
$maxIdx = $obj->Max( $seqNum, [ $base ] );
@values = $obj->Get( @names );
Passing in C<undef> for an optional argument is always treated the same
as if no argument were passed in.
lib/Algorithm/Diff.pm view on Meta::CPAN
@list = $diff->Items(2);
@list = @seq2[ $diff->Range(2) ];
You can also specify the base to use as the second argument. So the
following two snippets I<always> return the same lists:
@list = $diff->Items(1);
@list = @seq1[ $diff->Range(1,0) ];
=item C<Base>
$curBase = $diff->Base();
$oldBase = $diff->Base($newBase);
C<Base> sets and/or returns the current base (usually 0 or 1) that is
used when you request range information. The base defaults to 0 so
that range information is returned as array indices. You can set the
base to 1 if you want to report traditional line numbers instead.
=item C<Min>
$min1 = $diff->Min(1);
$min = $diff->Min( $seqNum, $base );
C<Min> returns the first value that C<Range> would return (given the
same arguments) or returns C<undef> if C<Range> would return an empty
list.
=item C<Max>
C<Max> returns the last value that C<Range> would return or C<undef>.
=item C<Get>
( $n, $x, $r ) = $diff->Get(qw( min1 max1 range1 ));
@values = $diff->Get(qw( 0min2 1max2 range2 same base ));
C<Get> returns one or more scalar values. You pass in a list of the
names of the values you want returned. Each name must match one of the
following regexes:
/^(-?\d+)?(min|max)[12]$/i
/^(range[12]|same|diff|base)$/i
The 1 or 2 after a name says which sequence you want the information
for (and where allowed, it is required). The optional number before
"min" or "max" is the base to use. So the following equalities hold:
$diff->Get('min1') == $diff->Min(1)
$diff->Get('0min2') == $diff->Min(2,0)
Using C<Get> in a scalar context when you've passed in more than one
name is a fatal error (C<die> is called).
=back
=head2 C<prepare>
Given a reference to a list of items, C<prepare> returns a reference
to a hash which can be used when comparing this sequence to other
sequences with C<LCS> or C<LCS_length>.
$prep = prepare( \@seq1 );
for $i ( 0 .. 10_000 )
{
@lcs = LCS( $prep, $seq[$i] );
# do something useful with @lcs
}
C<prepare> may be passed an optional third parameter; this is a CODE
reference to a key generation function. See L</KEY GENERATION
FUNCTIONS>.
$prep = prepare( \@seq1, \&keyGen );
for $i ( 0 .. 10_000 )
{
@lcs = LCS( $seq[$i], $prep, \&keyGen );
# do something useful with @lcs
}
Using C<prepare> provides a performance gain of about 50% when calling LCS
many times compared with not preparing.
=head2 C<diff>
@diffs = diff( \@seq1, \@seq2 );
$diffs_ref = diff( \@seq1, \@seq2 );
C<diff> computes the smallest set of additions and deletions necessary
to turn the first sequence into the second, and returns a description
of these changes. The description is a list of I<hunks>; each hunk
represents a contiguous section of items which should be added,
deleted, or replaced. (Hunks containing unchanged items are not
included.)
The return value of C<diff> is a list of hunks, or, in scalar context, a
reference to such a list. If there are no differences, the list will be
empty.
Here is an example. Calling C<diff> for the following two sequences:
a b c e h j l m n p
b c d e f j k l m r s t
would produce the following list:
(
[ [ '-', 0, 'a' ] ],
[ [ '+', 2, 'd' ] ],
[ [ '-', 4, 'h' ],
[ '+', 4, 'f' ] ],
[ [ '+', 6, 'k' ] ],
[ [ '-', 8, 'n' ],
[ '-', 9, 'p' ],
[ '+', 9, 'r' ],
[ '+', 10, 's' ],
[ '+', 11, 't' ] ],
( run in 0.365 second using v1.01-cache-2.11-cpan-9bca49b1385 )