File Coverage

blib/lib/Text/Diff/FormattedHTML.pm

Criterion	Covered	Total	%
statement	21	87	24.1
branch	0	30	0.0
condition			n/a
subroutine	7	20	35.0
pod	3	3	100.0
total	31	140	22.1

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.07

=cut

our $VERSION = '0.07';


=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. At the moment the only
valid option is C that can be set to a true value, for a
more compact table.

=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->{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"; 




218




 





 





 





 





 





 



   




219




 





 





 





 





 





 



     traverse_balanced $sq1, $sq2, 




220




 





 





 





 





 





 



       { 




221




 





 





 





 





 





 



        MATCH     => sub { 




222




0





 





 




  
0
  




 





 



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




223




0





 





 





 





 





 



            ++$ll; ++$rl; 




 




0





 





 





 





 





 



   




224




0





 





 





 





 





 



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




225




 





 





 





 





 





 



        }, 




226




 





 





 





 





 





 



        DISCARD_A => sub { 




227




0





 





 




  
0
  




 





 



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




228




0





 





 





 





 





 



            ++$ll; 




229




0





 





 





 





 





 



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




230




 





 





 





 





 





 



        }, 




231




 





 





 





 





 





 



        DISCARD_B => sub { 




232




0





 





 




  
0
  




 





 



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




233




0





 





 





 





 





 



            ++$rl; 




234




0





 





 





 





 





 



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




235




 





 





 





 





 





 



        }, 




236




 





 





 





 





 





 



        CHANGE    => sub { 




237




0





 





 




  
0
  




 





 



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




238




0





 





 





 





 





 



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




239




 





 





 





 





 





 



                            remove_open => '#del#', 




240




 





 





 





 





 





 



                            remove_close => '#/del#', 




241




 





 





 





 





 





 



                            append_open => '#ins#', 




242




 





 





 





 





 





 



                            append_close => '#/ins#', 




243




 





 





 





 





 





 



                           ); 




244




0





 





 





 





 





 



            ++$ll; ++$rl; 




 




0





 





 





 





 





 



   




245




0





 





 





 





 





 



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




246




 





 





 





 





 





 



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




247




 





 





 





 





 





 



        }, 




248




0





 





 





 





 





 



       }; 




249




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