File Coverage

blib/lib/Mojo/DOM/Role/Restrict.pm

Criterion	Covered	Total	%
statement	86	116	74.1
branch	45	82	54.8
condition	29	36	80.5
subroutine	17	19	89.4
pod	5	7	71.4
total	182	260	70.0

package Mojo::DOM::Role::Restrict;
use strict; use warnings; our $VERSION = 0.04;
use Mojo::Base -role;
use Mojo::Util qw(xml_escape);
use File::Spec;

sub to_string { $_[1] ? ${$_[0]}->render : $_[0]->render; }

sub render { _render($_[0]->tree, $_[0]->xml, $_[0]->restrict_spec) }

around parse => sub {
	my ($orig, $self) = (shift, shift);
	$self->restrict_spec($_[1] || $self->restrict_spec || {
		'*' => { '*' => 1 }
	});
	return $self->$orig(@_);
};

sub restrict_spec {
	if ( $_[1] ) {
		$_[1]->{$_} && ! ref $_[1]->{$_} && do { $_[1]->{$_} = { '*' => 1 } } for (keys %{$_[1]});
		${$_[0]}->{restrict_spec} = $_[1];
	}
	${$_[0]}->{restrict_spec};
}

sub valid { _valid($_[0]->tree, $_[0]->restrict_spec($_[1])) }

sub restrict { _restrict($_[0]->tree, $_[0]->restrict_spec($_[1])) && $_[0] }

sub diff_module {
	if ( $_[1] && $_[0]->diff_module_name !~ $_[1]) {
		$_[0]->diff_module_name($_[1]);
		$_[0]->diff_module_loaded(0);
	}
	$_[0]->diff_module_method($_[2]) if $_[2];
	$_[0]->diff_module_params($_[3]) if defined $_[3];
	return (
		$_[0]->diff_module_name,
		$_[0]->diff_module_method,
		$_[0]->diff_module_params
	);
}

has diff_module_name => 'Text::Diff';

has diff_module_loaded => 0;

has diff_module_method => 'diff';

has diff_module_params => sub {  { style => 'Unified' } };

sub diff {
	my ($self, $spec) = ($_[0], (shift)->restrict_spec(shift));
	my ($module, $method, $params) = $self->diff_module(@_);
	unless ( $self->diff_module_loaded ) {
		my @parts = split /::|'/, $module, -1;
    		shift @parts if @parts && !$parts[0];
    		my $file  =  File::Spec->catfile( @parts );
		LOAD_DIFF_MODULE: {
		    my $err;
		    for my $flag ( qw[1 0] ) {
			my $load = $file . ($flag ? '.pm' : '');
			eval { require $load };
			$@ ? $err .= $@ : last LOAD_DIFF_MODULE;
		    }
		    die $err if $err;
		}
		$self->diff_module_loaded(1)
	}
	{
		no strict 'refs';
		return *{"${module}::${method}"}->(\$self->to_string(1), \$self->to_string(), $params);
	}
}

# copy, paste and edit via Mojo::DOM::HTML::_render

my %EMPTY = map { $_ => 1 } qw(area base br col embed hr img input keygen link menuitem meta param source track wbr);

sub _render {
	my ($tree, $xml, $spec) = @_;

	# Tag
	my $type = $tree->[0];
	if ($type eq 'tag') {

		# Start tag
		my ($tag, $attrs) = _valid_tag($spec, $tree->[1], {%{$tree->[2]}});

		return '' unless $tag;

		my $result = "<$tag";

		# Attributes
		for (sort keys %{$attrs}) {
			my ($key, $value) = _valid_attribute($spec, $tag, $_, $attrs->{$_});
			$result .= defined $value
				? qq{ $key="} . xml_escape($value) . '"'
				: $xml
					? qq{ $key="$key"}
					: " $key"
			if $key;
		}

		# No children
		return $xml ? "$result />" : $EMPTY{$tag} ? "$result>" : "$result>" unless $tree->[4];

		# Children
		no warnings 'recursion';
		$result .= '>' . join '', map { _render($_, $xml, $spec) } @$tree[4 .. $#$tree];

		# End tag
		return "$result";
	}

	# Text (escaped)
	return xml_escape $tree->[1] if $type eq 'text';

	# Raw text
	return $tree->[1] if $type eq 'raw';

	# Root
	return join '', map { _render($_, $xml, $spec) } @$tree[1 .. $#$tree] if $type eq 'root';

	# DOCTYPE
	return '[1] . '>' if $type eq 'doctype';

	# Comment
	return '' if $type eq 'comment';

	# CDATA
	return '[1] . ']]>' if $type eq 'cdata';

	# Processing instruction
	return '[1] . '?>' if $type eq 'pi';

	# Everything else
	return '';
}

sub _valid_tag {
	my ($spec, $tag, $attrs) = @_;
	my $valid = $spec->{$tag} // $spec->{'*'};
	return ref $valid && $valid->{validate_tag}
		? $valid->{validate_tag}($tag, $attrs)
		: $valid
			? ($tag, $attrs)
			: 0;
}

sub _valid_attribute {
	my ($spec, $tag, $attr, $value) = @_;
	my $valid = $spec->{$tag}->{$attr} // $spec->{$tag}->{'*'} // $spec->{'*'}->{$attr} // $spec->{'*'}->{'*'};
	return ref $valid
		? $valid->($attr, $value)
		: ($valid and $valid =~ m/1/ || $value =~ m/$valid/)
			? ( $attr, $value )
			: 0;
}

sub _valid {
	my ($tree, $spec) = @_;
	if ($tree->[0] eq 'tag') {
		my ($tag, $attrs) = _valid_tag($spec, $tree->[1], {%{$tree->[2]}});
		return 0 unless $tag;
		_valid_attribute($spec, $tag, $_, $attrs->{$_}) or return 0
			for (sort keys %{$attrs});
		if ($tree->[4]) {
			_valid($_, $spec) or return 0 for ( @$tree[4 .. $#$tree]  );
		}
	} elsif ($tree->[0] eq 'root') {
		_valid($_, $spec) or return 0 for ( @$tree[1 .. $#$tree] );
	}
	return 1;
}

sub _restrict {
	my ($tree, $spec) = @_;
	if ($tree->[0] eq 'tag') {
		my ($tag, $attrs) = _valid_tag($spec, $tree->[1], $tree->[2]);
		return 0 unless $tag;
		$tree->[1] = $tag;
		for (sort keys %{$attrs}) {
			my ($key, $value) = _valid_attribute($spec, $tag, $_, delete $attrs->{$_});
			$attrs->{$key} = $value if $key;
		}
		if ($tree->[4]) {
			my $i = 4;
			_restrict($_, $spec) ? $i++ : splice(@{$tree}, $i, 1)
				for ( @$tree[$i .. $#$tree]  );
		}
	} elsif ($tree->[0] eq 'root') {
		my $i = 1;
		_restrict($_, $spec) ? $i++ : splice(@{$tree}, $i, 1)
			for ( @$tree[$i .. $#$tree] );
	}
	return 1;
}


1;

# TODO pretty print (for diff) and minmize.

__END__