Algorithm-Diff-1.1902/0040755000567200017500000000000010463315710014167 5ustar monkperlusersAlgorithm-Diff-1.1902/diffnew.pl0100644000567200017500000004122310124555570016151 0ustar monkperlusers#!/usr/bin/perl # # `Diff' program in Perl # Copyright 1998 M-J. Dominus. (mjd-perl-diff@plover.com) # # This program is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # # Altered to output in `context diff' format (but without context) # September 1998 Christian Murphy (cpm@muc.de) # # Context lines feature added # Unified, "Old" (Standard UNIX), Ed diff added September 1998 # Reverse_Ed (-f option) added March 1999 # Amir D. Karger (karger@bead.aecom.yu.edu) # # Modular functions integrated into program # February 1999 M-J. Dominus (mjd-perl-diff@plover.com) # # In this file, "item" usually means "line of text", and "item number" usually # means "line number". But theoretically the code could be used more generally use strict; use Algorithm::Diff qw(diff); # GLOBAL VARIABLES #### # After we've read up to a certain point in each file, the number of items # we've read from each file will differ by $FLD (could be 0) my $File_Length_Difference = 0; #ed diff outputs hunks *backwards*, so we need to save hunks when doing ed diff my @Ed_Hunks = (); ######################## my $usage = << "ENDUSAGE"; Usage: $0 [{-c | -C lines -e | -f | -u | -U lines}] oldfile newfile -c do a context diff with 3 lines of context -C do a context diff with 'lines' lines of context (implies -c) -e create a script for the ed editor to change oldfile to newfile -f like -e but in reverse order -u do a unified diff with 3 lines of context -U do a unified diff with 'lines' lines of context (implies -u) -q report only whether or not the files differ By default it will do an "old-style" diff, with output like UNIX diff ENDUSAGE my $Context_Lines = 0; # lines of context to print. 0 for old-style diff my $Diff_Type = "OLD"; # by default, do standard UNIX diff my ($opt_c, $opt_u, $opt_e, $opt_f, $opt_q); while ($ARGV[0] =~ /^-/) { my $opt = shift; last if $opt eq '--'; if ($opt =~ /^-C(.*)/) { $Context_Lines = $1 || shift; $opt_c = 1; $Diff_Type = "CONTEXT"; } elsif ($opt =~ /^-c$/) { $Context_Lines = 3; $opt_c = 1; $Diff_Type = "CONTEXT"; } elsif ($opt =~ /^-e$/) { $opt_e = 1; $Diff_Type = "ED"; } elsif ($opt =~ /^-f$/) { $opt_f = 1; $Diff_Type = "REVERSE_ED"; } elsif ($opt =~ /^-U(.*)$/) { $Context_Lines = $1 || shift; $opt_u = 1; $Diff_Type = "UNIFIED"; } elsif ($opt =~ /^-u$/) { $Context_Lines = 3; $opt_u = 1; $Diff_Type = "UNIFIED"; } elsif ($opt =~ /^-q$/) { $Context_Lines = 0; $opt_q = 1; $opt_e = 1; $Diff_Type = "ED"; } else { $opt =~ s/^-//; bag("Illegal option -- $opt"); } } if ($opt_q and grep($_,($opt_c, $opt_f, $opt_u)) > 1) { bag("Combining -q with other options is nonsensical"); } if (grep($_,($opt_c, $opt_e, $opt_f, $opt_u)) > 1) { bag("Only one of -c, -u, -f, -e are allowed"); } bag($usage) unless @ARGV == 2; ######## DO THE DIFF! my ($file1, $file2) = @ARGV; my ($char1, $char2); # string to print before file names if ($Diff_Type eq "CONTEXT") { $char1 = '*' x 3; $char2 = '-' x 3; } elsif ($Diff_Type eq "UNIFIED") { $char1 = '-' x 3; $char2 = '+' x 3; } open (F1, $file1) or bag("Couldn't open $file1: $!"); open (F2, $file2) or bag("Couldn't open $file2: $!"); my (@f1, @f2); chomp(@f1 = ); close F1; chomp(@f2 = ); close F2; # diff yields lots of pieces, each of which is basically a Block object my $diffs = diff(\@f1, \@f2); exit 0 unless @$diffs; if ($opt_q and @$diffs) { print "Files $file1 and $file2 differ\n"; exit 1; } if ($Diff_Type =~ /UNIFIED|CONTEXT/) { my @st = stat($file1); my $MTIME = 9; print "$char1 $file1\t", scalar localtime($st[$MTIME]), "\n"; @st = stat($file2); print "$char2 $file2\t", scalar localtime($st[$MTIME]), "\n"; } my ($hunk,$oldhunk); # Loop over hunks. If a hunk overlaps with the last hunk, join them. # Otherwise, print out the old one. foreach my $piece (@$diffs) { $hunk = new Hunk ($piece, $Context_Lines); next unless $oldhunk; # first time through # Don't need to check for overlap if blocks have no context lines if ($Context_Lines && $hunk->does_overlap($oldhunk)) { $hunk->prepend_hunk($oldhunk); } else { $oldhunk->output_diff(\@f1, \@f2, $Diff_Type); } } continue { $oldhunk = $hunk; } # print the last hunk $oldhunk->output_diff(\@f1, \@f2, $Diff_Type); # Print hunks backwards if we're doing an ed diff map {$_->output_ed_diff(\@f1, \@f2, $Diff_Type)} @Ed_Hunks if @Ed_Hunks; exit 1; # END MAIN PROGRAM sub bag { my $msg = shift; $msg .= "\n"; warn $msg; exit 2; } ######## # Package Hunk. A Hunk is a group of Blocks which overlap because of the # context surrounding each block. (So if we're not using context, every # hunk will contain one block.) { package Hunk; sub new { # Arg1 is output from &LCS::diff (which corresponds to one Block) # Arg2 is the number of items (lines, e.g.,) of context around each block # # This subroutine changes $File_Length_Difference # # Fields in a Hunk: # blocks - a list of Block objects # start - index in file 1 where first block of the hunk starts # end - index in file 1 where last block of the hunk ends # # Variables: # before_diff - how much longer file 2 is than file 1 due to all hunks # until but NOT including this one # after_diff - difference due to all hunks including this one my ($class, $piece, $context_items) = @_; my $block = new Block ($piece); # this modifies $FLD! my $before_diff = $File_Length_Difference; # BEFORE this hunk my $after_diff = $before_diff + $block->{"length_diff"}; $File_Length_Difference += $block->{"length_diff"}; # @remove_array and @insert_array hold the items to insert and remove # Save the start & beginning of each array. If the array doesn't exist # though (e.g., we're only adding items in this block), then figure # out the line number based on the line number of the other file and # the current difference in file lenghts my @remove_array = $block->remove; my @insert_array = $block->insert; my ($a1, $a2, $b1, $b2, $start1, $start2, $end1, $end2); $a1 = @remove_array ? $remove_array[0 ]->{"item_no"} : -1; $a2 = @remove_array ? $remove_array[-1]->{"item_no"} : -1; $b1 = @insert_array ? $insert_array[0 ]->{"item_no"} : -1; $b2 = @insert_array ? $insert_array[-1]->{"item_no"} : -1; $start1 = $a1 == -1 ? $b1 - $before_diff : $a1; $end1 = $a2 == -1 ? $b2 - $after_diff : $a2; $start2 = $b1 == -1 ? $a1 + $before_diff : $b1; $end2 = $b2 == -1 ? $a2 + $after_diff : $b2; # At first, a hunk will have just one Block in it my $hunk = { "start1" => $start1, "start2" => $start2, "end1" => $end1, "end2" => $end2, "blocks" => [$block], }; bless $hunk, $class; $hunk->flag_context($context_items); return $hunk; } # Change the "start" and "end" fields to note that context should be added # to this hunk sub flag_context { my ($hunk, $context_items) = @_; return unless $context_items; # no context # add context before my $start1 = $hunk->{"start1"}; my $num_added = $context_items > $start1 ? $start1 : $context_items; $hunk->{"start1"} -= $num_added; $hunk->{"start2"} -= $num_added; # context after my $end1 = $hunk->{"end1"}; $num_added = ($end1+$context_items > $#f1) ? $#f1 - $end1 : $context_items; $hunk->{"end1"} += $num_added; $hunk->{"end2"} += $num_added; } # Is there an overlap between hunk arg0 and old hunk arg1? # Note: if end of old hunk is one less than beginning of second, they overlap sub does_overlap { my ($hunk, $oldhunk) = @_; return "" unless $oldhunk; # first time through, $oldhunk is empty # Do I actually need to test both? return ($hunk->{"start1"} - $oldhunk->{"end1"} <= 1 || $hunk->{"start2"} - $oldhunk->{"end2"} <= 1); } # Prepend hunk arg1 to hunk arg0 # Note that arg1 isn't updated! Only arg0 is. sub prepend_hunk { my ($hunk, $oldhunk) = @_; $hunk->{"start1"} = $oldhunk->{"start1"}; $hunk->{"start2"} = $oldhunk->{"start2"}; unshift (@{$hunk->{"blocks"}}, @{$oldhunk->{"blocks"}}); } # DIFF OUTPUT ROUTINES. THESE ROUTINES CONTAIN DIFF FORMATTING INFO... sub output_diff { # First arg is the current hunk of course # Next args are refs to the files # last arg is type of diff my $diff_type = $_[-1]; my %funchash = ("OLD" => \&output_old_diff, "CONTEXT" => \&output_context_diff, "ED" => \&store_ed_diff, "REVERSE_ED" => \&output_ed_diff, "UNIFIED" => \&output_unified_diff, ); if (exists $funchash{$diff_type}) { &{$funchash{$diff_type}}(@_); # pass in all args } else {die "unknown diff type $diff_type"} } sub output_old_diff { # Note that an old diff can't have any context. Therefore, we know that # there's only one block in the hunk. my ($hunk, $fileref1, $fileref2) = @_; my %op_hash = ('+' => 'a', '-' => 'd', '!' => 'c'); my @blocklist = @{$hunk->{"blocks"}}; warn ("Expecting one block in an old diff hunk!") if scalar @blocklist != 1; my $block = $blocklist[0]; my $op = $block->op; # +, -, or ! # Calculate item number range. # old diff range is just like a context diff range, except the ranges # are on one line with the action between them. my $range1 = $hunk->context_range(1); my $range2 = $hunk->context_range(2); my $action = $op_hash{$op} || warn "unknown op $op"; print "$range1$action$range2\n"; # If removing anything, just print out all the remove lines in the hunk # which is just all the remove lines in the block if ($block->remove) { my @outlist = @$fileref1[$hunk->{"start1"}..$hunk->{"end1"}]; map {$_ = "< $_\n"} @outlist; # all lines will be '< text\n' print @outlist; } print "---\n" if $op eq '!'; # only if inserting and removing if ($block->insert) { my @outlist = @$fileref2[$hunk->{"start2"}..$hunk->{"end2"}]; map {$_ = "> $_\n"} @outlist; # all lines will be '> text\n' print @outlist; } } sub output_unified_diff { my ($hunk, $fileref1, $fileref2) = @_; my @blocklist; # Calculate item number range. my $range1 = $hunk->unified_range(1); my $range2 = $hunk->unified_range(2); print "@@ -$range1 +$range2 @@\n"; # Outlist starts containing the hunk of file 1. # Removing an item just means putting a '-' in front of it. # Inserting an item requires getting it from file2 and splicing it in. # We splice in $num_added items. Remove blocks use $num_added because # splicing changed the length of outlist. # We remove $num_removed items. Insert blocks use $num_removed because # their item numbers---corresponding to positions in file *2*--- don't take # removed items into account. my $low = $hunk->{"start1"}; my $hi = $hunk->{"end1"}; my ($num_added, $num_removed) = (0,0); my @outlist = @$fileref1[$low..$hi]; map {s/^/ /} @outlist; # assume it's just context foreach my $block (@{$hunk->{"blocks"}}) { foreach my $item ($block->remove) { my $op = $item->{"sign"}; # - my $offset = $item->{"item_no"} - $low + $num_added; $outlist[$offset] =~ s/^ /$op/; $num_removed++; } foreach my $item ($block->insert) { my $op = $item->{"sign"}; # + my $i = $item->{"item_no"}; my $offset = $i - $hunk->{"start2"} + $num_removed; splice(@outlist,$offset,0,"$op$$fileref2[$i]"); $num_added++; } } map {s/$/\n/} @outlist; # add \n's print @outlist; } sub output_context_diff { my ($hunk, $fileref1, $fileref2) = @_; my @blocklist; print "***************\n"; # Calculate item number range. my $range1 = $hunk->context_range(1); my $range2 = $hunk->context_range(2); # Print out file 1 part for each block in context diff format if there are # any blocks that remove items print "*** $range1 ****\n"; my $low = $hunk->{"start1"}; my $hi = $hunk->{"end1"}; if (@blocklist = grep {$_->remove} @{$hunk->{"blocks"}}) { my @outlist = @$fileref1[$low..$hi]; map {s/^/ /} @outlist; # assume it's just context foreach my $block (@blocklist) { my $op = $block->op; # - or ! foreach my $item ($block->remove) { $outlist[$item->{"item_no"} - $low] =~ s/^ /$op/; } } map {s/$/\n/} @outlist; # add \n's print @outlist; } print "--- $range2 ----\n"; $low = $hunk->{"start2"}; $hi = $hunk->{"end2"}; if (@blocklist = grep {$_->insert} @{$hunk->{"blocks"}}) { my @outlist = @$fileref2[$low..$hi]; map {s/^/ /} @outlist; # assume it's just context foreach my $block (@blocklist) { my $op = $block->op; # + or ! foreach my $item ($block->insert) { $outlist[$item->{"item_no"} - $low] =~ s/^ /$op/; } } map {s/$/\n/} @outlist; # add \n's print @outlist; } } sub store_ed_diff { # ed diff prints out diffs *backwards*. So save them while we're generating # them, then print them out at the end my $hunk = shift; unshift @Ed_Hunks, $hunk; } sub output_ed_diff { # This sub is used for ed ('diff -e') OR reverse_ed ('diff -f'). # last arg is type of diff my $diff_type = $_[-1]; my ($hunk, $fileref1, $fileref2) = @_; my %op_hash = ('+' => 'a', '-' => 'd', '!' => 'c'); # Can't be any context for this kind of diff, so each hunk has one block my @blocklist = @{$hunk->{"blocks"}}; warn ("Expecting one block in an ed diff hunk!") if scalar @blocklist != 1; my $block = $blocklist[0]; my $op = $block->op; # +, -, or ! # Calculate item number range. # old diff range is just like a context diff range, except the ranges # are on one line with the action between them. my $range1 = $hunk->context_range(1); $range1 =~ s/,/ / if $diff_type eq "REVERSE_ED"; my $action = $op_hash{$op} || warn "unknown op $op"; print ($diff_type eq "ED" ? "$range1$action\n" : "$action$range1\n"); if ($block->insert) { my @outlist = @$fileref2[$hunk->{"start2"}..$hunk->{"end2"}]; map {s/$/\n/} @outlist; # add \n's print @outlist; print ".\n"; # end of ed 'c' or 'a' command } } sub context_range { # Generate a range of item numbers to print. Only print 1 number if the range # has only one item in it. Otherwise, it's 'start,end' # Flag is the number of the file (1 or 2) my ($hunk, $flag) = @_; my ($start, $end) = ($hunk->{"start$flag"},$hunk->{"end$flag"}); $start++; $end++; # index from 1, not zero my $range = ($start < $end) ? "$start,$end" : $end; return $range; } sub unified_range { # Generate a range of item numbers to print for unified diff # Print number where block starts, followed by number of lines in the block # (don't print number of lines if it's 1) my ($hunk, $flag) = @_; my ($start, $end) = ($hunk->{"start$flag"},$hunk->{"end$flag"}); $start++; $end++; # index from 1, not zero my $length = $end - $start + 1; my $first = $length < 2 ? $end : $start; # strange, but correct... my $range = $length== 1 ? $first : "$first,$length"; return $range; } } # end Package Hunk ######## # Package Block. A block is an operation removing, adding, or changing # a group of items. Basically, this is just a list of changes, where each # change adds or deletes a single item. # (Change could be a separate class, but it didn't seem worth it) { package Block; sub new { # Input is a chunk from &Algorithm::LCS::diff # Fields in a block: # length_diff - how much longer file 2 is than file 1 due to this block # Each change has: # sign - '+' for insert, '-' for remove # item_no - number of the item in the file (e.g., line number) # We don't bother storing the text of the item # my ($class,$chunk) = @_; my @changes = (); # This just turns each change into a hash. foreach my $item (@$chunk) { my ($sign, $item_no, $text) = @$item; my $hashref = {"sign" => $sign, "item_no" => $item_no}; push @changes, $hashref; } my $block = { "changes" => \@changes }; bless $block, $class; $block->{"length_diff"} = $block->insert - $block->remove; return $block; } # LOW LEVEL FUNCTIONS sub op { # what kind of block is this? my $block = shift; my $insert = $block->insert; my $remove = $block->remove; $remove && $insert and return '!'; $remove and return '-'; $insert and return '+'; warn "unknown block type"; return '^'; # context block } # Returns a list of the changes in this block that remove items # (or the number of removals if called in scalar context) sub remove { return grep {$_->{"sign"} eq '-'} @{shift->{"changes"}}; } # Returns a list of the changes in this block that insert items sub insert { return grep {$_->{"sign"} eq '+'} @{shift->{"changes"}}; } } # end of package Block Algorithm-Diff-1.1902/t/0040755000567200017500000000000010463315710014432 5ustar monkperlusersAlgorithm-Diff-1.1902/t/oo.t0100644000567200017500000001364210124555602015237 0ustar monkperlusers# Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl oo.t' use strict; BEGIN { $^W++; } use lib qw( blib lib ); use Algorithm::Diff qw( compact_diff ); use Data::Dumper; use Test qw( plan ok $ntest ); BEGIN { $|++; plan( tests => 969 ); $SIG{__DIE__} = sub # breakpoint on die { $DB::single = 1 if ! $^S; die @_; }; $SIG{__WARN__} = sub # breakpoint on warn { $DB::single = 1; warn @_; }; } sub Ok($$) { @_= reverse @_; goto &ok } my( $first, $a, $b, $hunks ); for my $pair ( [ "a b c e h j l m n p", " b c d e f j k l m r s t", 9 ], [ "", "", 0 ], [ "a b c", "", 1 ], [ "", "a b c d", 1 ], [ "a b", "x y z", 1 ], [ " c e h j l m n p r", "a b c d f g j k l m s t", 7 ], [ "a b c d", "a b c d", 1 ], [ "a d", "a b c d", 3 ], [ "a b c d", "a d", 3 ], [ "a b c d", " b c ", 3 ], [ " b c ", "a b c d", 3 ], ) { $first= $ntest; ( $a, $b, $hunks )= @$pair; my @a = split ' ', $a; my @b = split ' ', $b; my $d = Algorithm::Diff->new( \@a, \@b ); if( @ARGV ) { print "1: $a$/2: $b$/"; while( $d->Next() ) { printf "%10s %s %s$/", join(' ',$d->Items(1)), $d->Same() ? '=' : '|', join(' ',$d->Items(2)); } } Ok( 0, $d->Base() ); Ok( 0, $d->Base(undef) ); Ok( 0, $d->Base(1) ); Ok( 1, $d->Base(undef) ); Ok( 1, $d->Base(0) ); ok( ! eval { $d->Diff(); 1 } ); ok( $@, qr/\breset\b/i ); ok( ! eval { $d->Same(); 1 } ); ok( $@, qr/\breset\b/i ); ok( ! eval { $d->Items(1); 1 } ); ok( $@, qr/\breset\b/i ); ok( ! eval { $d->Range(2); 1 } ); ok( $@, qr/\breset\b/i ); ok( ! eval { $d->Min(1); 1 } ); ok( $@, qr/\breset\b/i ); ok( ! eval { $d->Max(2); 1 } ); ok( $@, qr/\breset\b/i ); ok( ! eval { $d->Get('Min1'); 1 } ); ok( $@, qr/\breset\b/i ); ok( ! $d->Next(0) ); ok( ! eval { $d->Same(); 1 } ); ok( $@, qr/\breset\b/i ); Ok( 1, $d->Next() ) if 0 < $hunks; Ok( 2, $d->Next(undef) ) if 1 < $hunks; Ok( 3, $d->Next(1) ) if 2 < $hunks; Ok( 2, $d->Next(-1) ) if 1 < $hunks; ok( ! $d->Next(-2) ); ok( ! eval { $d->Same(); 1 } ); ok( $@, qr/\breset\b/i ); ok( ! $d->Prev(0) ); ok( ! eval { $d->Same(); 1 } ); ok( $@, qr/\breset\b/i ); Ok( -1, $d->Prev() ) if 0 < $hunks; Ok( -2, $d->Prev(undef) ) if 1 < $hunks; Ok( -3, $d->Prev(1) ) if 2 < $hunks; Ok( -2, $d->Prev(-1) ) if 1 < $hunks; ok( ! $d->Prev(-2) ); Ok( 1, $d->Next() ) if 0 < $hunks; ok( ! $d->Prev() ); Ok( 1, $d->Next() ) if 0 < $hunks; ok( ! $d->Prev(2) ); Ok( -1, $d->Prev() ) if 0 < $hunks; ok( ! $d->Next() ); Ok( -1, $d->Prev() ) if 0 < $hunks; ok( ! $d->Next(5) ); Ok( 1, $d->Next() ) if 0 < $hunks; Ok( $d, $d->Reset() ); ok( ! $d->Prev(0) ); Ok( 3, $d->Reset(3)->Next(0) ) if 2 < $hunks; Ok( -3, $d->Reset(-2)->Prev() ) if 2 < $hunks; Ok( $hunks || !1, $d->Reset(0)->Next(-1) ); my $c = $d->Copy(); ok( $c->Base(), $d->Base() ); ok( $c->Next(0), $d->Next(0) ); ok( $d->Copy(-4)->Next(0), $d->Copy()->Reset(-4)->Next(0) ); $c = $d->Copy( undef, 1 ); Ok( 1, $c->Base() ); ok( $c->Next(0), $d->Next(0) ); $d->Reset(); my( @A, @B ); while( $d->Next() ) { if( $d->Same() ) { Ok( 0, $d->Diff() ); ok( $d->Same(), $d->Range(2) ); ok( $d->Items(2), $d->Range(1) ); ok( "@{[$d->Same()]}", "@{[$d->Items(1)]}" ); ok( "@{[$d->Items(1)]}", "@{[$d->Items(2)]}" ); ok( "@{[$d->Items(2)]}", "@a[$d->Range(1)]" ); ok( "@a[$d->Range(1,0)]", "@b[$d->Range(2)]" ); push @A, $d->Same(); push @B, @b[$d->Range(2)]; } else { Ok( 0, $d->Same() ); ok( $d->Diff() & 1, 1*!!$d->Range(1) ); ok( $d->Diff() & 2, 2*!!$d->Range(2) ); ok( "@{[$d->Items(1)]}", "@a[$d->Range(1)]" ); ok( "@{[$d->Items(2)]}", "@b[$d->Range(2,0)]" ); push @A, @a[$d->Range(1)]; push @B, $d->Items(2); } } ok( "@A", "@a" ); ok( "@B", "@b" ); next if ! $hunks; Ok( 1, $d->Next() ); { local $^W= 0; ok( ! eval { $d->Items(); 1 } ); } ok( ! eval { $d->Items(0); 1 } ); { local $^W= 0; ok( ! eval { $d->Range(); 1 } ); } ok( ! eval { $d->Range(3); 1 } ); { local $^W= 0; ok( ! eval { $d->Min(); 1 } ); } ok( ! eval { $d->Min(-1); 1 } ); { local $^W= 0; ok( ! eval { $d->Max(); 1 } ); } ok( ! eval { $d->Max(9); 1 } ); $d->Reset(-1); $c= $d->Copy(undef,1); ok( "@a[$d->Range(1)]", "@{[(0,@a)[$c->Range(1)]]}" ); ok( "@b[$c->Range(2,0)]", "@{[(0,@b)[$d->Range(2,1)]]}" ); ok( "@a[$d->Get('min1')..$d->Get('0Max1')]", "@{[(0,@a)[$d->Get('1MIN1')..$c->Get('MAX1')]]}" ); ok( "@{[$c->Min(1),$c->Max(2,0)]}", "@{[$c->Get('Min1','0Max2')]}" ); ok( ! eval { scalar $c->Get('Min1','0Max2'); 1 } ); ok( "@{[0+$d->Same(),$d->Diff(),$d->Base()]}", "@{[$d->Get(qq)]}" ); ok( "@{[0+$d->Range(1),0+$d->Range(2)]}", "@{[$d->Get(qq)]}" ); { local $^W= 0; ok( ! eval { $c->Get('range'); 1 } ); ok( ! eval { $c->Get('min'); 1 } ); ok( ! eval { $c->Get('max'); 1 } ); } } continue { if( @ARGV ) { my $tests= $ntest - $first; print "$hunks hunks, $tests tests.$/"; } } # $d = Algorithm::Diff->new( \@a, \@b, {KeyGen=>sub...} ); # @cdiffs = compact_diff( \@seq1, \@seq2 ); Algorithm-Diff-1.1902/t/base.t0100644000567200017500000002632410124555602015535 0ustar monkperlusers# Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl base.t' use strict; $^W++; use lib qw(blib lib); use Algorithm::Diff qw(diff LCS traverse_sequences traverse_balanced sdiff); use Data::Dumper; use Test; BEGIN { $|++; plan tests => 35; $SIG{__DIE__} = sub # breakpoint on die { $DB::single = 1; $DB::single = 1; # avoid complaint die @_; } } my @a = qw(a b c e h j l m n p); my @b = qw(b c d e f j k l m r s t); my @correctResult = qw(b c e j l m); my $correctResult = join(' ', @correctResult); my $skippedA = 'a h n p'; my $skippedB = 'd f k r s t'; # From the Algorithm::Diff manpage: my $correctDiffResult = [ [ [ '-', 0, 'a' ] ], [ [ '+', 2, 'd' ] ], [ [ '-', 4, 'h' ], [ '+', 4, 'f' ] ], [ [ '+', 6, 'k' ] ], [ [ '-', 8, 'n' ], [ '+', 9, 'r' ], [ '-', 9, 'p' ], [ '+', 10, 's' ], [ '+', 11, 't' ], ] ]; # Result of LCS must be as long as @a my @result = Algorithm::Diff::_longestCommonSubsequence( \@a, \@b ); ok( scalar(grep { defined } @result), scalar(@correctResult), "length of _longestCommonSubsequence" ); # result has b[] line#s keyed by a[] line# # print "result =", join(" ", map { defined($_) ? $_ : 'undef' } @result), "\n"; my @aresult = map { defined( $result[$_] ) ? $a[$_] : () } 0 .. $#result; my @bresult = map { defined( $result[$_] ) ? $b[ $result[$_] ] : () } 0 .. $#result; ok( "@aresult", $correctResult, "A results" ); ok( "@bresult", $correctResult, "B results" ); my ( @matchedA, @matchedB, @discardsA, @discardsB, $finishedA, $finishedB ); sub match { my ( $a, $b ) = @_; push ( @matchedA, $a[$a] ); push ( @matchedB, $b[$b] ); } sub discard_b { my ( $a, $b ) = @_; push ( @discardsB, $b[$b] ); } sub discard_a { my ( $a, $b ) = @_; push ( @discardsA, $a[$a] ); } sub finished_a { my ( $a, $b ) = @_; $finishedA = $a; } sub finished_b { my ( $a, $b ) = @_; $finishedB = $b; } traverse_sequences( \@a, \@b, { MATCH => \&match, DISCARD_A => \&discard_a, DISCARD_B => \&discard_b } ); ok( "@matchedA", $correctResult); ok( "@matchedB", $correctResult); ok( "@discardsA", $skippedA); ok( "@discardsB", $skippedB); @matchedA = @matchedB = @discardsA = @discardsB = (); $finishedA = $finishedB = undef; traverse_sequences( \@a, \@b, { MATCH => \&match, DISCARD_A => \&discard_a, DISCARD_B => \&discard_b, A_FINISHED => \&finished_a, B_FINISHED => \&finished_b, } ); ok( "@matchedA", $correctResult); ok( "@matchedB", $correctResult); ok( "@discardsA", $skippedA); ok( "@discardsB", $skippedB); ok( $finishedA, 9, "index of finishedA" ); ok( $finishedB, undef, "index of finishedB" ); my @lcs = LCS( \@a, \@b ); ok( "@lcs", $correctResult ); # Compare the diff output with the one from the Algorithm::Diff manpage. my $diff = diff( \@a, \@b ); $Data::Dumper::Indent = 0; my $cds = Dumper($correctDiffResult); my $dds = Dumper($diff); ok( $dds, $cds ); ################################################## # m@perlmeister.com 03/23/2002: # Tests for sdiff-interface ################################################# @a = qw(abc def yyy xxx ghi jkl); @b = qw(abc dxf xxx ghi jkl); $correctDiffResult = [ ['u', 'abc', 'abc'], ['c', 'def', 'dxf'], ['-', 'yyy', ''], ['u', 'xxx', 'xxx'], ['u', 'ghi', 'ghi'], ['u', 'jkl', 'jkl'] ]; @result = sdiff(\@a, \@b); ok(Dumper(\@result), Dumper($correctDiffResult)); ################################################# @a = qw(a b c e h j l m n p); @b = qw(b c d e f j k l m r s t); $correctDiffResult = [ ['-', 'a', '' ], ['u', 'b', 'b'], ['u', 'c', 'c'], ['+', '', 'd'], ['u', 'e', 'e'], ['c', 'h', 'f'], ['u', 'j', 'j'], ['+', '', 'k'], ['u', 'l', 'l'], ['u', 'm', 'm'], ['c', 'n', 'r'], ['c', 'p', 's'], ['+', '', 't'], ]; @result = sdiff(\@a, \@b); ok(Dumper(\@result), Dumper($correctDiffResult)); ################################################# @a = qw(a b c d e); @b = qw(a e); $correctDiffResult = [ ['u', 'a', 'a' ], ['-', 'b', ''], ['-', 'c', ''], ['-', 'd', ''], ['u', 'e', 'e'], ]; @result = sdiff(\@a, \@b); ok(Dumper(\@result), Dumper($correctDiffResult)); ################################################# @a = qw(a e); @b = qw(a b c d e); $correctDiffResult = [ ['u', 'a', 'a' ], ['+', '', 'b'], ['+', '', 'c'], ['+', '', 'd'], ['u', 'e', 'e'], ]; @result = sdiff(\@a, \@b); ok(Dumper(\@result), Dumper($correctDiffResult)); ################################################# @a = qw(v x a e); @b = qw(w y a b c d e); $correctDiffResult = [ ['c', 'v', 'w' ], ['c', 'x', 'y' ], ['u', 'a', 'a' ], ['+', '', 'b'], ['+', '', 'c'], ['+', '', 'd'], ['u', 'e', 'e'], ]; @result = sdiff(\@a, \@b); ok(Dumper(\@result), Dumper($correctDiffResult)); ################################################# @a = qw(x a e); @b = qw(a b c d e); $correctDiffResult = [ ['-', 'x', '' ], ['u', 'a', 'a' ], ['+', '', 'b'], ['+', '', 'c'], ['+', '', 'd'], ['u', 'e', 'e'], ]; @result = sdiff(\@a, \@b); ok(Dumper(\@result), Dumper($correctDiffResult)); ################################################# @a = qw(a e); @b = qw(x a b c d e); $correctDiffResult = [ ['+', '', 'x' ], ['u', 'a', 'a' ], ['+', '', 'b'], ['+', '', 'c'], ['+', '', 'd'], ['u', 'e', 'e'], ]; @result = sdiff(\@a, \@b); ok(Dumper(\@result), Dumper($correctDiffResult)); ################################################# @a = qw(a e v); @b = qw(x a b c d e w x); $correctDiffResult = [ ['+', '', 'x' ], ['u', 'a', 'a' ], ['+', '', 'b'], ['+', '', 'c'], ['+', '', 'd'], ['u', 'e', 'e'], ['c', 'v', 'w'], ['+', '', 'x'], ]; @result = sdiff(\@a, \@b); ok(Dumper(\@result), Dumper($correctDiffResult)); ################################################# @a = qw(); @b = qw(a b c); $correctDiffResult = [ ['+', '', 'a' ], ['+', '', 'b' ], ['+', '', 'c' ], ]; @result = sdiff(\@a, \@b); ok(Dumper(\@result), Dumper($correctDiffResult)); ################################################# @a = qw(a b c); @b = qw(); $correctDiffResult = [ ['-', 'a', '' ], ['-', 'b', '' ], ['-', 'c', '' ], ]; @result = sdiff(\@a, \@b); ok(Dumper(\@result), Dumper($correctDiffResult)); ################################################# @a = qw(a b c); @b = qw(1); $correctDiffResult = [ ['c', 'a', '1' ], ['-', 'b', '' ], ['-', 'c', '' ], ]; @result = sdiff(\@a, \@b); ok(Dumper(\@result), Dumper($correctDiffResult)); ################################################# @a = qw(a b c); @b = qw(c); $correctDiffResult = [ ['-', 'a', '' ], ['-', 'b', '' ], ['u', 'c', 'c' ], ]; @result = sdiff(\@a, \@b); ok(Dumper(\@result), Dumper($correctDiffResult)); ################################################# @a = qw(a b c); @b = qw(a x c); my $r = ""; traverse_balanced( \@a, \@b, { MATCH => sub { $r .= "M @_";}, DISCARD_A => sub { $r .= "DA @_";}, DISCARD_B => sub { $r .= "DB @_";}, CHANGE => sub { $r .= "C @_";}, } ); ok($r, "M 0 0C 1 1M 2 2"); ################################################# # No CHANGE callback => use discard_a/b instead @a = qw(a b c); @b = qw(a x c); $r = ""; traverse_balanced( \@a, \@b, { MATCH => sub { $r .= "M @_";}, DISCARD_A => sub { $r .= "DA @_";}, DISCARD_B => sub { $r .= "DB @_";}, } ); ok($r, "M 0 0DA 1 1DB 2 1M 2 2"); ################################################# @a = qw(a x y c); @b = qw(a v w c); $r = ""; traverse_balanced( \@a, \@b, { MATCH => sub { $r .= "M @_";}, DISCARD_A => sub { $r .= "DA @_";}, DISCARD_B => sub { $r .= "DB @_";}, CHANGE => sub { $r .= "C @_";}, } ); ok($r, "M 0 0C 1 1C 2 2M 3 3"); ################################################# @a = qw(x y c); @b = qw(v w c); $r = ""; traverse_balanced( \@a, \@b, { MATCH => sub { $r .= "M @_";}, DISCARD_A => sub { $r .= "DA @_";}, DISCARD_B => sub { $r .= "DB @_";}, CHANGE => sub { $r .= "C @_";}, } ); ok($r, "C 0 0C 1 1M 2 2"); ################################################# @a = qw(a x y z); @b = qw(b v w); $r = ""; traverse_balanced( \@a, \@b, { MATCH => sub { $r .= "M @_";}, DISCARD_A => sub { $r .= "DA @_";}, DISCARD_B => sub { $r .= "DB @_";}, CHANGE => sub { $r .= "C @_";}, } ); ok($r, "C 0 0C 1 1C 2 2DA 3 3"); ################################################# @a = qw(a z); @b = qw(a); $r = ""; traverse_balanced( \@a, \@b, { MATCH => sub { $r .= "M @_";}, DISCARD_A => sub { $r .= "DA @_";}, DISCARD_B => sub { $r .= "DB @_";}, CHANGE => sub { $r .= "C @_";}, } ); ok($r, "M 0 0DA 1 1"); ################################################# @a = qw(z a); @b = qw(a); $r = ""; traverse_balanced( \@a, \@b, { MATCH => sub { $r .= "M @_";}, DISCARD_A => sub { $r .= "DA @_";}, DISCARD_B => sub { $r .= "DB @_";}, CHANGE => sub { $r .= "C @_";}, } ); ok($r, "DA 0 0M 1 0"); ################################################# @a = qw(a b c); @b = qw(x y z); $r = ""; traverse_balanced( \@a, \@b, { MATCH => sub { $r .= "M @_";}, DISCARD_A => sub { $r .= "DA @_";}, DISCARD_B => sub { $r .= "DB @_";}, CHANGE => sub { $r .= "C @_";}, } ); ok($r, "C 0 0C 1 1C 2 2"); Algorithm-Diff-1.1902/htmldiff.pl0100644000567200017500000000347510124555572016335 0ustar monkperlusers#!/usr/bin/perl -w # diffs two files and writes an HTML output file. use strict; use CGI qw(:standard :html3); use Algorithm::Diff 'traverse_sequences'; use Text::Tabs; my ( @a, @b ); # Take care of whitespace. sub preprocess { my $arrayRef = shift; chomp(@$arrayRef); @$arrayRef = expand(@$arrayRef); } # This will be called with both lines are the same sub match { my ( $ia, $ib ) = @_; print pre( $a[$ia] ), "\n"; } # This will be called when there is a line in A that isn't in B sub only_a { my ( $ia, $ib ) = @_; print pre( { -class => 'onlyA' }, $a[$ia] ), "\n"; } # This will be called when there is a line in B that isn't in A sub only_b { my ( $ia, $ib ) = @_; print pre( { -class => 'onlyB' }, $b[$ib] ), "\n"; } # MAIN PROGRAM # Check for two arguments. print "usage: $0 file1 file2 > diff.html\n" if @ARGV != 2; $tabstop = 4; # For Text::Tabs # Read each file into an array. open FH, $ARGV[0]; @a = ; close FH; open FH, $ARGV[1]; @b = ; close FH; # Expand whitespace preprocess( \@a ); preprocess( \@b ); # inline style my $style = < "$ARGV[0] vs. $ARGV[1]", -style => { -code => $style } } ), h1( { -style => 'margin-left: 24pt' }, span( { -style => 'color: red' }, $ARGV[0] ), span(" vs. "), span( { -style => 'color: blue' }, $ARGV[1] ) ), "\n"; # And compare the arrays traverse_sequences( \@a, # first sequence \@b, # second sequence { MATCH => \&match, # callback on identical lines DISCARD_A => \&only_a, # callback on A-only DISCARD_B => \&only_b, # callback on B-only } ); print end_html(); Algorithm-Diff-1.1902/lib/0040755000567200017500000000000010463315710014735 5ustar monkperlusersAlgorithm-Diff-1.1902/lib/Algorithm/0040755000567200017500000000000010463315710016663 5ustar monkperlusersAlgorithm-Diff-1.1902/lib/Algorithm/Diff.pm0100644000567200017500000014362310463315530020077 0ustar monkperluserspackage 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_02; # ^ ^^ ^^-- 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, # 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; } # binary search for insertion point... my $low = 0; my $index; my $found; while ( $low <= $high ) { $index = ( $high + $low ) / 2; # $index = int(( $high + $low ) / 2); # without 'use integer' $found = $array->[$index]; if ( $aValue == $found ) { return undef; } elsif ( $aValue > $found ) { $low = $index + 1; } else { $high = $index - 1; } } # now insertion point is in $low. $array->[$low] = $aValue; # overwrite next larger return $low; } # This method computes the longest common subsequence in $a and $b. # Result is array or ref, whose contents is such that # $a->[ $i ] == $b->[ $result[ $i ] ] # foreach $i in ( 0 .. $#result ) if $result[ $i ] is defined. # An additional argument may be passed; this is a hash or key generating # function that should return a string that uniquely identifies the given # element. It should be the case that if the key is the same, the elements # will compare the same. If this parameter is undef or missing, the key # will be the element as a string. # By default, comparisons will use "eq" and elements will be turned into keys # using the default stringizing operator '""'. # Additional parameters, if any, will be passed to the key generation # routine. sub _longestCommonSubsequence { my $a = shift; # array ref or hash ref my $b = shift; # array ref or hash ref my $counting = shift; # scalar my $keyGen = shift; # code ref my $compare; # code ref if ( ref($a) eq 'HASH' ) { # prepared hash must be in $b my $tmp = $b; $b = $a; $a = $tmp; } # Check for bogus (non-ref) argument values if ( !ref($a) || !ref($b) ) { my @callerInfo = caller(1); die 'error: must pass array or hash references to ' . $callerInfo[3]; } # set up code refs # Note that these are optimized. if ( !defined($keyGen) ) # optimize for strings { $keyGen = sub { $_[0] }; $compare = sub { my ( $a, $b ) = @_; $a eq $b }; } else { $compare = sub { my $a = shift; my $b = shift; &$keyGen( $a, @_ ) eq &$keyGen( $b, @_ ); }; } my ( $aStart, $aFinish, $matchVector ) = ( 0, $#$a, [] ); my ( $prunedCount, $bMatches ) = ( 0, {} ); if ( ref($b) eq 'HASH' ) # was $bMatches prepared for us? { $bMatches = $b; } else { my ( $bStart, $bFinish ) = ( 0, $#$b ); # First we prune off any common elements at the beginning while ( $aStart <= $aFinish and $bStart <= $bFinish and &$compare( $a->[$aStart], $b->[$bStart], @_ ) ) { $matchVector->[ $aStart++ ] = $bStart++; $prunedCount++; } # now the end while ( $aStart <= $aFinish and $bStart <= $bFinish and &$compare( $a->[$aFinish], $b->[$bFinish], @_ ) ) { $matchVector->[ $aFinish-- ] = $bFinish--; $prunedCount++; } # Now compute the equivalence classes of positions of elements $bMatches = _withPositionsOfInInterval( $b, $bStart, $bFinish, $keyGen, @_ ); } my $thresh = []; my $links = []; my ( $i, $ai, $j, $k ); for ( $i = $aStart ; $i <= $aFinish ; $i++ ) { $ai = &$keyGen( $a->[$i], @_ ); if ( exists( $bMatches->{$ai} ) ) { $k = 0; for $j ( @{ $bMatches->{$ai} } ) { # optimization: most of the time this will be true if ( $k and $thresh->[$k] > $j and $thresh->[ $k - 1 ] < $j ) { $thresh->[$k] = $j; } else { $k = _replaceNextLargerWith( $thresh, $j, $k ); } # oddly, it's faster to always test this (CPU cache?). if ( defined($k) ) { $links->[$k] = [ ( $k ? $links->[ $k - 1 ] : undef ), $i, $j ]; } } } } if (@$thresh) { return $prunedCount + @$thresh if $counting; for ( my $link = $links->[$#$thresh] ; $link ; $link = $link->[0] ) { $matchVector->[ $link->[1] ] = $link->[2]; } } elsif ($counting) { return $prunedCount; } return wantarray ? @$matchVector : $matchVector; } sub traverse_sequences { my $a = shift; # array ref my $b = shift; # array ref my $callbacks = shift || {}; my $keyGen = shift; my $matchCallback = $callbacks->{'MATCH'} || sub { }; my $discardACallback = $callbacks->{'DISCARD_A'} || sub { }; my $finishedACallback = $callbacks->{'A_FINISHED'}; my $discardBCallback = $callbacks->{'DISCARD_B'} || sub { }; my $finishedBCallback = $callbacks->{'B_FINISHED'}; my $matchVector = _longestCommonSubsequence( $a, $b, 0, $keyGen, @_ ); # Process all the lines in @$matchVector my $lastA = $#$a; my $lastB = $#$b; my $bi = 0; my $ai; for ( $ai = 0 ; $ai <= $#$matchVector ; $ai++ ) { my $bLine = $matchVector->[$ai]; if ( defined($bLine) ) # matched { &$discardBCallback( $ai, $bi++, @_ ) while $bi < $bLine; &$matchCallback( $ai, $bi++, @_ ); } else { &$discardACallback( $ai, $bi, @_ ); } } # The last entry (if any) processed was a match. # $ai and $bi point just past the last matching lines in their sequences. while ( $ai <= $lastA or $bi <= $lastB ) { # last A? if ( $ai == $lastA + 1 and $bi <= $lastB ) { if ( defined($finishedACallback) ) { &$finishedACallback( $lastA, @_ ); $finishedACallback = undef; } else { &$discardBCallback( $ai, $bi++, @_ ) while $bi <= $lastB; } } # last B? if ( $bi == $lastB + 1 and $ai <= $lastA ) { if ( defined($finishedBCallback) ) { &$finishedBCallback( $lastB, @_ ); $finishedBCallback = undef; } else { &$discardACallback( $ai++, $bi, @_ ) while $ai <= $lastA; } } &$discardACallback( $ai++, $bi, @_ ) if $ai <= $lastA; &$discardBCallback( $ai, $bi++, @_ ) if $bi <= $lastB; } return 1; } sub traverse_balanced { my $a = shift; # array ref my $b = shift; # array ref my $callbacks = shift || {}; my $keyGen = shift; my $matchCallback = $callbacks->{'MATCH'} || sub { }; my $discardACallback = $callbacks->{'DISCARD_A'} || sub { }; my $discardBCallback = $callbacks->{'DISCARD_B'} || sub { }; my $changeCallback = $callbacks->{'CHANGE'}; my $matchVector = _longestCommonSubsequence( $a, $b, 0, $keyGen, @_ ); # Process all the lines in match vector my $lastA = $#$a; my $lastB = $#$b; my $bi = 0; my $ai = 0; my $ma = -1; my $mb; while (1) { # Find next match indices $ma and $mb do { $ma++; } while( $ma <= $#$matchVector && !defined $matchVector->[$ma] ); last if $ma > $#$matchVector; # end of matchVector? $mb = $matchVector->[$ma]; # Proceed with discard a/b or change events until # next match while ( $ai < $ma || $bi < $mb ) { if ( $ai < $ma && $bi < $mb ) { # Change if ( defined $changeCallback ) { &$changeCallback( $ai++, $bi++, @_ ); } else { &$discardACallback( $ai++, $bi, @_ ); &$discardBCallback( $ai, $bi++, @_ ); } } elsif ( $ai < $ma ) { &$discardACallback( $ai++, $bi, @_ ); } else { # $bi < $mb &$discardBCallback( $ai, $bi++, @_ ); } } # Match &$matchCallback( $ai++, $bi++, @_ ); } 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 }, @_ ); &$match(); return wantarray ? @$retval : $retval; } sub sdiff { my $a = shift; # array ref my $b = shift; # array ref my $retval = []; my $discard = sub { push ( @$retval, [ '-', $a->[ $_[0] ], "" ] ) }; my $add = sub { push ( @$retval, [ '+', "", $b->[ $_[1] ] ] ) }; my $change = sub { push ( @$retval, [ 'c', $a->[ $_[0] ], $b->[ $_[1] ] ] ); }; my $match = sub { push ( @$retval, [ 'u', $a->[ $_[0] ], $b->[ $_[1] ] ] ); }; traverse_balanced( $a, $b, { MATCH => $match, DISCARD_A => $discard, DISCARD_B => $add, CHANGE => $change, }, @_ ); return wantarray ? @$retval : $retval; } ######################################## my $Root= __PACKAGE__; package Algorithm::Diff::_impl; use strict; sub _Idx() { 0 } # $me->[_Idx]: Ref to array of hunk indices # 1 # $me->[1]: Ref to first sequence # 2 # $me->[2]: Ref to second sequence sub _End() { 3 } # $me->[_End]: Diff between forward and reverse pos sub _Same() { 4 } # $me->[_Same]: 1 if pos 1 contains unchanged items sub _Base() { 5 } # $me->[_Base]: Added to range's min and max sub _Pos() { 6 } # $me->[_Pos]: Which hunk is currently selected sub _Off() { 7 } # $me->[_Off]: Offset into _Idx for current position sub _Min() { -2 } # Added to _Off to get min instead of max+1 sub Die { require Carp; Carp::confess( @_ ); } sub _ChkPos { my( $me )= @_; return if $me->[_Pos]; my $meth= ( caller(1) )[3]; Die( "Called $meth on 'reset' object" ); } sub _ChkSeq { my( $me, $seq )= @_; return $seq + $me->[_Off] if 1 == $seq || 2 == $seq; my $meth= ( caller(1) )[3]; Die( "$meth: Invalid sequence number ($seq); must be 1 or 2" ); } sub getObjPkg { my( $us )= @_; return ref $us if ref $us; return $us . "::_obj"; } sub new { my( $us, $seq1, $seq2, $opts ) = @_; my @args; for( $opts->{keyGen} ) { push @args, $_ if $_; } for( $opts->{keyGenArgs} ) { push @args, @$_ if $_; } my $cdif= Algorithm::Diff::compact_diff( $seq1, $seq2, @args ); my $same= 1; if( 0 == $cdif->[2] && 0 == $cdif->[3] ) { $same= 0; splice @$cdif, 0, 2; } my @obj= ( $cdif, $seq1, $seq2 ); $obj[_End] = (1+@$cdif)/2; $obj[_Same] = $same; $obj[_Base] = 0; my $me = bless \@obj, $us->getObjPkg(); $me->Reset( 0 ); return $me; } sub Reset { my( $me, $pos )= @_; $pos= int( $pos || 0 ); $pos += $me->[_End] if $pos < 0; $pos= 0 if $pos < 0 || $me->[_End] <= $pos; $me->[_Pos]= $pos || !1; $me->[_Off]= 2*$pos - 1; return $me; } sub Base { my( $me, $base )= @_; my $oldBase= $me->[_Base]; $me->[_Base]= 0+$base if defined $base; return $oldBase; } sub Copy { my( $me, $pos, $base )= @_; my @obj= @$me; my $you= bless \@obj, ref($me); $you->Reset( $pos ) if defined $pos; $you->Base( $base ); return $you; } sub Next { my( $me, $steps )= @_; $steps= 1 if ! defined $steps; if( $steps ) { my $pos= $me->[_Pos]; my $new= $pos + $steps; $new= 0 if $pos && $new < 0; $me->Reset( $new ) } return $me->[_Pos]; } sub Prev { my( $me, $steps )= @_; $steps= 1 if ! defined $steps; my $pos= $me->Next(-$steps); $pos -= $me->[_End] if $pos; return $pos; } sub Diff { my( $me )= @_; $me->_ChkPos(); return 0 if $me->[_Same] == ( 1 & $me->[_Pos] ); my $ret= 0; my $off= $me->[_Off]; for my $seq ( 1, 2 ) { $ret |= $seq if $me->[_Idx][ $off + $seq + _Min ] < $me->[_Idx][ $off + $seq ]; } return $ret; } sub Min { my( $me, $seq, $base )= @_; $me->_ChkPos(); my $off= $me->_ChkSeq($seq); $base= $me->[_Base] if !defined $base; return $base + $me->[_Idx][ $off + _Min ]; } sub Max { my( $me, $seq, $base )= @_; $me->_ChkPos(); my $off= $me->_ChkSeq($seq); $base= $me->[_Base] if !defined $base; return $base + $me->[_Idx][ $off ] -1; } sub Range { my( $me, $seq, $base )= @_; $me->_ChkPos(); my $off = $me->_ChkSeq($seq); 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; 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 which can be obtained from the first sequence by deleting some items, and from the secend sequence by deleting other items. You also want I to be as long as possible. In this case I 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-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 and C 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. But actually, the LCS is C: 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, C, C, OO interface, C, C, C, C, and C. =head2 C 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 may be passed an optional third parameter; this is a CODE reference to a key generation function. See L. @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 This is just like C except it only returns the length of the longest common subsequence. This provides a performance gain of about 9% compared to C. =head2 C Like C 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 $diff = Algorithm::Diffs->new( \@seq1, \@seq2 ); $diff = Algorithm::Diffs->new( \@seq1, \@seq2, \%opts ); C 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, 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 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 for an optional argument is always treated the same as if no argument were passed in. =item C $pos = $diff->Next(); # Move forward 1 hunk $pos = $diff->Next( 2 ); # Move forward 2 hunks $pos = $diff->Next(-5); # Move backward 5 hunks C moves the object to point at the next hunk. The object starts out "reset", which means it isn't pointing at any hunk. If the object is reset, then C moves to the first hunk. C returns a true value iff the move didn't go past the last hunk. So C will return true iff the object is not reset. Actually, C returns the object's new position, which is a number between 1 and the number of hunks (inclusive), or returns a false value. =item C C is almost identical to C; it moves to the $Nth previous hunk. On a 'reset' object, C [and C] move to the last hunk. The position returned by C is relative to the I of the hunks; -1 for the last hunk, -2 for the second-to-last, etc. =item C $diff->Reset(); # Reset the object's position $diff->Reset($pos); # Move to the specified hunk $diff->Reset(1); # Move to the first hunk $diff->Reset(-1); # Move to the last hunk C returns the object, so, for example, you could use C<< $diff->Reset()->Next(-1) >> to get the number of hunks. =item C $copy = $diff->Copy( $newPos, $newBase ); C returns a copy of the object. The copy and the orignal object share most of their data, so making copies takes very little memory. The copy maintains its own position (separate from the original), which is the main purpose of copies. It also maintains its own base. By default, the copy's position starts out the same as the original object's position. But C takes an optional first argument to set the new position, so the following three snippets are equivalent: $copy = $diff->Copy($pos); $copy = $diff->Copy(); $copy->Reset($pos); $copy = $diff->Copy()->Reset($pos); C takes an optional second argument to set the base for the copy. If you wish to change the base of the copy but leave the position the same as in the original, here are two equivalent ways: $copy = $diff->Copy(); $copy->Base( 0 ); $copy = $diff->Copy(undef,0); Here are two equivalent way to get a "reset" copy: $copy = $diff->Copy(0); $copy = $diff->Copy()->Reset(); =item C $bits = $obj->Diff(); C returns a true value iff the current hunk contains items that are different between the two sequences. It actually returns one of the follow 4 values: =over 4 =item 3 C<3==(1|2)>. This hunk contains items from @seq1 and the items from @seq2 that should replace them. Both sequence 1 and 2 contain changed items so both the 1 and 2 bits are set. =item 2 This hunk only contains items from @seq2 that should be inserted (not items from @seq1). Only sequence 2 contains changed items so only the 2 bit is set. =item 1 This hunk only contains items from @seq1 that should be deleted (not items from @seq2). Only sequence 1 contains changed items so only the 1 bit is set. =item 0 This means that the items in this hunk are the same in both sequences. Neither sequence 1 nor 2 contain changed items so neither the 1 nor the 2 bits are set. =back =item C C returns a true value iff the current hunk contains items that are the same in both sequences. It actually returns the list of items if they are the same or an emty list if they aren't. In a scalar context, it returns the size of the list. =item C $count = $diff->Items(2); @items = $diff->Items($seqNum); C returns the (number of) items from the specified sequence that are part of the current hunk. If the current hunk contains only insertions, then C<< $diff->Items(1) >> will return an empty list (0 in a scalar conext). If the current hunk contains only deletions, then C<< $diff->Items(2) >> will return an empty list (0 in a scalar conext). If the hunk contains replacements, then both C<< $diff->Items(1) >> and C<< $diff->Items(2) >> will return different, non-empty lists. Otherwise, the hunk contains identical items and all of the following will return the same lists: @items = $diff->Items(1); @items = $diff->Items(2); @items = $diff->Same(); =item C $count = $diff->Range( $seqNum ); @indices = $diff->Range( $seqNum ); @indices = $diff->Range( $seqNum, $base ); C is like C except that it returns a list of I to the items rather than the items themselves. By default, the index of the first item (in each sequence) is 0 but this can be changed by calling the C method. So, by default, the following two snippets return the same lists: @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 return the same lists: @list = $diff->Items(1); @list = @seq1[ $diff->Range(1,0) ]; =item C $curBase = $diff->Base(); $oldBase = $diff->Base($newBase); C 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 $min1 = $diff->Min(1); $min = $diff->Min( $seqNum, $base ); C returns the first value that C would return (given the same arguments) or returns C if C would return an empty list. =item C C returns the last value that C would return or C. =item C ( $n, $x, $r ) = $diff->Get(qw( min1 max1 range1 )); @values = $diff->Get(qw( 0min2 1max2 range2 same base )); C 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 in a scalar context when you've passed in more than one name is a fatal error (C is called). =back =head2 C Given a reference to a list of items, C returns a reference to a hash which can be used when comparing this sequence to other sequences with C or C. $prep = prepare( \@seq1 ); for $i ( 0 .. 10_000 ) { @lcs = LCS( $prep, $seq[$i] ); # do something useful with @lcs } C may be passed an optional third parameter; this is a CODE reference to a key generation function. See L. $prep = prepare( \@seq1, \&keyGen ); for $i ( 0 .. 10_000 ) { @lcs = LCS( $seq[$i], $prep, \&keyGen ); # do something useful with @lcs } Using C provides a performance gain of about 50% when calling LCS many times compared with not preparing. =head2 C @diffs = diff( \@seq1, \@seq2 ); $diffs_ref = diff( \@seq1, \@seq2 ); C 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; 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 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 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' ] ], ) There are five hunks here. The first hunk says that the C at position 0 of the first sequence should be deleted (C<->). The second hunk says that the C at position 2 of the second sequence should be inserted (C<+>). The third hunk says that the C at position 4 of the first sequence should be removed and replaced with the C from position 4 of the second sequence. And so on. C may be passed an optional third parameter; this is a CODE reference to a key generation function. See L. Additional parameters, if any, will be passed to the key generation routine. =head2 C @sdiffs = sdiff( \@seq1, \@seq2 ); $sdiffs_ref = sdiff( \@seq1, \@seq2 ); C computes all necessary components to show two sequences and their minimized differences side by side, just like the Unix-utility I does: same same before | after old < - - > new It returns a list of array refs, each pointing to an array of display instructions. In scalar context it returns a reference to such a list. If there are no differences, the list will have one entry per item, each indicating that the item was unchanged. Display instructions consist of three elements: A modifier indicator (C<+>: Element added, C<->: Element removed, C: Element unmodified, C: Element changed) and the value of the old and new elements, to be displayed side-by-side. An C of 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 results in ( [ '-', 'a', '' ], [ 'u', 'b', 'b' ], [ 'u', 'c', 'c' ], [ '+', '', 'd' ], [ 'u', 'e', 'e' ], [ 'c', 'h', 'f' ], [ 'u', 'j', 'j' ], [ '+', '', 'k' ], [ 'u', 'l', 'l' ], [ 'u', 'm', 'm' ], [ 'c', 'n', 'r' ], [ 'c', 'p', 's' ], [ '+', '', 't' ], ) C may be passed an optional third parameter; this is a CODE reference to a key generation function. See L. Additional parameters, if any, will be passed to the key generation routine. =head2 C C is much like C except it returns a much more compact description consisting of just one flat list of indices. An example helps explain the format: my @a = qw( a b c e h j l m n p ); my @b = qw( b c d e f j k l m r s t ); @cdiff = compact_diff( \@a, \@b ); # Returns: # @a @b @a @b # start start values values ( 0, 0, # = 0, 0, # a ! 1, 0, # b c = b c 3, 2, # ! d 3, 3, # e = e 4, 4, # f ! h 5, 5, # j = j 6, 6, # ! k 6, 7, # l m = l m 8, 9, # n p ! r s t 10, 12, # ); The 0th, 2nd, 4th, etc. entries are all indices into @seq1 (@a in the above example) indicating where a hunk begins. The 1st, 3rd, 5th, etc. entries are all indices into @seq2 (@b in the above example) indicating where the same hunk begins. So each pair of indices (except the last pair) describes where a hunk begins (in each sequence). Since each hunk must end at the item just before the item that starts the next hunk, the next pair of indices can be used to determine where the hunk ends. So, the first 4 entries (0..3) describe the first hunk. Entries 0 and 1 describe where the first hunk begins (and so are always both 0). Entries 2 and 3 describe where the next hunk begins, so subtracting 1 from each tells us where the first hunk ends. That is, the first hunk contains items C<$diff[0]> through C<$diff[2] - 1> of the first sequence and contains items C<$diff[1]> through C<$diff[3] - 1> of the second sequence. In other words, the first hunk consists of the following two lists of items: # 1st pair 2nd pair # of indices of indices @list1 = @a[ $cdiff[0] .. $cdiff[2]-1 ]; @list2 = @b[ $cdiff[1] .. $cdiff[3]-1 ]; # Hunk start Hunk end Note that the hunks will always alternate between those that are part of the LCS (those that contain unchanged items) and those that contain changes. This means that all we need to be told is whether the first hunk is a 'same' or 'diff' hunk and we can determine which of the other hunks contain 'same' items or 'diff' items. By convention, we always make the first hunk contain unchanged items. So the 1st, 3rd, 5th, etc. hunks (all odd-numbered hunks if you start counting from 1) all contain unchanged items. And the 2nd, 4th, 6th, etc. hunks (all even-numbered hunks if you start counting from 1) all contain changed items. Since @a and @b don't begin with the same value, the first hunk in our example is empty (otherwise we'd violate the above convention). Note that the first 4 index values in our example are all zero. Plug these values into our previous code block and we get: @hunk1a = @a[ 0 .. 0-1 ]; @hunk1b = @b[ 0 .. 0-1 ]; And C<0..-1> returns the empty list. Move down one pair of indices (2..5) and we get the offset ranges for the second hunk, which contains changed items. Since C<@diff[2..5]> contains (0,0,1,0) in our example, the second hunk consists of these two lists of items: @hunk2a = @a[ $cdiff[2] .. $cdiff[4]-1 ]; @hunk2b = @b[ $cdiff[3] .. $cdiff[5]-1 ]; # or @hunk2a = @a[ 0 .. 1-1 ]; @hunk2b = @b[ 0 .. 0-1 ]; # or @hunk2a = @a[ 0 .. 0 ]; @hunk2b = @b[ 0 .. -1 ]; # or @hunk2a = ( 'a' ); @hunk2b = ( ); That is, we would delete item 0 ('a') from @a. Since C<@diff[4..7]> contains (1,0,3,2) in our example, the third hunk consists of these two lists of items: @hunk3a = @a[ $cdiff[4] .. $cdiff[6]-1 ]; @hunk3a = @b[ $cdiff[5] .. $cdiff[7]-1 ]; # or @hunk3a = @a[ 1 .. 3-1 ]; @hunk3a = @b[ 0 .. 2-1 ]; # or @hunk3a = @a[ 1 .. 2 ]; @hunk3a = @b[ 0 .. 1 ]; # or @hunk3a = qw( b c ); @hunk3a = qw( b c ); Note that this third hunk contains unchanged items as our convention demands. You can continue this process until you reach the last two indices, which will always be the number of items in each sequence. This is required so that subtracting one from each will give you the indices to the last items in each sequence. =head2 C C used to be the most general facility provided by this module (the new OO interface is more powerful and much easier to use). Imagine that there are two arrows. Arrow A points to an element of sequence A, and arrow B points to an element of the sequence B. Initially, the arrows point to the first elements of the respective sequences. C will advance the arrows through the sequences one element at a time, calling an appropriate user-specified callback function before each advance. It willadvance the arrows in such a way that if there are equal elements C<$A[$i]> and C<$B[$j]> which are equal and which are part of the LCS, there will be some moment during the execution of C when arrow A is pointing to C<$A[$i]> and arrow B is pointing to C<$B[$j]>. When this happens, C will call the C callback function and then it will advance both arrows. Otherwise, one of the arrows is pointing to an element of its sequence that is not part of the LCS. C will advance that arrow and will call the C or the C callback, depending on which arrow it advanced. If both arrows point to elements that are not part of the LCS, then C will advance one of them and call the appropriate callback, but it is not specified which it will call. The arguments to C are the two sequences to traverse, and a hash which specifies the callback functions, like this: traverse_sequences( \@seq1, \@seq2, { MATCH => $callback_1, DISCARD_A => $callback_2, DISCARD_B => $callback_3, } ); Callbacks for MATCH, DISCARD_A, and DISCARD_B are invoked with at least the indices of the two arrows as their arguments. They are not expected to return any values. If a callback is omitted from the table, it is not called. Callbacks for A_FINISHED and B_FINISHED are invoked with at least the corresponding index in A or B. If arrow A reaches the end of its sequence, before arrow B does, C will call the C callback when it advances arrow B, if there is such a function; if not it will call C instead. Similarly if arrow B finishes first. C returns when both arrows are at the ends of their respective sequences. It returns true on success and false on failure. At present there is no way to fail. C may be passed an optional fourth parameter; this is a CODE reference to a key generation function. See L. Additional parameters, if any, will be passed to the key generation function. If you want to pass additional parameters to your callbacks, but don't need a custom key generation function, you can get the default by passing undef: traverse_sequences( \@seq1, \@seq2, { MATCH => $callback_1, DISCARD_A => $callback_2, DISCARD_B => $callback_3, }, undef, # default key-gen $myArgument1, $myArgument2, $myArgument3, ); C does not have a useful return value; you are expected to plug in the appropriate behavior with the callback functions. =head2 C C is an alternative to C. It uses a different algorithm to iterate through the entries in the computed LCS. Instead of sticking to one side and showing element changes as insertions and deletions only, it will jump back and forth between the two sequences and report I occurring as deletions on one side followed immediatly by an insertion on the other side. In addition to the C, C, and C callbacks supported by C, C supports a C callback indicating that one element got C by another: traverse_balanced( \@seq1, \@seq2, { MATCH => $callback_1, DISCARD_A => $callback_2, DISCARD_B => $callback_3, CHANGE => $callback_4, } ); If no C callback is specified, C will map C events to C and C actions, therefore resulting in a similar behaviour as C with different order of events. C might be a bit slower than C, noticable only while processing huge amounts of data. The C function of this module is implemented as call to C. C does not have a useful return value; you are expected to plug in the appropriate behavior with the callback functions. =head1 KEY GENERATION FUNCTIONS Most of the functions accept an optional extra parameter. This is a CODE reference to a key generating (hashing) function that should return a string that uniquely identifies a given element. It should be the case that if two elements are to be considered equal, their keys should be the same (and the other way around). If no key generation function is provided, the key will be the element as a string. By default, comparisons will use "eq" and elements will be turned into keys using the default stringizing operator '""'. Where this is important is when you're comparing something other than strings. If it is the case that you have multiple different objects that should be considered to be equal, you should supply a key generation function. Otherwise, you have to make sure that your arrays contain unique references. For instance, consider this example: package Person; sub new { my $package = shift; return bless { name => '', ssn => '', @_ }, $package; } sub clone { my $old = shift; my $new = bless { %$old }, ref($old); } sub hash { return shift()->{'ssn'}; } my $person1 = Person->new( name => 'Joe', ssn => '123-45-6789' ); my $person2 = Person->new( name => 'Mary', ssn => '123-47-0000' ); my $person3 = Person->new( name => 'Pete', ssn => '999-45-2222' ); my $person4 = Person->new( name => 'Peggy', ssn => '123-45-9999' ); my $person5 = Person->new( name => 'Frank', ssn => '000-45-9999' ); If you did this: my $array1 = [ $person1, $person2, $person4 ]; my $array2 = [ $person1, $person3, $person4, $person5 ]; Algorithm::Diff::diff( $array1, $array2 ); everything would work out OK (each of the objects would be converted into a string like "Person=HASH(0x82425b0)" for comparison). But if you did this: my $array1 = [ $person1, $person2, $person4 ]; my $array2 = [ $person1, $person3, $person4->clone(), $person5 ]; Algorithm::Diff::diff( $array1, $array2 ); $person4 and $person4->clone() (which have the same name and SSN) would be seen as different objects. If you wanted them to be considered equivalent, you would have to pass in a key generation function: my $array1 = [ $person1, $person2, $person4 ]; my $array2 = [ $person1, $person3, $person4->clone(), $person5 ]; Algorithm::Diff::diff( $array1, $array2, \&Person::hash ); This would use the 'ssn' field in each Person as a comparison key, and so would consider $person4 and $person4->clone() as equal. You may also pass additional parameters to the key generation function if you wish. =head1 ERROR CHECKING If you pass these routines a non-reference and they expect a reference, they will die with a message. =head1 AUTHOR This version released by Tye McQueen (http://perlmonks.org/?node=tye). =head1 LICENSE Parts Copyright (c) 2000-2004 Ned Konz. All rights reserved. Parts by Tye McQueen. This program is free software; you can redistribute it and/or modify it under the same terms as Perl. =head1 MAILING LIST Mark-Jason still maintains a mailing list. To join a low-volume mailing list for announcements related to diff and Algorithm::Diff, send an empty mail message to mjd-perl-diff-request@plover.com. =head1 CREDITS Versions through 0.59 (and much of this documentation) were written by: Mark-Jason Dominus, mjd-perl-diff@plover.com This version borrows some documentation and routine names from Mark-Jason's, but Diff.pm's code was completely replaced. This code was adapted from the Smalltalk code of Mario Wolczko , which is available at ftp://st.cs.uiuc.edu/pub/Smalltalk/MANCHESTER/manchester/4.0/diff.st C and C were written by Mike Schilli . The algorithm is that described in I, CACM, vol.20, no.5, pp.350-353, May 1977, with a few minor improvements to improve the speed. Much work was done by Ned Konz (perl@bike-nomad.com). The OO interface and some other changes are by Tye McQueen. =cut Algorithm-Diff-1.1902/lib/Algorithm/DiffOld.pm0100644000567200017500000001753310463315120020531 0ustar monkperlusers# This is a version of Algorithm::Diff that uses only a comparison function, # like versions <= 0.59 used to. # $Revision: 1.3 $ package Algorithm::DiffOld; use strict; use vars qw($VERSION @EXPORT_OK @ISA @EXPORT); use integer; # see below in _replaceNextLargerWith() for mod to make # if you don't use this require Exporter; @ISA = qw(Exporter); @EXPORT = qw(); @EXPORT_OK = qw(LCS diff traverse_sequences); $VERSION = 1.10; # manually tracking Algorithm::Diff # McIlroy-Hunt diff algorithm # Adapted from the Smalltalk code of Mario I. Wolczko, # by Ned Konz, perl@bike-nomad.com =head1 NAME Algorithm::DiffOld - Compute `intelligent' differences between two files / lists but use the old (<=0.59) interface. =head1 NOTE This has been provided as part of the Algorithm::Diff package by Ned Konz. This particular module is B for people who B to have the old interface, which uses a comparison function rather than a key generating function. Because each of the lines in one array have to be compared with each of the lines in the other array, this does M*N comparisions. This can be very slow. I clocked it at taking 18 times as long as the stock version of Algorithm::Diff for a 4000-line file. It will get worse quadratically as array sizes increase. =head1 SYNOPSIS use Algorithm::DiffOld qw(diff LCS traverse_sequences); @lcs = LCS( \@seq1, \@seq2, $comparison_function ); $lcsref = LCS( \@seq1, \@seq2, $comparison_function ); @diffs = diff( \@seq1, \@seq2, $comparison_function ); traverse_sequences( \@seq1, \@seq2, { MATCH => $callback, DISCARD_A => $callback, DISCARD_B => $callback, }, $comparison_function ); =head1 COMPARISON FUNCTIONS Each of the main routines should be passed a comparison function. If you aren't passing one in, B. These functions should return a true value when two items should compare as equal. For instance, @lcs = LCS( \@seq1, \@seq2, sub { my ($a, $b) = @_; $a eq $b } ); but if that is all you're doing with your comparison function, just use Algorithm::Diff and let it do this (this is its default). Or: sub someFunkyComparisonFunction { my ($a, $b) = @_; $a =~ m{$b}; } @diffs = diff( \@lines, \@patterns, \&someFunkyComparisonFunction ); which would allow you to diff an array @lines which consists of text lines with an array @patterns which consists of regular expressions. This is actually the reason I wrote this version -- there is no way to do this with a key generation function as in the stock Algorithm::Diff. =cut # 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; } # binary search for insertion point... my $low = 0; my $index; my $found; while ( $low <= $high ) { $index = ( $high + $low ) / 2; # $index = int(( $high + $low ) / 2); # without 'use integer' $found = $array->[ $index ]; if ( $aValue == $found ) { return undef; } elsif ( $aValue > $found ) { $low = $index + 1; } else { $high = $index - 1; } } # now insertion point is in $low. $array->[ $low ] = $aValue; # overwrite next larger return $low; } # This method computes the longest common subsequence in $a and $b. # Result is array or ref, whose contents is such that # $a->[ $i ] == $b->[ $result[ $i ] ] # foreach $i in ( 0 .. $#result ) if $result[ $i ] is defined. # An additional argument may be passed; this is a CODE ref to a comparison # routine. By default, comparisons will use "eq" . # Note that this routine will be called as many as M*N times, so make it fast! # Additional parameters, if any, will be passed to the key generation routine. sub _longestCommonSubsequence { my $a = shift; # array ref my $b = shift; # array ref my $compare = shift || sub { my $a = shift; my $b = shift; $a eq $b }; my $aStart = 0; my $aFinish = $#$a; my $bStart = 0; my $bFinish = $#$b; my $matchVector = []; # First we prune off any common elements at the beginning while ( $aStart <= $aFinish and $bStart <= $bFinish and &$compare( $a->[ $aStart ], $b->[ $bStart ], @_ ) ) { $matchVector->[ $aStart++ ] = $bStart++; } # now the end while ( $aStart <= $aFinish and $bStart <= $bFinish and &$compare( $a->[ $aFinish ], $b->[ $bFinish ], @_ ) ) { $matchVector->[ $aFinish-- ] = $bFinish--; } my $thresh = []; my $links = []; my ( $i, $ai, $j, $k ); for ( $i = $aStart; $i <= $aFinish; $i++ ) { $k = 0; # look for each element of @b between $bStart and $bFinish # that matches $a->[ $i ], in reverse order for ($j = $bFinish; $j >= $bStart; $j--) { next if ! &$compare( $a->[$i], $b->[$j], @_ ); # optimization: most of the time this will be true if ( $k and $thresh->[ $k ] > $j and $thresh->[ $k - 1 ] < $j ) { $thresh->[ $k ] = $j; } else { $k = _replaceNextLargerWith( $thresh, $j, $k ); } # oddly, it's faster to always test this (CPU cache?). if ( defined( $k ) ) { $links->[ $k ] = [ ( $k ? $links->[ $k - 1 ] : undef ), $i, $j ]; } } } if ( @$thresh ) { for ( my $link = $links->[ $#$thresh ]; $link; $link = $link->[ 0 ] ) { $matchVector->[ $link->[ 1 ] ] = $link->[ 2 ]; } } return wantarray ? @$matchVector : $matchVector; } sub traverse_sequences { my $a = shift; # array ref my $b = shift; # array ref my $callbacks = shift || { }; my $compare = shift; my $matchCallback = $callbacks->{'MATCH'} || sub { }; my $discardACallback = $callbacks->{'DISCARD_A'} || sub { }; my $finishedACallback = $callbacks->{'A_FINISHED'}; my $discardBCallback = $callbacks->{'DISCARD_B'} || sub { }; my $finishedBCallback = $callbacks->{'B_FINISHED'}; my $matchVector = _longestCommonSubsequence( $a, $b, $compare, @_ ); # Process all the lines in match vector my $lastA = $#$a; my $lastB = $#$b; my $bi = 0; my $ai; for ( $ai = 0; $ai <= $#$matchVector; $ai++ ) { my $bLine = $matchVector->[ $ai ]; if ( defined( $bLine ) ) # matched { &$discardBCallback( $ai, $bi++, @_ ) while $bi < $bLine; &$matchCallback( $ai, $bi++, @_ ); } else { &$discardACallback( $ai, $bi, @_ ); } } # the last entry (if any) processed was a match. if ( defined( $finishedBCallback ) && $ai <= $lastA ) { &$finishedBCallback( $bi, @_ ); } else { &$discardACallback( $ai++, $bi, @_ ) while ( $ai <= $lastA ); } if ( defined( $finishedACallback ) && $bi <= $lastB ) { &$finishedACallback( $ai, @_ ); } else { &$discardBCallback( $ai, $bi++, @_ ) while ( $bi <= $lastB ); } return 1; } sub LCS { my $a = shift; # array ref my $matchVector = _longestCommonSubsequence( $a, @_ ); my @retval; my $i; for ( $i = 0; $i <= $#$matchVector; $i++ ) { if ( defined( $matchVector->[ $i ] ) ) { push( @retval, $a->[ $i ] ); } } return wantarray ? @retval : \@retval; } 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 scalar(@$hunk); $hunk = [] }; traverse_sequences( $a, $b, { MATCH => $match, DISCARD_A => $discard, DISCARD_B => $add }, @_ ); &$match(); return wantarray ? @$retval : $retval; } 1; Algorithm-Diff-1.1902/META.yml0100644000567200017500000000047210463315710015440 0ustar monkperlusers# http://module-build.sourceforge.net/META-spec.html #XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX# name: Algorithm-Diff version: 1.1902 version_from: lib/Algorithm/Diff.pm installdirs: site requires: distribution_type: module generated_by: ExtUtils::MakeMaker version 6.17 Algorithm-Diff-1.1902/Changes0100644000567200017500000000255010463315640015463 0ustar monkperlusersRevision history for Perl module Algorithm::Diff. 1.19_02 2006-07-31 - Fix typo in @EXPORT_OK (s/LCDidx/LCSidx/) (RT 8576) - Use 'printf' in example code, not 'sprintf' nor 'sprint' (RT 16067) - DiffOld wasn't passing extra arguments to compare routine (RT 20650) 1.19 2004-09-22 - Added OO interface. - Based on Ned's v1.18 (unreleased) 1.13 Sun Mar 24 16:05:32 PST 2002 - sdiff and traverse_balanced added by Mike Schilli . 1.11 Thu Jul 12 12:52:18 PDT 2001 - Added A_FINISHED and B_FINISHED per docs - Called user callback function from keygen properly 1.10 July 7 2000 - Uploaded to CPAN - More optimizations - Added Algorithm::DiffOld 1.08 - Fixed bug with binary search that was making diff output too big 1.06 Wed Jun 14 14:15:31 PDT 2000 - First CPAN version by NEDKONZ - Added MJD's list info to README 1.05 Sun Jun 11 15:17:05 PDT 2000 - Changed version label string. - Put MJD's PPT diff version into this distribution as diffnew.pl 1.04 Added documentation. 1.03 Working version 1.01 First version by Ned Konz. - Total re-write to cure problems with memory usage and speed. Now takes only a few seconds and less than three megabytes to compare two 4000-line files. - Changed optional callback function reference from being equality function to being key (hash) generation function. 0.59 Last version maintained by Mark-Jason Dominus Algorithm-Diff-1.1902/cdiff.pl0100644000567200017500000003004410124555600015573 0ustar monkperlusers#!/usr/bin/perl -w # # `Diff' program in Perl # Copyright 1998 M-J. Dominus. (mjd-perl-diff@plover.com) # # This program is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # # Altered to output in `context diff' format (but without context) # September 1998 Christian Murphy (cpm@muc.de) # # Command-line arguments and context lines feature added # September 1998 Amir D. Karger (karger@bead.aecom.yu.edu) # # In this file, "item" usually means "line of text", and "item number" usually # means "line number". But theoretically the code could be used more generally use strict; use Algorithm::Diff qw(diff); use File::stat; use vars qw ($opt_C $opt_c $opt_u $opt_U); use Getopt::Std; my $usage = << "ENDUSAGE"; Usage: $0 [{-c | -u}] [{-C | -U} lines] oldfile newfile -c will do a context diff with 3 lines of context -C will do a context diff with 'lines' lines of context -u will do a unified diff with 3 lines of context -U will do a unified diff with 'lines' lines of context ENDUSAGE getopts('U:C:cu') or bag("$usage"); bag("$usage") unless @ARGV == 2; my ($file1, $file2) = @ARGV; if (defined $opt_C || defined $opt_c) { $opt_c = ""; # -c on if -C given on command line $opt_u = undef; } elsif (defined $opt_U || defined $opt_u) { $opt_u = ""; # -u on if -U given on command line $opt_c = undef; } else { $opt_c = ""; # by default, do context diff, not old diff } my ($char1, $char2); # string to print before file names my $Context_Lines; # lines of context to print if (defined $opt_c) { $Context_Lines = defined $opt_C ? $opt_C : 3; $char1 = '*' x 3; $char2 = '-' x 3; } elsif (defined $opt_u) { $Context_Lines = defined $opt_U ? $opt_U : 3; $char1 = '-' x 3; $char2 = '+' x 3; } # After we've read up to a certain point in each file, the number of items # we've read from each file will differ by $FLD (could be 0) my $File_Length_Difference = 0; open (F1, $file1) or bag("Couldn't open $file1: $!"); open (F2, $file2) or bag("Couldn't open $file2: $!"); my (@f1, @f2); chomp(@f1 = ); close F1; chomp(@f2 = ); close F2; # diff yields lots of pieces, each of which is basically a Block object my $diffs = diff(\@f1, \@f2); exit 0 unless @$diffs; my $st = stat($file1); print "$char1 $file1\t", scalar localtime($st->mtime), "\n"; $st = stat($file2); print "$char2 $file2\t", scalar localtime($st->mtime), "\n"; my ($hunk,$oldhunk); # Loop over hunks. If a hunk overlaps with the last hunk, join them. # Otherwise, print out the old one. foreach my $piece (@$diffs) { $hunk = new Hunk ($piece, $Context_Lines); next unless $oldhunk; if ($hunk->does_overlap($oldhunk)) { $hunk->prepend_hunk($oldhunk); } else { $oldhunk->output_diff(\@f1, \@f2); } } continue { $oldhunk = $hunk; } # print the last hunk $oldhunk->output_diff(\@f1, \@f2); exit 1; # END MAIN PROGRAM sub bag { my $msg = shift; $msg .= "\n"; warn $msg; exit 2; } # Package Hunk. A Hunk is a group of Blocks which overlap because of the # context surrounding each block. (So if we're not using context, every # hunk will contain one block.) { package Hunk; sub new { # Arg1 is output from &LCS::diff (which corresponds to one Block) # Arg2 is the number of items (lines, e.g.,) of context around each block # # This subroutine changes $File_Length_Difference # # Fields in a Hunk: # blocks - a list of Block objects # start - index in file 1 where first block of the hunk starts # end - index in file 1 where last block of the hunk ends # # Variables: # before_diff - how much longer file 2 is than file 1 due to all hunks # until but NOT including this one # after_diff - difference due to all hunks including this one my ($class, $piece, $context_items) = @_; my $block = new Block ($piece); # this modifies $FLD! my $before_diff = $File_Length_Difference; # BEFORE this hunk my $after_diff = $before_diff + $block->{"length_diff"}; $File_Length_Difference += $block->{"length_diff"}; # @remove_array and @insert_array hold the items to insert and remove # Save the start & beginning of each array. If the array doesn't exist # though (e.g., we're only adding items in this block), then figure # out the line number based on the line number of the other file and # the current difference in file lenghts my @remove_array = $block->remove; my @insert_array = $block->insert; my ($a1, $a2, $b1, $b2, $start1, $start2, $end1, $end2); $a1 = @remove_array ? $remove_array[0 ]->{"item_no"} : -1; $a2 = @remove_array ? $remove_array[-1]->{"item_no"} : -1; $b1 = @insert_array ? $insert_array[0 ]->{"item_no"} : -1; $b2 = @insert_array ? $insert_array[-1]->{"item_no"} : -1; $start1 = $a1 == -1 ? $b1 - $before_diff : $a1; $end1 = $a2 == -1 ? $b2 - $after_diff : $a2; $start2 = $b1 == -1 ? $a1 + $before_diff : $b1; $end2 = $b2 == -1 ? $a2 + $after_diff : $b2; # At first, a hunk will have just one Block in it my $hunk = { "start1" => $start1, "start2" => $start2, "end1" => $end1, "end2" => $end2, "blocks" => [$block], }; bless $hunk, $class; $hunk->flag_context($context_items); return $hunk; } # Change the "start" and "end" fields to note that context should be added # to this hunk sub flag_context { my ($hunk, $context_items) = @_; return unless $context_items; # no context # add context before my $start1 = $hunk->{"start1"}; my $num_added = $context_items > $start1 ? $start1 : $context_items; $hunk->{"start1"} -= $num_added; $hunk->{"start2"} -= $num_added; # context after my $end1 = $hunk->{"end1"}; $num_added = ($end1+$context_items > $#f1) ? $#f1 - $end1 : $context_items; $hunk->{"end1"} += $num_added; $hunk->{"end2"} += $num_added; } # Is there an overlap between hunk arg0 and old hunk arg1? # Note: if end of old hunk is one less than beginning of second, they overlap sub does_overlap { my ($hunk, $oldhunk) = @_; return "" unless $oldhunk; # first time through, $oldhunk is empty # Do I actually need to test both? return ($hunk->{"start1"} - $oldhunk->{"end1"} <= 1 || $hunk->{"start2"} - $oldhunk->{"end2"} <= 1); } # Prepend hunk arg1 to hunk arg0 # Note that arg1 isn't updated! Only arg0 is. sub prepend_hunk { my ($hunk, $oldhunk) = @_; $hunk->{"start1"} = $oldhunk->{"start1"}; $hunk->{"start2"} = $oldhunk->{"start2"}; unshift (@{$hunk->{"blocks"}}, @{$oldhunk->{"blocks"}}); } # DIFF OUTPUT ROUTINES. THESE ROUTINES CONTAIN DIFF FORMATTING INFO... sub output_diff { if (defined $main::opt_u) {&output_unified_diff(@_)} elsif (defined $main::opt_c) {&output_context_diff(@_)} else {die "unknown diff"} } sub output_unified_diff { my ($hunk, $fileref1, $fileref2) = @_; my @blocklist; # Calculate item number range. my $range1 = $hunk->unified_range(1); my $range2 = $hunk->unified_range(2); print "@@ -$range1 +$range2 @@\n"; # Outlist starts containing the hunk of file 1. # Removing an item just means putting a '-' in front of it. # Inserting an item requires getting it from file2 and splicing it in. # We splice in $num_added items. Remove blocks use $num_added because # splicing changed the length of outlist. # We remove $num_removed items. Insert blocks use $num_removed because # their item numbers---corresponding to positions in file *2*--- don't take # removed items into account. my $low = $hunk->{"start1"}; my $hi = $hunk->{"end1"}; my ($num_added, $num_removed) = (0,0); my @outlist = @$fileref1[$low..$hi]; map {s/^/ /} @outlist; # assume it's just context foreach my $block (@{$hunk->{"blocks"}}) { foreach my $item ($block->remove) { my $op = $item->{"sign"}; # - my $offset = $item->{"item_no"} - $low + $num_added; $outlist[$offset] =~ s/^ /$op/; $num_removed++; } foreach my $item ($block->insert) { my $op = $item->{"sign"}; # + my $i = $item->{"item_no"}; my $offset = $i - $hunk->{"start2"} + $num_removed; splice(@outlist,$offset,0,"$op$$fileref2[$i]"); $num_added++; } } map {s/$/\n/} @outlist; # add \n's print @outlist; } sub output_context_diff { my ($hunk, $fileref1, $fileref2) = @_; my @blocklist; print "***************\n"; # Calculate item number range. my $range1 = $hunk->context_range(1); my $range2 = $hunk->context_range(2); # Print out file 1 part for each block in context diff format if there are # any blocks that remove items print "*** $range1 ****\n"; my $low = $hunk->{"start1"}; my $hi = $hunk->{"end1"}; if (@blocklist = grep {$_->remove} @{$hunk->{"blocks"}}) { my @outlist = @$fileref1[$low..$hi]; map {s/^/ /} @outlist; # assume it's just context foreach my $block (@blocklist) { my $op = $block->op; # - or ! foreach my $item ($block->remove) { $outlist[$item->{"item_no"} - $low] =~ s/^ /$op/; } } map {s/$/\n/} @outlist; # add \n's print @outlist; } print "--- $range2 ----\n"; $low = $hunk->{"start2"}; $hi = $hunk->{"end2"}; if (@blocklist = grep {$_->insert} @{$hunk->{"blocks"}}) { my @outlist = @$fileref2[$low..$hi]; map {s/^/ /} @outlist; # assume it's just context foreach my $block (@blocklist) { my $op = $block->op; # + or ! foreach my $item ($block->insert) { $outlist[$item->{"item_no"} - $low] =~ s/^ /$op/; } } map {s/$/\n/} @outlist; # add \n's print @outlist; } } sub context_range { # Generate a range of item numbers to print. Only print 1 number if the range # has only one item in it. Otherwise, it's 'start,end' my ($hunk, $flag) = @_; my ($start, $end) = ($hunk->{"start$flag"},$hunk->{"end$flag"}); $start++; $end++; # index from 1, not zero my $range = ($start < $end) ? "$start,$end" : $end; return $range; } sub unified_range { # Generate a range of item numbers to print for unified diff # Print number where block starts, followed by number of lines in the block # (don't print number of lines if it's 1) my ($hunk, $flag) = @_; my ($start, $end) = ($hunk->{"start$flag"},$hunk->{"end$flag"}); $start++; $end++; # index from 1, not zero my $length = $end - $start + 1; my $first = $length < 2 ? $end : $start; # strange, but correct... my $range = $length== 1 ? $first : "$first,$length"; return $range; } } # end Package Hunk # Package Block. A block is an operation removing, adding, or changing # a group of items. Basically, this is just a list of changes, where each # change adds or deletes a single item. # (Change could be a separate class, but it didn't seem worth it) { package Block; sub new { # Input is a chunk from &Algorithm::LCS::diff # Fields in a block: # length_diff - how much longer file 2 is than file 1 due to this block # Each change has: # sign - '+' for insert, '-' for remove # item_no - number of the item in the file (e.g., line number) # We don't bother storing the text of the item # my ($class,$chunk) = @_; my @changes = (); # This just turns each change into a hash. foreach my $item (@$chunk) { my ($sign, $item_no, $text) = @$item; my $hashref = {"sign" => $sign, "item_no" => $item_no}; push @changes, $hashref; } my $block = { "changes" => \@changes }; bless $block, $class; $block->{"length_diff"} = $block->insert - $block->remove; return $block; } # LOW LEVEL FUNCTIONS sub op { # what kind of block is this? my $block = shift; my $insert = $block->insert; my $remove = $block->remove; $remove && $insert and return '!'; $remove and return '-'; $insert and return '+'; warn "unknown block type"; return '^'; # context block } # Returns a list of the changes in this block that remove items # (or the number of removals if called in scalar context) sub remove { return grep {$_->{"sign"} eq '-'} @{shift->{"changes"}}; } # Returns a list of the changes in this block that insert items sub insert { return grep {$_->{"sign"} eq '+'} @{shift->{"changes"}}; } } # end of package Block Algorithm-Diff-1.1902/MANIFEST0100644000567200017500000000111110124555600015305 0ustar monkperlusersChanges lib/Algorithm/Diff.pm Algorithm::Diff perl module lib/Algorithm/DiffOld.pm Algorithm::Diff perl module with old behavior Makefile.PL MANIFEST README t/base.t Basic test script t/oo.t OO interface test script cdiff.pl Context diff utility diff.pl Simple Unix diff utility written in Perl diffnew.pl Full-featured Unix diff utility written in Perl htmldiff.pl Sample using traverse_sequences META.yml Module meta-data (added by MakeMaker) Algorithm-Diff-1.1902/diff.pl0100644000567200017500000000172110124555600015430 0ustar monkperlusers#!/usr/bin/perl # # `Diff' program in Perl # Copyright 1998 M-J. Dominus. (mjd-perl-diff@plover.com) # # This program is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # use Algorithm::Diff qw(diff); bag("Usage: $0 oldfile newfile") unless @ARGV == 2; my ($file1, $file2) = @ARGV; # -f $file1 or bag("$file1: not a regular file"); # -f $file2 or bag("$file2: not a regular file"); -T $file1 or bag("$file1: binary"); -T $file2 or bag("$file2: binary"); open (F1, $file1) or bag("Couldn't open $file1: $!"); open (F2, $file2) or bag("Couldn't open $file2: $!"); chomp(@f1 = ); close F1; chomp(@f2 = ); close F2; $diffs = diff(\@f1, \@f2); exit 0 unless @$diffs; foreach $chunk (@$diffs) { foreach $line (@$chunk) { my ($sign, $lineno, $text) = @$line; printf "%4d$sign %s\n", $lineno+1, $text; } print "--------\n"; } exit 1; sub bag { my $msg = shift; $msg .= "\n"; warn $msg; exit 2; } Algorithm-Diff-1.1902/Makefile.PL0100644000567200017500000000040610124555604016140 0ustar monkperlusersuse ExtUtils::MakeMaker; # See lib/ExtUtils/MakeMaker.pm for details of how to influence # the contents of the Makefile that is written. WriteMakefile( 'NAME' => 'Algorithm::Diff', 'VERSION_FROM' => 'lib/Algorithm/Diff.pm', # finds $VERSION ); Algorithm-Diff-1.1902/README0100644000567200017500000000641010124555604015047 0ustar monkperlusersThis is a module for computing the difference between two files, two strings, or any other two lists of things. It uses an intelligent algorithm similar to (or identical to) the one used by the Unix "diff" program. It is guaranteed to find the *smallest possible* set of differences. This package contains a few parts. Algorithm::Diff is the module that contains several interfaces for which computing the differences betwen two lists. The several "diff" programs also included in this package use Algorithm::Diff to find the differences and then they format the output. Algorithm::Diff also includes some other useful functions such as "LCS", which computes the longest common subsequence of two lists. A::D is suitable for many uses. You can use it for finding the smallest set of differences between two strings, or for computing the most efficient way to update the screen if you were replacing "curses". Algorithm::DiffOld is a previous version of the module which is included primarilly for those wanting to use a custom comparison function rather than a key generating function (and who don't mind the significant performance penalty of perhaps 20-fold). diff.pl implements a "diff" in Perl that is as simple as (was previously) possible so that you can see how it works. The output format is not compatible with regular "diff". It needs to be reimplemented using the OO interface to greatly simplify the code. diffnew.pl implements a "diff" in Perl with full bells and whistles. By Mark-Jason, with code from cdiff.pl included. cdiff.pl implements "diff" that generates real context diffs in either traditional format or GNU unified format. Original contextless "context" diff supplied by Christian Murphy. Modifications to make it into a real full-featured diff with -c and -u options supplied by Amir D. Karger. Yes, you can use this program to generate patches. OTHER RESOURCES "Longest Common Subsequences", at http://www.ics.uci.edu/~eppstein/161/960229.html This code was adapted from the Smalltalk code of Mario Wolczko , which is available at ftp://st.cs.uiuc.edu/pub/Smalltalk/MANCHESTER/manchester/4.0/diff.st THANKS SECTION Thanks to Ned Konz's for rewriting the module to greatly improve performance, for maintaining it over the years, and for readilly handing it over to me so I could plod along with my improvements. (From Ned Konz's earlier versions): Thanks to Mark-Jason Dominus for doing the original Perl version and maintaining it over the last couple of years. Mark-Jason has been a huge contributor to the Perl community and CPAN; it's because of people like him that Perl has become a success. Thanks to Mario Wolczko for writing and making publicly available his Smalltalk version of diff, which this Perl version is heavily based on. Thanks to Mike Schilli for writing sdiff and traverse_balanced and making them available for the Algorithm::Diff distribution. (From Mark-Jason Dominus' earlier versions): Huge thanks to Amir Karger for adding full context diff supprt to "cdiff.pl", and then for waiting patiently for five months while I let it sit in a closet and didn't release it. Thank you thank you thank you, Amir! Thanks to Christian Murphy for adding the first context diff format support to "cdiff.pl".