view release on metacpan or  search on metacpan

lib/Mojo/DOM/Role/Restrict.pm  view on Meta::CPAN

		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></$tag>" unless $tree->[4];

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

		# End tag
		return "$result</$tag>";
	}

	# 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 '<!DOCTYPE' . $tree->[1] . '>' if $type eq 'doctype';

	# Comment
	return '<!--' . $tree->[1] . '-->' if $type eq 'comment';

	# CDATA
	return '<![CDATA[' . $tree->[1] . ']]>' if $type eq 'cdata';

	# Processing instruction
	return '<?' . $tree->[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') {