File Coverage

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

Criterion	Covered	Total	%
statement	80	86	93.0
branch	45	66	68.1
condition	29	30	96.6
subroutine	15	15	100.0
pod	3	5	60.0
total	172	202	85.1

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

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] }

# 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 diff

__END__