package HTML::EscapeEvil;

use strict;
use base qw(HTML::Filter Class::Accessor);
use HTML::Element;

our($ENTITY_REGEXP,%JS_EVENT,$VERSION);

__PACKAGE__->mk_accessors(qw(allow_comment allow_declaration allow_process allow_entity_reference allow_script allow_style collection_process));
__PACKAGE__->mk_ro_accessors(qw(processes));

BEGIN{

	$VERSION = 0.03;

	my @allow_entity_references = ("amp","lt","gt","quot","apos","#039","nbsp","copy","reg");
	$ENTITY_REGEXP = "&amp;(" . (join "|",@allow_entity_references) . ")(;)";

## allow javascript event handler setting
## cite : javascript in href. e.g. <a href="javascript:alert('hello')">hello</a>
	%JS_EVENT = (
				cite			=> 0,
				onblur			=> 0,
				onchange		=> 0,
				onclick			=> 0,
				ondblclick		=> 0,
				onerror			=> 0,
				onfocus			=> 0,
				onkeydown		=> 0,
				onkeypress		=> 0,
				onkeyup			=> 0,
				onload			=> 0,
				onmousedown		=> 0,
				onmousemove		=> 0,
				onmouseout		=> 0,
				onmouseover		=> 0,
				onmouseup		=> 0,
				onreset			=> 0,
				onselect		=> 0,
				onsubmit		=> 0,
				onunload		=> 0,
				);
}

sub new{

	my($class,%args) = @_;
	my $self = $class->SUPER::new;

	foreach(qw(allow_comment allow_declaration allow_process allow_style allow_script collection_process)){

		$self->{$_} = ($args{$_}) ? 1 : 0;
	}

	if($args{allow_entity_reference} ne "" && $args{allow_entity_reference} == 0){
		
		$self->{allow_entity_reference} = 0;
	}else{
		
		$self->{allow_entity_reference} = 1;
	}
	
	$self->{processes} = [];

	$self->{_content} = [];
	$self->{_allow_tags} = {};

	bless $self,ref $class || $class;
	
	if($args{allow_tags}){

		$self->add_allow_tags(
								(ref($args{allow_tags}) eq "ARRAY") ? @{$args{allow_tags}} : $args{allow_tags}
							);
	}

	return $self;
}


sub set_allow_tags{

	my $self = shift;
	$self->{_allow_tags} = {};
	$self->{_current_tag} = undef;

	$self->{allow_script} = 0;
	$self->{allow_style} = 0;
	$self->{allow_comment} = 0;
	$self->{allow_declaration} = 0;
	$self->{allow_process} = 0;
	$self->{allow_entity_reference} = 1;
	$self->{collection_process} = 0;

	$self->clear_content;
	$self->clear_process;
	$self->add_allow_tags(@_);
}

sub add_allow_tags{

	my($self,@tags) = @_;
	foreach my $tag(@tags){

		$tag = lc $tag;
		if($tag eq "script" || $tag eq "style"){

			$self->{"allow_$tag"} = 1;
			next;
		}
		$self->{_allow_tags}->{$tag} = 1;
	}

}

sub deny_tags{

	my($self,@tags) = @_;
	foreach my $tag(@tags){

		$tag = lc $tag;
		if($tag eq "script" || $tag eq "style"){

			$self->{"allow_$tag"} = 0;
			next;
		}
		delete $self->{_allow_tags}->{$tag};
	}
}


sub get_allow_tags{

	my $self = shift;
	my @tags = keys %{$self->{_allow_tags}};
	push @tags,"script" if $self->{allow_script};
	push @tags,"style" if $self->{allow_style};
	return sort {$a cmp $b} @tags;
}

sub is_allow_tags{

	my($self,$tag) = @_;
	my $flag;
	$tag = lc $tag;
	if($tag eq "script" || $tag eq "style"){

		$flag = $self->{"allow_$tag"};
	}else{

		$flag = (exists $self->{_allow_tags}->{$tag}) ? 1 : 0;
	}
	return ($flag) ? 1 : 0;
}


sub deny_all{

	my $self = shift;
	$self->{_allow_tags} = {};
	$self->{_current_tag} = undef;
	$self->{allow_script} = 0;
	$self->{allow_style} = 0;
	$self->{allow_comment} = 0;
	$self->{allow_declaration} = 0;
	$self->{allow_process} = 0;
	$self->{allow_entity_reference} = 0;
}

sub filtered_html{

	my $self = shift;
	my $content = join "",@{$self->{_content}};
	$self->clear_content;
	return $content;
}

sub filtered_file{

	my $self = shift;
	my $fh;
	(ref($_[0]) eq "GLOB" || ref(\$_[0]) eq "GLOB") ? ($fh = $_[0]) : (open $fh,"> $_[0]" or &_croak($!));
	print $fh $self->filtered_html;
	close $fh;
}

sub filtered{

	my $self = shift;
	my $content;
	if(-e $_[0] || ref($_[0]) eq "GLOB" || ref(\$_[0]) eq "GLOB"){

		$self->parse_file($_[0]);
	}elsif($_[0] ne ""){

		$self->parse($_[0]);
	}else{

		&_croak("content is empty");
	}
	
	if($_[1]){

		$self->filtered_file($_[1]);
		$content = 1;
	}else{

		$content = $self->filtered_html;
	}

	$self->eof;
	$self->{_current_tag} = undef;
	
	return $content;
}

sub clear{

	my $self = shift;
	$self->eof;
	$self->clear_process;
	$self->clear_content;
	$self->{_current_tag} = undef;
}

sub clear_content{

	my $self = shift;
	$self->{_content} = [] if scalar @{$self->{_content}};
}

sub clear_process{

	my $self = shift;
	$self->{processes} = [] if scalar @{$self->{processes}};
}

sub DESTROY{

	my $self = shift;
	$self->clear;
}

sub _escape{

	my $string = shift;
	$string =~ s/&/&amp;/g;
	$string =~ s/</&lt;/g;
	$string =~ s/>/&gt;/g;
	$string =~ s/\"/&quot;/g;
	$string =~ s/\'/&#039;/g;
	return $string;
}

sub _unescape{

	my $string = shift;
	$string =~ s/&amp;/&/g;
	$string =~ s/&lt;/</g;
	$string =~ s/&gt;/>/g;
	$string =~ s/&quot;/\"/g;
	$string =~ s/&#039;/\'/g;
	$string =~ s/&apos;/\'/g;
	return $string;
}

sub _unescape_entities{

	my $string = shift;
	$string =~ s/$ENTITY_REGEXP/\&$1$2/g;
	#print $string;
	return $string;
}

sub _croak{

	require Carp;
	Carp->import;
	croak(@_);
}


# ============================== override method start ============================== #

sub declaration{

	my($self,$declaration) = @_;
	$declaration = "<!$declaration>";
	$self->output(($self->{allow_declaration}) ? $declaration : &_escape($declaration));
}

sub process{

	my($self,$process,$process_text) = @_;
	if($self->{collection_process}){

		my $tmp_process = $process;
		$tmp_process =~ s/\?$//;
		push @{$self->{processes}},$tmp_process;
	}
	$self->SUPER::process($process,($self->{allow_process}) ? $process_text : &_escape($process_text));
}

sub start{

	my($self,$tagname,$attr,$attrseq,$text) = @_;
	$self->{_current_tag} = lc $tagname;
	if($self->is_allow_tags($tagname)){

		if(!$self->allow_script){
## change javascript event handler(1 : allow) e.g <body onload="alert(1)"> => <body onload="void(0)">
			foreach(keys %{$attr}){

				my $event = lc $_;
				if(exists $JS_EVENT{$event} && !$JS_EVENT{$event}){
					#delete $attr->{$event};
					$attr->{$event} = "void(0)";
				}
			}

## change javascript <a href="javascript:evil_script('evil')"> => <a href="javascript:void(0)">
			if(!$JS_EVENT{cite} && $attr->{href} =~ /^(java|vb)script:/i){

				$attr->{href} = "javascript:void(0)";
			}
## tag is generated again
			my $element = HTML::Element->new($tagname,%{$attr});
			$text = $element->starttag;
			$element->delete;
			$element = undef;
		}
	}else{
		$text = &_escape($text) 
	}
	$self->SUPER::start($tagname,$attr,$attrseq,$text);
}

sub end{

	my($self,$tagname,$text) = @_;
	$self->{_current_tag} = undef;
	$text = &_escape($text) if !$self->is_allow_tags($tagname);
	$self->SUPER::end($tagname,$text);
}

sub comment{

	my($self,$comment) = @_;
	$comment = "<!--$comment-->";
	$self->output(($self->{allow_comment}) ? $comment : &_escape($comment));
}

sub text{

	my($self,$text,$is_cdata) = @_;
	$text = &_escape($text);
	$text = &_unescape_entities($text) if $self->{allow_entity_reference};
	$text = &_unescape($text) if $is_cdata && $self->{_current_tag} eq "script" && $self->{allow_script};
	$text = &_unescape($text) if $is_cdata && $self->{_current_tag} eq "style" && $self->{allow_style};
	$self->SUPER::text($text,$is_cdata);
}

sub output{

	my($self,$content) = @_;
	push @{$self->{_content}},$content;
}


1;

__END__

=head1 NAME

HTML::EscapeEvil - Escape tag

=head1 VERSION

0.03

=head1 SYNPSIS

    use HTML::EscapeEvil;
    my $escapeevil = HTML::EscapeEvil->new;
    my $evil_html = <<HTML;
    <script type="text/javascript">
    <!--
    alert("script is evil tags!!");
    //-->
    </script>
    <iflame src="deny.html" width="100" height="100"></iframe>
    HTML

    $escapeevil->parse($html); #from string
    $escapeevil->parse_file($html_file); #from file or file handle

    my $clean_html = $escapeevil->filtered_html;
    $escapeevil->clear;

=head1 DESCRIPTION

The tag that doesn't want to permit escapes all.

=head1 METHOD

=head2 new

create instance

Example : 

    my $escapeevil = HTML::EscapeEvil->new(
                                         allow_comment => 1,
                                         allow_declaration => 0,
                                         allow_process => 0,
                                         allow_tags => [qw(a l l o w t a g s)],
                                         #allow_tags => "one",# OK
                                        );

Option :

allow_comment          : allow comment. default 0.

allow_declaration      : allow_declaration. default 0.

allow_process          : allow_process. default 0.

allow_tags             : set allow tags

allow_script           : allow script tag. default 0(is_allow_tags("script") OK)

allow_style            : allow style tag. default 0(is_allow_tags("style") OK)

allow_entity_reference : allow entity reference. default 1

collection_process     : collection process. default 0

When tag is not specified for allow_tags, default makes all tag invalid. 

=head2 set_allow_tags

The setting is returned to default. 

Example : 

    $escapeevil->set_allow_tags(qw(t a g s));

=head2 add_allow_tags

The tag that wants to permit is added. 

Example : 

    $escapeevil->add_allow_tags(qw(t a g s));

=head2 deny_tags

The specified tag is not permitted.

Example : 

    $escapeevil->deny_tags(qw(t a g s));

=head2 get_allow_tags

The list of the tag that has been permitted is returned. 

Example : 

    my @list = $escapeevil->get_allow_tags;

=head2 is_allow_tags

Whether it is tag that has been permitted is checked. 

Example : 

    print 'script is ', ($escapeevil->is_allow_tags('script')) ? 'allowed' : 'not allowed';

=head2 deny_all

No permission of all

Example : 

    $escapeevil->deny_all;

=head2 allow_comment

Whether the comment has been permitted is checked. Or, the setting change of the comment permission. 

Example : 

    print 'comment is ', ($escapeevil->allow_comment) ? 'allowed' : 'not allowed';
    $escapeevil->allow_comment(1); ## allow comment!

=head2 allow_declaration

Whether the DOCTYPE declaration has been permitted is checked. Or, the setting change of the DOCTYPE declaration permission. 

Example : 

    print 'declaration is ', ($escapeevil->allow_declaration) ? 'allowed' : 'not allowed';
    $escapeevil->allow_declaration(1); ## allow declaration!

=head2 allow_process

Whether the processing instruction has been permitted is checked. Or, the setting change of the processing instruction. 

Example : 

    print 'process is ', ($escapeevil->allow_process) ? 'allowed' : 'not allowed';
    $escapeevil->allow_process(1); ## allow process!

=head2 allow_entity_reference

Whether the substance reference has been permitted is checked. Or, the setting change of the substance reference. 

Example : 

    print 'entity_reference is ', ($escapeevil->allow_entity_reference) ? 'allowed' : 'not allowed';
    $escapeevil->allow_entity_reference(1); ## allow entity_reference!

=head2 allow_script

Whether it permits is checked script tag. Or, the setting change of script tag. 

Example : 

    print 'script is ', ($escapeevil->allow_script) ? 'allowed' : 'not allowed';
    $escapeevil->allow_script(1); ## allow script!

=head2 allow_style

Whether it permits is checked style tag. Or, the setting change of style tag. 

Example : 

    print 'style is ', ($escapeevil->allow_style) ? 'allowed' : 'not allowed';
    $escapeevil->allow_style(1); ## allow style!

=head2 collection_process

The setting change whether to collect process is done. Or, a present setting is acquired. 

Example : 

    print 'collection_process is ', ($escapeevil->collection_process) ? 'collection' : 'no collection';
    $escapeevil->collection_process(1); ##colloction process!

=head2 processes

The reference of the array of the processing instruction list is acquired. (reading exclusive use)

Example : 

    foreach(@{$escapeevil->processes}){

        my $process = $_;
        #example: eval $process ,system $process etc..
    }

=head2 filtered_html

HTML that escapes in the tag not permitted is returned. 

Example : 

    print $escapeevil->filetered_html;

=head2 filtered_file

HTML that escapes in the tag not permitted is written file. 

Example : 

    (e.g.1)
    $escapeevil->filtered_file("./filtered_file.html");
    (e.g.2)
    $escapeevil->filtered_file(*FILEHANDLE);

=head2 filtered

version 0.02 new method. parse(parse_file) and filtered_html(filtered_file) and eof,clear_process do.

Example : 

    my $html = "<script type=\"text/javascript\"><!--alert(\"hello!\");//--></script>";
    (e.g.1)
    my $cleanhtml = $escapeevil->filtered($html);
    (e.g.2)
    $escapeevil->filtered($html,"writefile.html");
    (e.g.3)
    open FILEHANDLE,"< evil.html" or die $!;
    $escapeevil->filtered(*FILEHANDLE,"writefile.html");

=head2 clear_process

Collected process is annulled.

Example : 

    $escapeevil->clear_process;

=head2 clear

Initialization of variable that liberates of HTML::Parser object and is internal. Please execute it when processing is completed. 

Example : 

    $escapeevil->clear;

=head1 NEW OPTION

VERSION 0.03.Javascript of event handler becomes invalid at allow_script(0) though event handler of javascript is defined in the tag that has been permitted, too. 

Example : 

    <a href="javascript:alert(1234)">hello</a> => <a href="javascript:void(0)">hello</a>
    <body onload="alert(5678)"> => <body onload="void(0)">

The definition of event handler is described in %HTML::Escape::JS_EVENT.

=head1 CAUTION

Please filtered_file must specify passing the file and specify the correct one. Die is executed when there are neither passing nor a writing authority that cannot be. 

Processes is a method only for reading. When the value is set, die is done. 

Carp http://search.cpan.org/~nwclark/perl-5.8.8/lib/Carp.pm

Class::Accessor http://search.cpan.org/~kasei/Class-Accessor-0.22/lib/Class/Accessor.pm

HTML::Element http://search.cpan.org/~petdance/HTML-Tree-3.1901/lib/HTML/Element.pm

HTML::Filter http://search.cpan.org/~gaas/HTML-Parser-3.46/lib/HTML/Filter.pm

HTML::Parser http://search.cpan.org/~gaas/HTML-Parser-3.46/Parser.pm

=head1 SEE ALSO

L<Carp> L<Class::Accessor> L<HTML::Element> L<HTML::Filter> L<HTML::Parser>

=head1 AUTHOR

Akira Horimoto <kurt0027@gmail.com>

=head1 COPYRIGHT

Copyright (C) 2006 Akira Horimoto

This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself.

=cut
