File Coverage

blib/lib/Text/Diff/FormattedHTML.pm

Criterion	Covered	Total	%
statement	20	107	18.6
branch	0	46	0.0
condition	0	6	0.0
subroutine	7	21	33.3
pod	3	3	100.0
total	30	183	16.3

package Text::Diff::FormattedHTML;

use 5.006;
use strict;
use warnings;

use File::Slurp;
use Algorithm::Diff 'traverse_balanced';
use String::Diff 'diff';

use base 'Exporter';

our @EXPORT = (qw'diff_files diff_strings diff_css');

=head1 NAME

Text::Diff::FormattedHTML - Generate a colorful HTML diff of strings/files.

=head1 VERSION

Version 0.08

=cut

our $VERSION = '0.08';


=head1 SYNOPSIS

    use Text::Diff::FormattedHTML;

    my $output = diff_files($file1, $file2);

    # for strings

    my $output = diff_strings( { vertical => 1 }, $file1, $file2);


    # as you might want some CSS:
    open OUT, ">diff.html";
    print OUT "\n", diff_css(), "\n";
    print OUT diff_files('fileA', 'fileB');
    close OUT;


=head1 DESCRIPTION

Presents in a (nice?) HTML table the difference between two files or strings.
Inspired on GitHub diff view.

=head1 SUBROUTINES

=head2 diff_files

   my $html = diff_files("filename1", "filename2");

C and C support a first optional argument
(an hash reference) where options can be set.

Valid options are:

=over 4

=item C

Can be set to a true value, for a more compact table.

=item C

Makes tables look nicer when there is a side with too many new lines.

=back

=cut

sub diff_files {
    my $settings = {};
    $settings = shift if ref($_[0]) eq "HASH";

    my ($f1, $f2) = @_;

    die "$f1 not available" unless -f $f1;
    die "$f2 not available" unless -f $f2;

    my @f1 = read_file $f1;
    my @f2 = read_file $f2;

    _internal_diff($settings, \@f1, \@f2);
}

=head2 diff_strings

   my $html = diff_strings("string1", "string2");

Compare strings. First split by newline, and then treat them as file
content (see function above).

=cut

sub diff_strings {
    my $settings = {};
    $settings = shift if ref($_[0]) eq "HASH";

    my ($s1, $s2) = @_;
    my @f1 = split /\n/, $s1;
    my @f2 = split /\n/, $s2;
    _internal_diff($settings, \@f1, \@f2);
}

=head2 diff_css

   my $css = diff_css;

Return the default css. You are invited to override it.

=cut

sub diff_css {
    return <<'EOCSS';
table.diff {
   border-collapse: collapse;
   border-top: solid 1px #999999;
   border-left: solid 1px #999999;
}

table.diff td {
   padding: 2px;
   padding-left: 5px;
   padding-right: 5px;
   border-right: solid 1px #999999;
   border-bottom: solid 1px #999999;
}

table.diff td:nth-child(1),
table.diff td:nth-child(2) {
   background-color: #deedff;
}

table.diff tr.change,
table.diff tr.disc_a,
table.diff tr.disc_b {
   background-color: #ffffdd;
}

table.diff tr.del {
  background-color: #ffeeee;
}

table.diff tr.ins {
  background-color: #eeffee;
}


table.diff td:nth-child(3),
table.diff td:nth-child(4) {
   font-family: monospace;
   white-space: pre;
}

table.diff td ins {
   padding: 2px;
   color: #009900;
   background-color: #ccffcc;
   text-decoration: none;
   font-weight: bold;
}

table.diff td del {
   padding: 2px;
   color: #990000;
   background-color: #ffcccc;
   text-decoration: none;
   font-weight: bold;
}

EOCSS
}

sub _protect {
    my $x = shift;
    if ($x) {
        $x =~ s/&/&/g;
        $x =~ s/
        $x =~ s/>/>/g;
    }
    return $x;
}

sub _internal_diff {
    my ($settings, $sq1, $sq2) = @_;

    my $get = sub {
        my ($l, $r) = @_;
        $l = $sq1->[$l];
        $r = $sq2->[$r];
        chomp($l) if $l;
        chomp($r) if $r;
        return ($l,$r);
    };

    my ($ll, $rl);

    my $line = sub {
        sprintf("
    };

     if ($settings->{limit_onesided}) {
         # Prevent really long lists where we just go on showing
         # all of the values that one side does not have
         if($settings->{vertical}){
             die "Option: [vertical] is incompatible with [limit_empty]";
         }
         my ($am_skipping, $num_since_lc, $num_since_rc) = (0, 0, 0);
         $line = sub {
             my ($class, $ln, $rn, $l, $r) = @_;

             my $out = '';
             if(
                 ($class ne 'disc_a') &&
                 ($class ne 'disc_b')
             ){
                 if($am_skipping){
                     $out .= "($num_since_lc, $num_since_rc)
                 }
                 ($am_skipping, $num_since_lc, $num_since_rc) = (0, 0, 0);
             }elsif($class ne 'disc_a'){
                 $num_since_lc++;
             }elsif($class ne 'disc_b'){
                 $num_since_rc++;
             }
             if(
                 ($num_since_lc > $settings->{limit_onesided}) ||
                 ($num_since_rc > $settings->{limit_onesided})
             ){
                 if(!$am_skipping){
                     $out = '
                     $am_skipping = 1;
                 }
                 $out .= '. ';
                 return $out;
             }

             $out .= sprintf("
             return $out;
         };
     }


    if ($settings->{vertical}) {
        $line = sub {
            my $out = "";
            my ($class, $ln, $rn, $l, $r) = @_;
            if ($l eq $r) {
                $out .= sprintf("
                                $class, $ln, $rn, $l);
            } else {
                $class eq "disc_a" && ($class = "disc_a del");
                $class eq "disc_b" && ($class = "disc_b ins");

                $class eq "change" && ($class = "change del");
                $l and $out .= sprintf("
                                       $class, $ln, $l);
                $class eq "change del" && ($class = "change ins");
                $r and $out .= sprintf("
                                       $class, $rn, $r);
            }
            $out
        }
    }

    my $out = "\n"; 




272




 





 





 





 





 





 



   




273




 





 





 





 





 





 



     traverse_balanced $sq1, $sq2, 




274




 





 





 





 





 





 



       { 




275




 





 





 





 





 





 



        MATCH     => sub { 




276



  
0
  




 





 




  
0
  




 





 



            my ($l, $r) = $get->(@_); 




277



  
0
  




 





 





 





 





 



            ++$ll; ++$rl; 




 



  
0
  




 





 





 





 





 



   




278



  
0
  




 





 





 





 





 



            $out .= $line->('match', $ll, $rl, _protect($l), _protect($r)); 




279




 





 





 





 





 





 



        }, 




280




 





 





 





 





 





 



        DISCARD_A => sub { 




281



  
0
  




 





 




  
0
  




 





 



            my ($l, $r) = $get->(@_); 




282



  
0
  




 





 





 





 





 



            ++$ll; 




283



  
0
  




 





 





 





 





 



            $out .= $line->('disc_a', $ll, '', _protect($l), ''); 




284




 





 





 





 





 





 



        }, 




285




 





 





 





 





 





 



        DISCARD_B => sub { 




286



  
0
  




 





 




  
0
  




 





 



            my ($l, $r) = $get->(@_); 




287



  
0
  




 





 





 





 





 



            ++$rl; 




288



  
0
  




 





 





 





 





 



            $out .= $line->('disc_b', '', $rl, '', _protect($r)); 




289




 





 





 





 





 





 



        }, 




290




 





 





 





 





 





 



        CHANGE    => sub { 




291



  
0
  




 





 




  
0
  




 





 



            my ($l, $r) = $get->(@_); 




292



  
0
  




 





 





 





 





 



            my $diff = diff($l, $r, 




293




 





 





 





 





 





 



                            remove_open => '#del#', 




294




 





 





 





 





 





 



                            remove_close => '#/del#', 




295




 





 





 





 





 





 



                            append_open => '#ins#', 




296




 





 





 





 





 





 



                            append_close => '#/ins#', 




297




 





 





 





 





 





 



                           ); 




298



  
0
  




 





 





 





 





 



            ++$ll; ++$rl; 




 



  
0
  




 





 





 





 





 



   




299



  
0
  




 





 





 





 





 



            $out .= $line->('change', $ll, $rl, 




300




 





 





 





 





 





 



                            _retag(_protect($diff->[0])), _retag(_protect($diff->[1]))); 




301




 





 





 





 





 





 



        }, 




302



  
0
  




 





 





 





 





 



       }; 




303



  
0
  




 





 





 





 





 



     $out .= "\n";

    traverse_balanced $sq1, $sq2,
      {
       MATCH     => sub {
           my ($l, $r) = $get->(@_);
           ++$ll; ++$rl;
           $out .= $line->('match', $ll, $rl, _protect($l), _protect($r));
       },
       DISCARD_A => sub {
           my ($l, $r) = $get->(@_);
           ++$ll;
           $out .= $line->('disc_a', $ll, '', _protect($l), '');
       },
       DISCARD_B => sub {
           my ($l, $r) = $get->(@_);
           ++$rl;
           $out .= $line->('disc_b', '', $rl, '', _protect($r));
       },
       CHANGE    => sub {
           my ($l, $r) = $get->(@_);
           my $diff = diff($l, $r,
                           remove_open => '#del#',
                           remove_close => '#/del#',
                           append_open => '#ins#',
                           append_close => '#/ins#',
                          );
           ++$ll; ++$rl;
           $out .= $line->('change', $ll, $rl,
                           _retag(_protect($diff->[0])), _retag(_protect($diff->[1])));
       },
      };
    $out .= "
}

sub _retag {
    my $x = shift;
    $x =~ s/#(.?(?:del|ins))#/<$1>/g;
    return $x;
}

=head1 AUTHOR

Alberto Simoes, C<<  >>

=head1 BUGS

Please report any bugs or feature requests to
C, or through the web
interface at
L.
I will be notified, and then you'll automatically be notified of
progress on your bug as I make changes.




=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc Text::Diff::FormattedHTML


You can also look for information at:

=over 4

=item * RT: CPAN's request tracker (report bugs here)

L

=item * AnnoCPAN: Annotated CPAN documentation

L

=item * CPAN Ratings

L

=item * Search CPAN

L

=back


=head1 ACKNOWLEDGEMENTS


=head1 LICENSE AND COPYRIGHT

Copyright 2011 Alberto Simoes.

This program is free software; you can redistribute it and/or modify it
under the terms of either: the GNU General Public License as published
by the Free Software Foundation; or the Artistic License.

See http://dev.perl.org/licenses/ for more information.


=cut

1; # End of Text::Diff::FormattedHTML