File Coverage

blib/lib/HTML/Blitz/Parser.pm

Criterion	Covered	Total	%
statement	191	195	98.4
branch	123	158	77.8
condition	19	24	79.1
subroutine	10	10	100.0
pod	0	4	0.0
total	343	391	87.9

# This code can be redistributed and modified under the terms of the GNU Affero
# General Public License as published by the Free Software Foundation, either
# version 3 of the License, or (at your option) any later version.
# See the "COPYING" file for details.
package HTML::Blitz::Parser;
use HTML::Blitz::pragma;
use HTML::Blitz::ParseError ();
use HTML::Blitz::TokenType qw(
    TT_TAG_OPEN
    TT_TAG_CLOSE
    TT_TEXT
    TT_COMMENT
    TT_DOCTYPE
);

our $VERSION = '0.07';

method _fail(
    $msg,
    :$pos       = pos(${$self->{src_ref}}),
    :$width     = 1,
    :$alt_msg   = undef,
    :$alt_pos   = undef,
    :$alt_width = 1,
) {
    die HTML::Blitz::ParseError->new(
        src_name  => $self->{src_name},
        src_ref   => $self->{src_ref},
        msg       => $msg,
        pos       => $pos,
        width     => $width,
        alt_msg   => $alt_msg,
        alt_pos   => $alt_pos,
        alt_width => $alt_width,
    )
}

method throw_for($token, $msg) {
    my $type = $token->{type};
    $self->_fail(
        $msg,
        pos => $token->{pos},
        $type eq TT_TAG_OPEN || $type eq TT_TAG_CLOSE
            ? (width => 1 + ($type eq TT_TAG_CLOSE) + length $token->{name})
            : (),
    );
}

method new($class: $src_name, $src) {
    my $self = bless {
        src_name        => $src_name,
        src_ref         => \$src,
        tag_stack       => [],
        in_foreign_elem => 0,
    }, $class;

    $src =~ s/\r\n?/\n/g;  # normalize newlines
    $src =~ /([\x{d800}-\x{dfff}])/
        and $self->_fail(sprintf("surrogate codepoint U+%04X in input", ord $1), pos => $-[1]);
    $src =~ /(
        [\x{fdd0}-\x{fdef}]
        | [\x{fffe}\x{ffff}]
        | [\x{1fffe}\x{1ffff}]
        | [\x{2fffe}\x{2ffff}]
        | [\x{3fffe}\x{3ffff}]
        | [\x{4fffe}\x{4ffff}]
        | [\x{5fffe}\x{5ffff}]
        | [\x{6fffe}\x{6ffff}]
        | [\x{7fffe}\x{7ffff}]
        | [\x{8fffe}\x{8ffff}]
        | [\x{9fffe}\x{9ffff}]
        | [\x{afffe}\x{affff}]
        | [\x{bfffe}\x{bffff}]
        | [\x{cfffe}\x{cffff}]
        | [\x{dfffe}\x{dffff}]
        | [\x{efffe}\x{effff}]
        | [\x{ffffe}\x{fffff}]
        | [\x{10fffe}\x{10ffff}]
    )/x and $self->_fail(sprintf("non-character codepoint U+%04X in input", ord $1), pos => $-[1]);
    $src =~ /((?![ \t\n\f])[\x00-\x1f\x7f-\x9f])/
        and $self->_fail(sprintf("control character U+%04X in input", ord $1), pos => $-[1]);

    pos($src) = 0;

    $self
}

my %entities;
{
    while (my $line = readline DATA) {
        chomp $line;
        my ($name, $value) = $line =~ /^(\w+) (\d+(?:,\d+)*)\z/a
            or die "Internal error: malformed entitiy definition '$line'";
        $value =~ s/(\d+),?/chr $1/aeg;
        $entities{$name} = $value;
    }
    close DATA;
}

my %void_tags = map +($_ => 1), qw(
    area
    base br
    col
    embed
    hr
    img input
    link
    meta
    source
    track
    wbr

    basefont bgsound
    frame
    keygen
    param
);

my %foreign_tags = map +($_ => 1), qw(
    math
    svg
);

method _consume_entity_maybe($chunk) {
    $chunk eq '&' or return $chunk;

    my $src_ref = $self->{src_ref};
    my $char;

    if ($$src_ref =~ /\G#/gc) {
        if ($$src_ref =~ /\G[xX]/gc) {
            $$src_ref =~ /\G([[:xdigit:]]+)/gc
                or $self->_fail("missing hex digits after '&#x'");
            $char = chr hex $1;
        } else {
            $$src_ref =~ /\G(\d+)/agc
                or $self->_fail("missing digits after '&#'");
            $char = chr $1;
        }
    } else {
        $$src_ref =~ /\G(\w+)/agc
            or $self->_fail("missing character name after '&'");
        $char = $entities{$1}
            // $self->_fail("invalid character reference '$1' after '&'", pos => $-[1], width => length $1 );
    }
    $$src_ref =~ /\G;/gc
        or $self->_fail("missing ';' after character reference");

    $char
}

method current_tag() {
    my $tag_stack = $self->{tag_stack};
    @$tag_stack ? $tag_stack->[-1][0] : ''
}

method parse() {
    my $src_ref = $self->{src_ref};
    my $tag_stack = $self->{tag_stack};

    my $cur_tag = @$tag_stack ? $tag_stack->[-1][0] : '';

    if ($$src_ref =~ /\G\z/) {
        length $cur_tag
            and $self->_fail("unclosed '<$cur_tag>' tag", pos => $tag_stack->[-1][1], width => 1 + length($cur_tag));
        return undef;
    }

    my $pos = pos $$src_ref;

    {
        my $text = '';

        if ($cur_tag eq 'script') {
            my $err = fun () { $self->_fail("unclosed '<$cur_tag>' tag", pos => $tag_stack->[-1][1], width => 1 + length($cur_tag)) };
            SCRIPT_DATA: {
                $$src_ref =~ m{ ( ) | < (/?) script [ \t\n\f/>] }xaaigc or $err->();
                        $match_start = $-[0];
                        if ($1) {
                            redo SCRIPT_DATA;
                        }
                        if (!$2) {
                            $$src_ref =~ m{ (-->) | ] }xaaigc or $err->();
                            if ($1) {
                                redo SCRIPT_DATA;
                            }
                            redo SCRIPT_DATA_ESCAPED;
                        }
                    }
                }
                pos($$src_ref) = $match_start;
            }
            $text = substr $$src_ref, $pos, pos($$src_ref) - $pos;
        } elsif ($cur_tag eq 'style') {
            if ($$src_ref =~ m{\G ( (?: (?! ] ) . )+ ) }xsgc) {
                $text = $1;
            }
        } elsif ($cur_tag eq 'title') {
            while ($$src_ref =~ m{\G ( (?: (?! ] ) [^&] )+ | & ) }xgc) {
                $text .= $self->_consume_entity_maybe($1);
            }
        } elsif ($cur_tag eq 'textarea') {
            while ($$src_ref =~ m{\G ( (?: (?! ] ) [^&] )+ | & ) }xgc) {
                $text .= $self->_consume_entity_maybe($1);
            }
        } else {
            while ($$src_ref =~ /\G ( [^<&]+ | & )/xgc) {
                $text .= $self->_consume_entity_maybe($1);
            }
        }

        if (length $text) {
            return {
                type    => TT_TEXT,
                pos     => $pos,
                content => $text,
            };
        }
    }

    if ($$src_ref =~ /\G
        if ($$src_ref =~ /\G!/gc) {
            if ($$src_ref =~ /\G--/gc) {
                if ($$src_ref =~ /\G(-?>)/) {
                    $self->_fail("improperly closed comment", width => length($1));
                }
                $$src_ref =~ /\G(.*?)(?|--!?>)/sgc
                    or $self->_fail("unterminated comment", pos => $pos, width => 4);
                my ($text, $closer) = ($1, $2);
                if ($closer eq '') {
                    $self->_fail(
                        "improperly closed comment (should be '-->')",
                        pos       => $-[2],
                        width     => length($closer),
                        alt_msg   => "comment starting here",
                        alt_pos   => $pos,
                        alt_width => 4,
                    );
                }
                if ($closer eq '') {
                    $text .= '
                    $closer = '-->';
                }
                return {
                    type    => TT_COMMENT,
                    pos     => $pos,
                    content => $text,
                };
            }

            if ($$src_ref =~ /\Gdoctype/aaigc) {
                $$src_ref =~ /\G[ \t\n\f]+/gc
                    or $self->_fail("missing whitespace after '
                $$src_ref =~ /\Ghtml/aaigc
                    or $self->_fail("invalid non-html doctype");
                $$src_ref =~ /\G[ \t\n\f]*>/gc
                    or $self->_fail("missing '>' after '
                return {
                    type => TT_DOCTYPE,
                    pos  => $pos,
                };
            }

            if ($self->{in_foreign_elem} && $$src_ref =~ /\G\[CDATA\[/gc) {
                my $text_start = $+[0];
                $$src_ref =~ /\]\]>/gc or $self->_fail("missing ']]>' after '
                my $text_end = $-[0];
                return {
                    type    => TT_TEXT,
                    pos     => $text_start,
                    content => substr($$src_ref, $text_start, $text_end - $text_start),
                };
            }

            $self->_fail("invalid declaration (should be '--' or 'DOCTYPE')");
        }

        my $closing = $$src_ref =~ m{\G/}gc;

        $$src_ref =~ m{\G([a-zA-Z][^\s/>[:cntrl:]]*)}gc
            or $self->_fail("invalid tag name");
        (my $name = $1) =~ tr/A-Z/a-z/;

        $$src_ref =~ /\G[ \t\n\f]+/gc;

        my (%attrs, %attr_pos);
        while ($$src_ref =~ m{\G([^\s/>="'<[:cntrl:]]+)}gc) {
            my $apos = $-[1];
            if ($closing) {
                $self->_fail("invalid attribute in end tag ''", pos => $apos, width => length $1);
            }
            (my $attr_name = $1) =~ tr/A-Z/a-z/;

            if (exists $attrs{$attr_name}) {
                $self->_fail("duplicate attribute '$attr_name' in '<$name>' tag", pos => $apos, width => length($attr_name), alt_msg => "first defined here", alt_pos => $attr_pos{$attr_name}, alt_width => length($attr_name));
            }

            $$src_ref =~ /\G[ \t\n\f]+/gc;

            my $attr_value = '';
            if ($$src_ref =~ /\G=[ \t\n\f]*/gc) {
                if ($$src_ref =~ /\G"/gc) {
                    my $qpos = $-[0];
                    my $text = '';
                    while ($$src_ref =~ /\G ( [^"&]+ | & ) /xgc) {
                        $text .= $self->_consume_entity_maybe($1);
                    }
                    $$src_ref =~ /\G"/gc
                        or $self->_fail(q{missing '"' after attribute value}, alt_msg => 'starting here', alt_pos => $qpos);
                    $$src_ref =~ m{\G[^ \t\n\f/>]}
                        and $self->_fail('missing whitespace after attribute value');
                    $attr_value = $text;
                } elsif ($$src_ref =~ /\G'/gc) {
                    my $qpos = $-[0];
                    my $text = '';
                    while ($$src_ref =~ /\G ( [^'&]+ | & ) /xgc) {
                        $text .= $self->_consume_entity_maybe($1);
                    }
                    $$src_ref =~ /\G'/gc
                        or $self->_fail(q{missing "'" after attribute value}, alt_msg => 'starting here', alt_pos => $qpos);
                    $$src_ref =~ m{\G[^ \t\n\f/>]}
                        and $self->_fail('missing whitespace after attribute value');
                    $attr_value = $text;
                } elsif ($$src_ref =~ /\G ( [^ \t\n\f&>"'<=`]+ | & )/xgc) {
                    my $text = '';
                    do {
                        $text .= $self->_consume_entity_maybe($1);
                    } while $$src_ref =~ /\G ( [^ \t\n\f&>"'<=`]+ | & )/xgc;
                    $attr_value = $text;
                } else {
                    $self->_fail("missing attribute value after '='");
                }
            }

            $attrs{$attr_name} = $attr_value;
            $attr_pos{$attr_name} = $apos;

            $$src_ref =~ /\G[ \t\n\f]+/gc;
        }

        $$src_ref =~ m{\G(/?)>}gc
            or $self->_fail("missing '>' at end of tag", alt_msg => 'starting here', alt_pos => $pos, alt_width => 1 + $closing + length($name));
        my $is_self_closing = length $1;

        if ($closing) {
            $is_self_closing and $self->_fail("invalid '/' at end of closing tag ''", pos => $-[1]);
            @$tag_stack
                or $self->_fail("closing tag '' has no corresponding open tag", pos => $pos, width => 1 + 1 + length($name));

            $cur_tag eq $name
                or $self->_fail("closing tag '' does not match current open tag '<$cur_tag>'", pos => $pos, width => 1 + 1 + length($name), alt_msg => 'starting here', alt_pos => $tag_stack->[-1][1], alt_width => 1 + length($cur_tag));

            if ($foreign_tags{$cur_tag}) {
                $self->{in_foreign_elem}--;
            }
            pop @$tag_stack;
            return {
                type => TT_TAG_CLOSE,
                pos  => $pos,
                name => $name,
            };
        }

        my $is_void = $void_tags{$name};
        if ($is_self_closing && !$is_void && !$foreign_tags{$name} && !$self->{in_foreign_elem}) {
            $self->_fail("invalid '/' at end of non-void tag '<$name>'", pos => $-[1], alt_msg => 'starting here', alt_pos => $pos, alt_width => 1 + length($name));
        }
        $is_self_closing ||= $is_void;

        if (!$is_self_closing) {
            push @{$self->{tag_stack}}, [$name, $pos];
            if ($foreign_tags{$name}) {
                $self->{in_foreign_elem}++;
            }
        }

        return {
            type            => TT_TAG_OPEN,
            pos             => $pos,
            name            => $name,
            attrs           => \%attrs,
            is_void         => $is_void,
            is_self_closing => $is_self_closing,
        };
    }

    # uncoverable statement
    die "Internal error: unparsable input '${\substr $$src_ref, pos($$src_ref), 10}'...";
}

1
__DATA__