File Coverage

blib/lib/Test/HTML/Differences.pm

Criterion	Covered	Total	%
statement	30	96	31.2
branch	1	28	3.5
condition	1	6	16.6
subroutine	10	19	52.6
pod	0	2	0.0
total	42	151	27.8

package Test::HTML::Differences;

use strict;
use warnings;
use parent qw(Exporter);
use HTML::Parser;
use HTML::Entities;
use Text::Diff;
use Text::Diff::Table;
use Test::Differences;

our $VERSION = '0.04';

our @EXPORT = qw(
	eq_or_diff_html
);

sub import {
	my $class = shift;
	if ($_[0] && $_[0] eq '-color') {
		shift @_;
		eval "use Test::Differences::Color"; ## no critic
		$@ and die $@;
	}
	__PACKAGE__->export_to_level(1, @_);
}

sub eq_or_diff_html ($$;$) { ## no critic
	my ($got_raw, $expected_raw, $desc) = @_;

	my $got             = normalize_html($got_raw);
	my $expected        = normalize_html($expected_raw);

	my $got_pretty      = normalize_html($got_raw, 1);
	my $expected_pretty = normalize_html($expected_raw, 1);

	no warnings 'redefine';
	my $orig = \&Text::Diff::Table::file_footer;
	local *Text::Diff::Table::file_footer = sub {
		my ($self, $seqa, $seqb, $options) = @_;
		my $elts = $self->{ELTS};
		for my $elt (@$elts) {
			next if $elt->[-1] eq 'bar';
			$elt->[1] = $got_pretty->[$elt->[0]] unless $elt->[-1] eq 'B';
			$elt->[3] = $expected_pretty->[$elt->[2]] unless $elt->[-1] eq 'A';
		}
		$orig->(@_);
	};

	local $Test::Builder::Level = $Test::Builder::Level + 1;
	table_diff();
	eq_or_diff($got, $expected, $desc);
}

sub normalize_html {
	my ($s, $pretty) = @_;

	my $root  = [ root => {} => [] ];
	my $stack = [ $root ];
	my $p = HTML::Parser->new(
		api_version => 3,
		handlers => {
			start => [
				sub {
					my ($tagname, $attr) = @_;
					my $e = [
						$tagname => $attr => []
					];
					push @{ $stack->[-1]->[2] }, $e;
					push @$stack, $e;
				},
				"tagname, attr"
			],
			end => [
				sub {
					pop @$stack;
				},
				"tagname",
			],
			comment => [
				sub {
					my ($text) = @_;
					push @{ $stack->[-1]->[2] }, $text;
				},
				"text"
			],
			text  => [
				sub {
					my ($dtext) = @_;
					$dtext =~ s/^\s+|\s+$//g;
					push @{ $stack->[-1]->[2] }, encode_entities($dtext) if $dtext =~ /\S/;
				},
				"dtext"
			]
		}
	);
	$p->unbroken_text(1);
	$p->empty_element_tags(1);
	$p->parse($s);
	$p->eof;

	my $indent = $pretty ? sub { "  " x shift() . sprintf(shift, @_) } : sub { shift; sprintf(shift, @_) };

	my $ret = [];
	my $walker; $walker = sub {
		my ($parent, $level) = @_;
		my ($tag, $attr, $children) = @$parent;

		my $a = join ' ', map { sprintf('%s="%s"', $_, encode_entities($attr->{$_})) } sort { $a cmp $b } keys %$attr;
		my $has_element = @$children > 1 || grep { ref($_) } @$children;
		if ($has_element) {
			push @$ret, $indent->($level, '<%s%s>', $tag, $a ? " $a" : "") unless $tag eq 'root';
			for my $node (@$children) {
				if (ref($node)) {
					$walker->($node, $level + 1);
				} else {
					push @$ret, $indent->($level + 1, '%s', $node);
				}
			}
			push @$ret, $indent->($level, '', $tag) unless $tag eq 'root';
		} else {
			if ($tag eq 'root') {
				push @$ret, join(' ', @$children);
			} else {
				push @$ret, $indent->($level, '<%s%s>%s', $tag, $a ? " $a" : "", join(' ', @$children), $tag);
			}
		}
	};
	$walker->($root, -1);

	$ret;
}


1;
__END__