File Coverage

blib/lib/Markup/MatchNode.pm

Criterion	Covered	Total	%
statement	57	94	60.6
branch	18	50	36.0
condition	7	18	38.8
subroutine	9	10	90.0
pod	1	3	33.3
total	92	175	52.5

package Markup::MatchNode;
$VERSION = '1.0.0';

####################################################
# This module is protected under the terms of the
# GNU GPL. Please see
# http://www.opensource.org/licenses/gpl-license.php
# for more information.
####################################################

use strict;
use Carp;

require Markup::TreeNode;

our @ISA = qw(Markup::TreeNode);
our $empty = '(empty)';

sub new {
	my $invocant = shift();
	my $class = ref($invocant) || $invocant;
	$class = bless {
		element_type	=> 'tag',
		tagname		=> '',
		attr		=> { },
		level		=> 0,
		parent		=> $empty,
		child_num	=> 0,
		children	=> [ ],
		text		=> '',
		options		=> { }
	}, $class;
	$class->init (@_);
	return $class;
}

sub init {
	my $self = shift();
	my %args = @_;

	foreach (keys %args) {
		# enforce integrity
		if ($_ eq 'parent' && $args{$_} ne $empty) {
			$self->attach_parent($args{$_});
			next;
		}

		# enforce integrity
		if ($_ eq 'children') {
			$self->attach_children($args{$_});
			next;
		}

		if (exists $self->{$_}) {
			$self->{$_} = $args{$_};
		}
		else {
			croak ("unrecognized node option $_");
		}
	}
}

sub _ignore_me {
	my $self = shift();

	while (($self = $self->{'parent'}) ne $empty) {
		return 1 if ($self->{'options'}->{'ignore_children'});
	}

	return 0;
}

sub compare_to {
	my ($self, $treenode) = @_;

	return undef if ($self->_ignore_me());

	if (scalar(@{ $self->{'options'}->{'call_filter'} || [] })) {
		foreach (@{$self->{'options'}->{'call_filter'}}) {
			$_->($self);
		}

		return undef;
	}

	my (@minor, @major);
	@minor = (0, 0, 0, '');
	@major = (0, 0, 0, '');
	# array positions: [0] == possible errors : [1] == correct points : [2] percent correct : [3] errors
	my $similar = sub {
		my ($nodeA, $nodeB) = @_;

		if ($nodeA eq $empty && $nodeB eq $empty) {
			return (1);
		}

		if ($nodeA eq $empty || $nodeB eq $empty) {
			return (0);
		}

		return ((($nodeA->{'element_type'} eq $nodeB->{'element_type'}) &&
			($nodeA->{'tagname'} eq $nodeB->{'tagname'})));
	};
	my $calc = sub {
		my ($minor, $major, $list) = @_;

		$minor->[3] =~ s/^://;
		$major->[3] =~ s/^://;

		$minor->[2] = _percent($minor->[1], $minor->[0]);
		$major->[2] = _percent($major->[1], $major->[0]);
		return $list ? ($minor, $major) : int((($minor->[2] + $major->[2]) / 2));
	};

	if ($self->{'text'}) {
		$minor[0]++;
		if ($self->{'options'}->{'text_not_null'}) {
			if ($treenode->{'text'} =~ m/(?:\S+)/) {
				$minor[1]++;
			}
			else {
				$minor[3] .= ':text is null where option text_not_null was specified';
			}
		}
		elsif ($self->{'text'} =~ m/^{!(.+)!}/) {
			if ($treenode->{'text'} =~ m/$1/) {
				$minor[1]++;
			}
			else {
				$minor[3] .= ":your regular expression /$1/ did not match the text";
			}
		}
		elsif ($self->{'text'} eq $treenode->{'text'}) {
			$minor[1]++;
		}
		else {
			$minor[3] .= ':unmatched text';
		}
	}

	$_ = \@minor;

	# these are tags which, if out of place, I find to be major errors
	foreach my $j (qw(table td tr tbody map object img body head title html)) {
		if ($self->{'tagname'} eq $j) {
			$_ = \@major; last;
		}
	}

	$_->[0]++;
	if ($similar->($self, $treenode)) {
		$_->[1]++;
	}
	else {
		# optional nodes get special treatment :)
		if ($self->{'options'}->{'optional'}) {
			return 'optional';
		}

		$_->[3] .= ':nodes are not simliar';

		# no point in going on - this node is out of place!
		return $calc->(\@minor, \@major, wantarray);
	}

	unless ($self->{'options'}->{'ignore_attrs'}) {
		foreach (keys %{ $self->{'attr'} }) {
			$minor[0]++;
			if ($self->{'attr'}->{$_} =~ m/^{!(.+)!}/) {
				if ($treenode->{'attr'}->{$_} =~ m/$1/) {
					$minor[1]++;
				}
				else {
					$minor[3] .= ":attribute '$_' could not be matched with /$1/";
				}
			}
			elsif ($self->{'attr'}->{$_} eq $treenode->{'attr'}->{$_}) {
				$minor[1]++;
			}
			else {
				$minor[3] .= ":attribute '$_' could not be matched";
			}
		}
	}

	return $calc->(\@minor, \@major, wantarray);
}

sub _percent {
	my ($div, $by) = @_;
	return 100 if (!$div && !$by);
	return (int(($div /((!$by) ? 1 : $by)) * 100));
}

sub _avg {
	my ($res, $cnt);
	foreach (@_) {
		$res += $_;
		$cnt++;
	}
	return (int($res / $cnt));
}

1;

__END__