File Coverage

blib/lib/HTML/EscapeEvil.pm

Criterion	Covered	Total	%
statement	124	179	69.2
branch	34	58	58.6
condition	16	45	35.5
subroutine	24	29	82.7
pod	18	20	90.0
total	216	331	65.2

package HTML::EscapeEvil;

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

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.05;

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

# ============================================================================= #
# allow javascript event handler setting
# cite : javascript in href. e.g. hello
# ============================================================================= #
    %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/&/&/g;
    $string =~ s/
    $string =~ s/>/>/g;
    $string =~ s/\"/"/g;
    $string =~ s/\'/'/g;
    return $string;
}

sub _unescape {

    my $string = shift;
    $string =~ s/&/&/g;
    $string =~ s/</
    $string =~ s/>/>/g;
    $string =~ s/"/\"/g;
    $string =~ s/'/\'/g;
    $string =~ s/'/\'/g;
    return $string;
}

sub _unescape_entities {

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

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

sub declaration {

    my ( $self, $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  =>
            foreach ( keys %{$attr} ) {

                my $event = lc $_;
                if ( exists $JS_EVENT{$event} && !$JS_EVENT{$event} ) {

                    #delete $attr->{$event};
                    $attr->{$event} = "void(0)";
                }
            }

## change javascript  =>
            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 = "";
    $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__