package Mojo::DOM::Role::Restrict;
use strict; use warnings; our $VERSION = 0.01;
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] || {
		'*' => { '*' => 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};
}

# 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], {%{$tree->[2]}});
		
		return '' unless $tag;
	
		my $result = "<$tag";

		# Attributes
		for (sort keys %{$attrs}) {
			my ($key, $value) = _valid_attribute($spec, $tag, $_, $tree->[2]{$_});
			$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;
}

1;

__END__

=head1 NAME

Mojo::DOM::Role::Restrict - The great new Mojo::DOM::Role::Restrict!

=head1 VERSION

Version 0.01

=cut

=head1 SYNOPSIS

	use Mojo::DOM;

	my $html = q|<html><head><script>...</script></head><body><p class="okay" id="allow" onclick="not-allow">Restrict <span class="not-okay">HTML</span></p></body></html>|;

	my $spec = {
		script => 0, # remove all script tags
		'*' => { # apply to all tags
			'*' => 1, # allow all attributes by default
			'onclick' => 0 # disable onclick attributes
		},
		span => {
			class => 0 # disable class attributes on span's
		}
	};

	#<html><head></head><body><p class="okay" id="allow">Restrict <span>HTML</span></p></body></html>
	print Mojo::DOM->with_roles('+Restrict')->new($html, $spec);


=head1 SUBROUTINES/METHODS

=head2 restrict_spec

Retrieve/Set the specification used to restrict the HTML.

	my $spec = $self->restrict_spec;

	$dom->restrict_spec($spec);

=cut

=head1 AUTHOR

LNATION, C<< <email at lnation.org> >>

=head1 BUGS

Please report any bugs or feature requests to C<bug-mojo-dom-role-restrict at rt.cpan.org>, or through
the web interface at L<https://rt.cpan.org/NoAuth/ReportBug.html?Queue=Mojo-DOM-Role-Restrict>.  I will be notified, and then you'll
automatically be notified of progress on your bug as I make changes.

=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc Mojo::DOM::Role::Restrict

You can also look for information at:

=over 4

=item * RT: CPAN's request tracker (report bugs here)

L<https://rt.cpan.org/NoAuth/Bugs.html?Dist=Mojo-DOM-Role-Restrict>

=item * CPAN Ratings

L<https://cpanratings.perl.org/d/Mojo-DOM-Role-Restrict>

=item * Search CPAN

L<https://metacpan.org/release/Mojo-DOM-Role-Restrict>

=back

=head1 ACKNOWLEDGEMENTS

=head1 LICENSE AND COPYRIGHT

This software is Copyright (c) 2021 by LNATION.

This is free software, licensed under:

  The Artistic License 2.0 (GPL Compatible)

=cut

1; # End of Mojo::DOM::Role::Restrict
