File Coverage

blib/lib/HTML/ValidationRules/Parser.pm

Criterion	Covered	Total	%
statement	49	50	98.0
branch	16	20	80.0
condition	10	13	76.9
subroutine	9	9	100.0
pod	0	5	0.0
total	84	97	86.6

package HTML::ValidationRules::Parser;
use strict;
use warnings;
use autodie;
use HTML::Parser;

my %ELEMENTS = (
    input => [qw(
        max
        maxlength
        min
        pattern
        required
    ), {
        name   => 'type',
        values => [qw(
            url
            email
            number
            range
        )],
    }],

    textarea => [qw(
        maxlength
        required
    )],

    select => [qw(
        required
    )],
);

my $ELEMENTS_PATTERN = qr/(@{[join '|', (map { quotemeta } keys %ELEMENTS)]})/o;
my %ATTRS_MAP = map {
    my $attr = ref $_ ? $_->{name} : $_;
       $attr => +{ map { $_ => 1 } @{$ELEMENTS{$_}} };
} keys %ELEMENTS;
my %TYPE_ATTR_MAP = map {
    my $attr = $_;
    map { $_ => 1 } @{$attr->{values}};
} grep { ref $_ && $_->{name} eq 'type' } @{$ELEMENTS{input}};

sub new {
    my ($class, %args) = @_;
    bless \%args, $class;
}

sub parser {
    my ($self) = @_;
    $self->{parser} ||= HTML::Parser->new(
        api_version => 3,
        start_h     => [\&start, 'self, tagname, attr, attrseq'],
        %{$self->{options} || {}},
    );
}

sub load_rules {
    my ($self, %args) = @_;
    my $file = delete $args{file};
    my $html = delete $args{html};

    undef $self->parser->{rules};

    if ($file) {
        $self->parser->parse_file($file);
    }
    else {
        $self->parser->parse($html);
        $self->parser->eof;
    }

    $self->parser->{rules};
}

sub start {
    my ($parser, $tag, $attr, $attrseq) = @_;
    return if $tag !~ $ELEMENTS_PATTERN;

    my $name = $attr->{name};
    return if !defined $name;

    my @rules;
    my $attrs = $ATTRS_MAP{lc $tag};

    if (defined $attr->{type} && $TYPE_ATTR_MAP{lc $attr->{type} || ''}) {
        my $type = $attr->{type};
        unshift @rules, key($type);
        $attrseq = [ grep { lc $_ ne 'type' } @$attrseq ];
    }

    for my $key (@{$attrseq || []}) {
        next if !$attrs->{$key};

        my $value = $attr->{$key};
        if (defined $value && $key ne $value) {
            push @rules, [ key($key) => $value ];
        }
        elsif ($key eq $value) {
            push @rules, key($key);
        }
    }

    $parser->{rules} ||= [];
    push @{$parser->{rules}}, $name => \@rules;
}

sub key {
    my $key = shift;
    return 'NOT_BLANK' if $key eq 'required';
    sprintf 'HTML_%s', uc $key;
}

!!1;