File Coverage

blib/lib/HTML/Restrict.pm

Criterion	Covered	Total	%
statement	163	164	99.3
branch	69	80	86.2
condition	19	24	79.1
subroutine	23	23	100.0
pod	1	1	100.0
total	275	292	94.1

use strict;
use 5.006;

package HTML::Restrict;

use version;
our $VERSION = 'v3.0.0';

use Carp qw( croak );
use Data::Dump qw( dump );
use HTML::Parser ();
use HTML::Entities qw( encode_entities );
use Types::Standard 1.000001 qw[ Bool HashRef ArrayRef CodeRef ];
use List::Util 1.33 qw( any none );
use Scalar::Util qw( reftype weaken );
use Sub::Quote 'quote_sub';
use URI ();

use Moo 1.002000;
use namespace::clean;

has allow_comments => (
    is      => 'rw',
    isa     => Bool,
    default => 0,
);

has allow_declaration => (
    is      => 'rw',
    isa     => Bool,
    default => 0,
);

has debug => (
    is      => 'rw',
    isa     => Bool,
    default => 0,
);

has parser => (
    is      => 'ro',
    lazy    => 1,
    builder => '_build_parser',
);

has rules => (
    is       => 'rw',
    isa      => HashRef,
    required => 0,
    default  => quote_sub(q{ {} }),
    trigger  => \&_build_parser,
    reader   => 'get_rules',
    writer   => 'set_rules',
);

has strip_enclosed_content => (
    is      => 'rw',
    isa     => ArrayRef,
    default => sub { [ 'script', 'style' ] },
);

has replace_img => (
    is      => 'rw',
    isa     => Bool | CodeRef,
    default => 0,
);

has trim => (
    is      => 'rw',
    isa     => Bool,
    default => 1,
);

has uri_schemes => (
    is       => 'rw',
    isa      => ArrayRef,
    required => 0,
    default  => sub { [ undef, 'http', 'https' ] },
    reader   => 'get_uri_schemes',
    writer   => 'set_uri_schemes',
);

has _processed => (
    is  => 'rw',
    isa => quote_sub(
        q{
        die "$_[0] is not false or a string!"
            unless !defined($_[0]) || $_[0] eq "" || "$_[0]" eq '0' || ref(\$_[0]) eq 'SCALAR'
    }
    ),
    clearer => '_clear_processed',
);

has _stripper_stack => (
    is      => 'rw',
    isa     => ArrayRef,
    default => sub { [] },
);

sub _build_parser {
    my $self  = shift;
    my $rules = shift;

    # don't allow any upper case tag or attribute names
    # these rules would otherwise silently be ignored
    if ($rules) {
        foreach my $tag_name ( keys %{$rules} ) {
            if ( lc $tag_name ne $tag_name ) {
                croak "All tag names must be lower cased";
            }
            if ( reftype $rules->{$tag_name} eq 'ARRAY' ) {
                my @attr_names;
                foreach my $attr_item ( @{ $rules->{$tag_name} } ) {
                    ref $attr_item eq 'HASH'
                        ? push( @attr_names, keys(%$attr_item) )
                        : push( @attr_names, $attr_item );
                }
                for (@attr_names) {
                    croak "All attribute names must be lower cased"
                        if lc $_ ne $_;
                }
            }
        }
    }

    weaken($self);
    return HTML::Parser->new(
        empty_element_tags => 1,

        start_h => [
            sub {
                my ( $p, $tagname, $attr, $text ) = @_;
                print "starting tag:  $tagname", "\n" if $self->debug;
                my $more = q{};

                if ( any { $_ eq $tagname } keys %{ $self->get_rules } ) {
                    print dump $attr if $self->debug;

                    foreach my $source_type ( 'href', 'src', 'cite' ) {

                        my $link = $attr->{$source_type};

                        # Remove unprintable ASCII control characters, which
                        # are 0..31. These characters are not valid in URLs,
                        # but they can prevent the URI parser from recognizing
                        # the scheme when they are used as leading characters.
                        # Browsers will helpfully ignore some of them, meaning
                        # that some of these characters (particularly 1..8 and
                        # 14..31) can be used to defeat HTML::Restrict when
                        # used as leading characters in a link.  In our case we
                        # will strip them all regardless of where they are in
                        # the URL. See
                        # https://github.com/oalders/html-restrict/issues/30
                        # https://url.spec.whatwg.org/
                        # https://infra.spec.whatwg.org/#c0-control

                        if ($link) {

                            # C0 control chars (decimal 0..31)
                            # sort of like $link =~ s/[[:^print:]]//g
                            $link =~ s/[\00-\037]|&#x?0+;/ /g;

                            my $url = URI->new($link);
                            if ( defined $url->scheme ) {
                                delete $attr->{$source_type}
                                    if none { $_ eq $url->scheme }
                                grep { defined } @{ $self->get_uri_schemes };
                            }
                            else {    # relative URL
                                delete $attr->{$source_type}
                                    unless grep { !defined }
                                    @{ $self->get_uri_schemes };
                            }
                        }
                    }

                    foreach
                        my $attr_item ( @{ $self->get_rules->{$tagname} } ) {
                        if ( ref $attr_item eq 'HASH' ) {

                            # validate or munge with regex or coderef contraints
                            #
                            for my $attr_name (
                                sort grep exists $attr->{$_},
                                keys %$attr_item
                            ) {
                                my $rule  = $attr_item->{$attr_name};
                                my $value = $attr->{$attr_name};
                                if ( ref $rule eq 'CODE' ) {
                                    $value = $rule->($value);
                                    next
                                        if !defined $value;
                                }
                                elsif ( $value =~ $rule ) {

                                    # ok
                                }
                                else {
                                    next;
                                }
                                $more .= qq[ $attr_name="]
                                    . encode_entities($value) . q["];
                            }
                        }
                        else {
                            my $attr_name = $attr_item;
                            if ( exists $attr->{$attr_name} ) {
                                my $value
                                    = encode_entities( $attr->{$attr_name} );
                                $more .= qq[ $attr_name="$value" ]
                                    unless $attr_name eq q{/};
                            }
                        }
                    }

                    # closing slash should (naturally) close the tag
                    if ( exists $attr->{q{/}} && $attr->{q{/}} eq q{/} ) {
                        $more .= ' /';
                    }

                    my $elem = "<$tagname $more>";
                    $elem =~ s{\s*>}{>}gxms;
                    $elem =~ s{\s+}{ }gxms;

                    $self->_processed( ( $self->_processed || q{} ) . $elem );
                }
                elsif ( $tagname eq 'img' && $self->replace_img ) {
                    my $alt;
                    if ( ref $self->replace_img ) {
                        $alt = $self->replace_img->( $tagname, $attr, $text );
                    }
                    else {
                        $alt
                            = defined( $attr->{alt} ) ? ": $attr->{alt}" : "";
                        $alt = "[IMAGE$alt]";
                    }
                    $self->_processed( ( $self->_processed || q{} ) . $alt );
                }
                elsif (
                    any { $_ eq $tagname }
                    @{ $self->strip_enclosed_content }
                ) {
                    print "adding $tagname to strippers" if $self->debug;
                    push @{ $self->_stripper_stack }, $tagname;
                }

            },
            "self,tagname,attr,text"
        ],

        end_h => [
            sub {
                my ( $p, $tagname, $attr, $text ) = @_;
                print "end: $text\n" if $self->debug;
                if ( any { $_ eq $tagname } keys %{ $self->get_rules } ) {
                    $self->_processed( ( $self->_processed || q{} ) . $text );
                }
                elsif ( any { $_ eq $tagname } @{ $self->_stripper_stack } ) {
                    $self->_delete_tag_from_stack($tagname);
                }

            },
            "self,tagname,attr,text"
        ],

        text_h => [
            sub {
                my ( $p, $text ) = @_;
                print "text: $text\n" if $self->debug;
                $text = _fix_text_encoding($text);
                if ( !@{ $self->_stripper_stack } ) {
                    $self->_processed( ( $self->_processed || q{} ) . $text );
                }
            },
            "self,text"
        ],

        comment_h => [
            sub {
                my ( $p, $text ) = @_;
                print "comment: $text\n" if $self->debug;
                if ( $self->allow_comments ) {
                    $self->_processed( ( $self->_processed || q{} ) . $text );
                }
            },
            "self,text"
        ],

        declaration_h => [
            sub {
                my ( $p, $text ) = @_;
                print "declaration: $text\n" if $self->debug;
                if ( $self->allow_declaration ) {
                    $self->_processed( ( $self->_processed || q{} ) . $text );
                }
            },
            "self,text"
        ],

    );
}

sub process {
    my $self = shift;

    # returns undef if no value was passed
    return if !@_;
    return $_[0] if !$_[0];

    my ($content) = @_;
    die 'content must be a string!'
        unless ref( \$content ) eq 'SCALAR';
    $self->_clear_processed;

    my $parser = $self->parser;
    $parser->parse($content);
    $parser->eof;

    my $text = $self->_processed;

    if ( $self->trim && $text ) {
        $text =~ s{\A\s*}{}gxms;
        $text =~ s{\s*\z}{}gxms;
    }
    $self->_processed($text);

    # ensure stripper stack is reset in case of broken html
    $self->_stripper_stack( [] );

    return $self->_processed;
}

# strip_enclosed_content tags could be nested in the source HTML, so we
# maintain a stack of these tags.

sub _delete_tag_from_stack {
    my $self        = shift;
    my $closing_tag = shift;

    my $found    = 0;
    my @tag_list = ();

    foreach my $tag ( reverse @{ $self->_stripper_stack } ) {
        if ( $tag eq $closing_tag && $found == 0 ) {
            $found = 1;
            next;
        }
        push @tag_list, $tag;
    }

    $self->_stripper_stack( [ reverse @tag_list ] );

    return;
}

# regex for entities that don't require a terminating semicolon
my ($short_entity_re)
    = map qr/$_/i,
    join '|',
    '#x[0-9a-f]+',
    '#[0-9]+',
    grep !/;\z/,
    sort keys %HTML::Entities::entity2char;

# semicolon required
my ($complete_entity_re)
    = map qr/$_/i,
    join '|',
    grep /;\z/,
    sort keys %HTML::Entities::entity2char;

sub _fix_text_encoding {
    my $text = shift;
    $text =~ s{
        &
        (?:
          ($short_entity_re);?
        |
          ($complete_entity_re)
        )?
    }{
          defined $1  ? "&$1;"
        : defined $2  ? "&$2"
                      : "&"
    }xgie;
    return encode_entities( $text, '<>' );
}

1;    # End of HTML::Restrict

# ABSTRACT: Strip unwanted HTML tags and attributes

__END__