File Coverage

blib/lib/HTML/Blitz.pm

Criterion	Covered	Total	%
statement	280	292	95.8
branch	135	226	59.7
condition	34	54	62.9
subroutine	34	36	94.4
pod	7	7	100.0
total	490	615	79.6

package HTML::Blitz 0.1001;
use HTML::Blitz::pragma;
use HTML::Blitz::Template ();
use HTML::Blitz::RuleSet ();
use HTML::Blitz::SSSelector ();
use HTML::Blitz::SelectorType qw(
    ST_FALSE
    ST_TAG_NAME
    ST_ATTR_HAS
    ST_ATTR_EQ
    ST_ATTR_PREFIX
    ST_ATTR_SUFFIX
    ST_ATTR_INFIX
    ST_ATTR_LIST_HAS
    ST_ATTR_LANG_PREFIX
    ST_NTH_CHILD
    ST_NTH_CHILD_OF_TYPE

    LT_DESCENDANT
    LT_CHILD
    LT_SIBLING
    LT_ADJACENT_SIBLING
);
use HTML::Blitz::ActionType qw(
    AT_REMOVE_IF
    AT_REPLACE_INNER
    AT_REPLACE_OUTER
    AT_REPEAT_OUTER

    AT_AS_MODIFY_ATTRS
    AT_AS_REPLACE_ATTRS

    AT_A_REMOVE_ATTR
    AT_A_SET_ATTR
    AT_A_MODIFY_ATTR

    AT_P_VARIABLE
    AT_P_IMMEDIATE
    AT_P_TRANSFORM
    AT_P_FRAGMENT
    AT_P_VARHTML
);
use Carp qw(croak);
use Scalar::Util qw(blessed);
use overload ();

method new($class: @rules) {
    my $self = bless {
        ruleset => HTML::Blitz::RuleSet->new,
    }, $class;
    if (@rules && ref($rules[0]) eq 'HASH') {
        my %opt = %{shift @rules};
        $self->set_keep_doctype(delete $opt{keep_doctype}) if exists $opt{keep_doctype};
        $self->set_keep_comments_re(delete $opt{keep_comments_re}) if exists $opt{keep_comments_re};
        $self->set_dummy_marker_re(delete $opt{dummy_marker_re}) if exists $opt{dummy_marker_re};
        croak "Invalid HTML::Blitz option name(s): " . join(", ", sort keys %opt)
            if keys %opt;
    }
    $self->add_rules(@rules);
    $self
}

method set_keep_doctype($val) {
    $self->{ruleset}->set_keep_doctype($val);
}

method set_keep_comments_re($keep_comments_re) {
    $self->{ruleset}->set_keep_comments_re($keep_comments_re);
}

method set_dummy_marker_re($dummy_marker_re) {
    $self->{ruleset}->set_dummy_marker_re($dummy_marker_re);
}

fun _css_unescape($str) {
    $str =~ s{
        \\ (?:
            ( [[:xdigit:]]{1,6} ) (?: \r\n | [ \t\r\n\f] )?+
        |
            ( [^\n\r\f[:xdigit:]] )
        )
    }{
        $2 // do {
            my $n = hex $1;
            $n > 0x10_ffff ? "\x{fffd}" : chr $n
        }
    }xegr
}

fun _css_unescape_string($str) {
    if ($str =~ s/\A"//) {
        $str =~ s/"\z// or die "Internal error: unterminated \" string";
    } else {
        $str =~ s/\A'// or die "Internal error: malformed (unquoted) string: $str";
        $str =~ s/'\z// or die "Internal error: unterminated ' string";
    }
    $str =~ s{
        \\ (?:
            ( [[:xdigit:]]{1,6} ) (?: \r\n | [ \t\r\n\f] )?+
        |
            ( [^\n\r\f[:xdigit:]] )
        |
            ( \r \n?+ | [\n\f] )
        )
    }{
        defined $3 ? '' :
        $2 // do {
            my $n = hex $1;
            $n > 0x10_ffff ? "\x{fffd}" : chr $n
        }
    }xegr
}

my $ws = qr/[ \t\r\n\f]/;
my $nmchar = qr{
    (?:
        [a-zA-Z0-9_\-]
    |
        [^\x00-\x7f]
    |
        \\ [[:xdigit:]]{1,6} (?: \r\n | $ws )?+
    |
        \\ [^\n\r\f[:xdigit:]]
    )
}x;
my $ident = qr{ -?  (?! [0-9\-] ) $nmchar++ }x;
my $string = qr{
    " (?: [^\n\r\f\\"] | \\ (?: \r \n?+ | [^\r[:xdigit:]] | [[:xdigit:]]{1,6} (?: \r\n | $ws )?+ ) | [^\x00-\x7f] )*+ "
|
    ' (?: [^\n\r\f\\'] | \\ (?: \r \n?+ | [^\r[:xdigit:]] | [[:xdigit:]]{1,6} (?: \r\n | $ws )?+ ) | [^\x00-\x7f] )*+ '
}x;

my %attr_op_type = (
    ''  => ST_ATTR_EQ,
    '^' => ST_ATTR_PREFIX,
    '$' => ST_ATTR_SUFFIX,
    '*' => ST_ATTR_INFIX,
    '~' => ST_ATTR_LIST_HAS,
    '|' => ST_ATTR_LANG_PREFIX,
);

my %comb_type = (
    ' ' => LT_DESCENDANT,
    '>' => LT_CHILD,
    '~' => LT_SIBLING,
    '+' => LT_ADJACENT_SIBLING,
);

fun _try_parse_simple_selector($src_ref, :$allow_tag_name) {
    if ($allow_tag_name && $$src_ref =~ /\G(\*|$ident)/gc) {
        return { type => ST_TAG_NAME, name => _css_unescape($1) };
    }

    if ($$src_ref =~ /\G#($nmchar++)/gc) {
        return { type => ST_ATTR_EQ, attr => 'id', value => _css_unescape($1) };
    }

    if ($$src_ref =~ /\G\.($ident)/gc) {
        return { type => ST_ATTR_LIST_HAS, attr => 'class', value => _css_unescape($1) };
    }

    if (
        $$src_ref =~ m{
            \G
            \[ $ws*+
            ($ident) $ws*+
            (?:
                ( [\^\$\*~\|]?+ ) = $ws*+ (?: ($ident) | ($string) ) $ws*+
            )?+
            \]
        }xgc
    ) {
        my ($attr, $op, $val_ident, $val_string) = ($1, $2, $3, $4);
        $attr = _css_unescape $attr;
        $attr =~ tr/A-Z/a-z/;
        if (!defined $op) {
            return { type => ST_ATTR_HAS, attr => $attr };
        }

        my $value = defined($val_ident) ? _css_unescape($val_ident) : _css_unescape_string($val_string);
        if (
            ($op eq '~' && ($value eq '' || $value =~ /$ws/)) ||
            ($op =~ /\A[\^\$*]\z/ && $value eq '')
        ) {
            return { type => ST_FALSE };
        }
        return { type => $attr_op_type{$op}, attr => $attr, value => $value };
    }

    if ($$src_ref =~ /\G:(nth-child|nth-of-type())\(/iaagc) {
        my $pos = $-[0];
        my $name = $1;
        my $type = defined $2 ? ST_NTH_CHILD_OF_TYPE : ST_NTH_CHILD;
        $$src_ref =~ /\G$ws++/gc;
        $$src_ref =~ m{
            \G
            (
                ( [\-+]? [0-9]* ) [Nn] (?: $ws*+ ([\-+]) $ws*+ ([0-9]+) )?+
            |
                [\-+]? [0-9]+
            |
                [Oo][Dd][Dd]
            |
                [Ee][Vv][Ee][Nn]
            )
        }xgc
            or croak "Bad argument to :$name(): " . substr($$src_ref, $pos, 100);
        my ($arg, $num1, $sign, $num2) = ($1, $2, $3, $4);
        $$src_ref =~ /\G$ws++/gc;
        $$src_ref =~ /\G\)/gc
            or croak "Missing ')' after argument to :$name(): " . substr($$src_ref, $pos, 100);

        if (defined $num1) {
            if ($num1 eq '+' || $num1 eq '') {
                $num1 = 1;
            } elsif ($num1 eq '-') {
                $num1 = -1;
            } else {
                $num1 = 0 + $num1;
            }
            if (defined $sign) {
                $num2 = 0 + $num2;
                $num2 = -$num2 if $sign eq '-';
            } else {
                $num2 = 0;
            }
        } elsif (lc($arg) eq 'odd') {
            $num1 = 2;
            $num2 = 1;
        } elsif (lc($arg) eq 'even') {
            $num1 = 2;
            $num2 = 0;
        } else {
            $num1 = 0;
            $num2 = 0 + $arg;
        }
        return { type => $type, a => $num1, b => $num2 };
    }

    if ($$src_ref =~ /\G:first-child(?![^.#:\[\]),>~ \t\r\n\f])/iaagc) {
        return { type => ST_NTH_CHILD, a => 0, b => 1 };
    }

    if ($$src_ref =~ /\G:first-of-type(?![^.#:\[\]),>~ \t\r\n\f])/iaagc) {
        return { type => ST_NTH_CHILD_OF_TYPE, a => 0, b => 1 };
    }

    if ($$src_ref =~ /\G:($ident)/gc) {
        croak "Unsupported pseudo-class :$1";
    }

    undef
}

fun _parse_selector($src) {
    croak "Invalid selector: $src" if ref $src;

    my @alternatives;
    my $sequences = [];
    my $simples = [];

    pos($src) = 0;
    $src =~ /\G$ws++/gc;

    while () {
        if ($src =~ /\G:not\(/iaagc) {
            my $pos = $-[0];
            $src =~ /\G$ws++/gc;
            my $simple = _try_parse_simple_selector \$src, allow_tag_name => 1
                or croak "Unparsable selector in argument to ':not()': " . substr($src, $pos, 100);
            $src =~ /\G$ws++/gc;
            $src =~ /\G\)/gc
                or croak "Missing ')' after argument to ':not(': " . substr($src, pos($src), 100);
            $simple->{negated} = 1;
            push @$simples, $simple;
        } elsif (defined(my $simple = _try_parse_simple_selector \$src, allow_tag_name => !@$simples)) {
            push @$simples, $simple;
        } elsif ($src =~ /\G(?>$ws*([>~+])|$ws)$ws*+/gc) {
            my $comb = $1 // ' ';
            @$simples
                or croak "Selector list before '$comb' cannot be empty: " . substr($src, $-[0], 100);
            push @$sequences, HTML::Blitz::SSSelector->new(
                simple_selectors => $simples,
                link_type        => $comb_type{$comb},
            );
            $simples = [];
        } elsif ($src =~ /\G,$ws*+/gc) {
            @$simples
                or croak "Selector list before ',' cannot be empty: " . substr($src, $-[0], 100);
            push @$sequences, HTML::Blitz::SSSelector->new(
                simple_selectors => $simples,
                link_type        => undef,
            );
            $simples = [];
            push @alternatives, $sequences;
            $sequences = [];
        } else {
            last;
        }
    }

    $src =~ /\G$ws*+\z/
        or croak "Unparsable selector: " . substr($src, pos($src), 100);
    @$simples
        or croak
            @$sequences ? "Trailing combinator after last selector list" :
            @alternatives ? "trailing comma after last selector list" :
            "Selector cannot be empty";

    push @$sequences, HTML::Blitz::SSSelector->new(
        simple_selectors => $simples,
        link_type        => undef,
    );
    push @alternatives, $sequences;
    \@alternatives
}

fun _text($str) {
    +{ type => AT_P_IMMEDIATE, value => '' . $str }
}

fun _varify($throw, $var) {
    $var =~ /\A[^\W\d][\w\-.]*\z/ or $throw->("Invalid variable name '$var'");
    [undef, $var]
}

fun _var($throw, $var) {
    +{ type => AT_P_VARIABLE, value => _varify($throw, $var) }
}

fun _is_callable($val) {
    ref($val) eq 'CODE' ||
    (blessed($val) && overload::Method($val, '&{}'))
}

fun _template($throw, $val) {
    blessed($val) && $val->isa('HTML::Blitz::Template')
        or $throw->("Argument must be an instance of HTML::Blitz::Template: '$val'");
    +{ type => AT_P_FRAGMENT, value => $val->_codegen }
}

fun _dyn_builder($throw, $var) {
    +{ type => AT_P_VARHTML, value => _varify($throw, $var) }
}

my %_nop = (
    type    => AT_REPLACE_INNER,
    attrset => {
        type    => AT_AS_MODIFY_ATTRS,
        content => {},
    },
    content => undef,
    repeat  => [],
);

fun _id($x) { $x }

fun _mk_transform_attr($attr, $fn) {
    +{
        %_nop,
        attrset => {
            type    => AT_AS_MODIFY_ATTRS,
            content => {
                $attr => {
                    type  => AT_A_MODIFY_ATTR,
                    param => { type => AT_P_TRANSFORM, static => $fn, dynamic => [] },
                },
            },
        },
    }
}

fun _attr_add_word($throw, $attr, @words) {
    for my $word (@words) {
        $throw->("Argument cannot contain whitespace: '$word'")
            if $word =~ /[ \t\r\n\f]/;
    }
    _mk_transform_attr $attr, fun ($value) {
        my (@list, %seen);
        for my $word (($value // '') =~ /[^ \t\r\n\f]+/g, @words) {
            push @list, $word if !$seen{$word}++;
        }
        join ' ', @list
    }
}

fun _attr_remove_word($throw, $attr, @words) {
    my %banned;
    for my $word (@words) {
        $throw->("Argument cannot contain whitespace: '$word'")
            if $word =~ /[ \t\r\n\f]/;
        $banned{$word} = 1;
    }
    _mk_transform_attr $attr, fun ($value) {
        my @list;
        my $new_value = join ' ', grep !$banned{$_}, ($value // '') =~ /[^ \t\r\n\f]+/g;
        length $new_value ? $new_value : undef
    }
}

my %actions = (
    remove => fun ($throw, @args) {
        $throw->("Expected 0 arguments, got " . @args)
            if @args != 0;
        +{ type => AT_REPLACE_OUTER, param => _text('') }
    },

    remove_inner => fun ($throw, @args) {
        $throw->("Expected 0 arguments, got " . @args)
            if @args != 0;
        +{ %_nop, content => _text('') }
    },

    remove_if => fun ($throw, @args) {
        $throw->("Expected 1 argument, got " . @args)
            if @args != 1;
        my $var = _varify $throw, $args[0];
        +{ type => AT_REMOVE_IF, cond => [$var], else => undef }
    },

    replace_inner_text => fun ($throw, @args) {
        $throw->("Expected 1 argument, got " . @args)
            if @args != 1;
        +{ %_nop, content => _text($args[0]) }
    },

    replace_inner_var => fun ($throw, @args) {
        $throw->("Expected 1 argument, got " . @args)
            if @args != 1;
        +{ %_nop, content => _var($throw, $args[0]) }
    },

    replace_inner_template => fun ($throw, @args) {
        $throw->("Expected 1 argument, got " . @args)
            if @args != 1;
        +{ %_nop, content => _template($throw, $args[0]) }
    },

    #replace_inner_builder => fun ($throw, @args) {
    #    $throw->("Expected 1 argument, got " . @args)
    #        if @args != 1;
    #    +{ %_nop, content => _builder($throw, $args[0]) }
    #},

    replace_inner_dyn_builder => fun ($throw, @args) {
        $throw->("Expected 1 argument, got " . @args)
            if @args != 1;
        +{ %_nop, content => _dyn_builder($throw, $args[0]) }
    },

    replace_outer_text => fun ($throw, @args) {
        $throw->("Expected 1 argument, got " . @args)
            if @args != 1;
        +{ type => AT_REPLACE_OUTER, param => _text($args[0]) }
    },

    replace_outer_var => fun ($throw, @args) {
        $throw->("Expected 1 argument, got " . @args)
            if @args != 1;
        +{ type => AT_REPLACE_OUTER, param => _var($throw, $args[0]) }
    },

    replace_outer_template => fun ($throw, @args) {
        $throw->("Expected 1 argument, got " . @args)
            if @args != 1;
        +{ type => AT_REPLACE_OUTER, param => _template($throw, $args[0]) }
    },

    #replace_outer_builder => fun ($throw, @args) {
    #    $throw->("Expected 1 argument, got " . @args)
    #        if @args != 1;
    #    +{ type => AT_REPLACE_OUTER, param => _builder($throw, $args[0]) }
    #},

    replace_outer_dyn_builder => fun ($throw, @args) {
        $throw->("Expected 1 argument, got " . @args)
            if @args != 1;
        +{ type => AT_REPLACE_OUTER, param => _dyn_builder($throw, $args[0]) }
    },

    transform_inner_sub => fun ($throw, @args) {
        $throw->("Expected 1 argument, got " . @args)
            if @args != 1;
        my $fn = $args[0];
        _is_callable $fn
            or $throw->("Argument must be a function");
        +{ %_nop, content => { type => AT_P_TRANSFORM, static => $fn,  dynamic => [] } }
    },

    transform_inner_var => fun ($throw, @args) {
        $throw->("Expected 1 argument, got " . @args)
            if @args != 1;
        my $var = _varify $throw, $args[0];
        +{ %_nop, content => { type => AT_P_TRANSFORM, static => \&_id,  dynamic => [$var] } }
    },

    transform_outer_sub => fun ($throw, @args) {
        $throw->("Expected 1 argument, got " . @args)
            if @args != 1;
        my $fn = $args[0];
        _is_callable $fn
            or $throw->("Argument must be a function");
        +{ type => AT_REPLACE_OUTER, param => { type => AT_P_TRANSFORM, static => $fn,  dynamic => [] } }
    },

    transform_outer_var => fun ($throw, @args) {
        $throw->("Expected 1 argument, got " . @args)
            if @args != 1;
        my $var = _varify $throw, $args[0];
        +{ type => AT_REPLACE_OUTER, param => { type => AT_P_TRANSFORM, static => \&_id,  dynamic => [$var] } }
    },

    remove_attribute => fun ($throw, @args) {
        +{ %_nop, attrset => { type => AT_AS_MODIFY_ATTRS, content => { map +($_ => { type => AT_A_REMOVE_ATTR }), @args } } }
    },

    replace_all_attributes => fun ($throw, @args) {
        $throw->("Expected 1 argument, got " . @args)
            if @args != 1;
        my $attr = $args[0];
        +{
            %_nop,
            attrset => {
                type    => AT_AS_REPLACE_ATTRS,
                content => {
                    map {
                        my $v = $attr->{$_};
                        ref($v) eq 'ARRAY'
                            or $throw->("Attribute replacement value must be an array reference, not '$v'");
                        @$v == 2
                            or $throw->("Attribute replacement value must have 2 elements, not " . @$v);
                        $_ =>
                            $v->[0] eq 'text' ? _text($v->[1]) :
                            $v->[0] eq 'var' ? _var($throw, $v->[1]) :
                            $throw->("Invalid attribute replacement type (must be 'text' or 'var'): '$v->[0]'")
                    } keys %$attr
                },
            },
        }
    },

    remove_all_attributes => fun ($throw, @args) {
        $throw->("Expected 0 arguments, got " . @args)
            if @args != 0;
        +{ %_nop, attrset => { type => AT_AS_REPLACE_ATTRS, content => {} } }
    },

    set_attribute_text => fun ($throw, @args) {
        $throw->("Expected 1 or 2 arguments, got " . @args)
            if @args < 1 || @args > 2;
        if (@args == 1) {
            ref(my $attr = $args[0]) eq 'HASH'
                or $throw->(ref $args[0] ? "Invalid reference type (must be HASH): $args[0]" : "Missing value for attribute '$args[0]'");
            return +{ %_nop, attrset => { type => AT_AS_MODIFY_ATTRS, content => { map +($_ => { type => AT_A_SET_ATTR, param => _text($attr->{$_}) }), keys %$attr } } };
        }
        +{ %_nop, attrset => { type => AT_AS_MODIFY_ATTRS, content => { $args[0] => { type => AT_A_SET_ATTR, param => _text($args[1]) } } } }
    },

    set_attribute_var => fun ($throw, @args) {
        $throw->("Expected 1 or 2 arguments, got " . @args)
            if @args < 1 || @args > 2;
        if (@args == 1) {
            ref(my $attr = $args[0]) eq 'HASH'
                or $throw->(ref $args[0] ? "Invalid reference type (must be HASH): $args[0]" : "Missing value for attribute '$args[0]'");
            return +{ %_nop, attrset => { type => AT_AS_MODIFY_ATTRS, content => { map +($_ => { type => AT_A_SET_ATTR, param => _var($throw, $attr->{$_}) }), keys %$attr } } };
        }
        +{ %_nop, attrset => { type => AT_AS_MODIFY_ATTRS, content => { $args[0] => { type => AT_A_SET_ATTR, param => _var($throw, $args[1]) } } } }
    },

    set_attributes => fun ($throw, @args) {
        $throw->("Expected 1 argument, got " . @args)
            if @args != 1;
        my $attr = $args[0];
        +{
            %_nop,
            attrset => {
                type    => AT_AS_MODIFY_ATTRS,
                content => {
                    map {
                        my $v = $attr->{$_};
                        ref($v) eq 'ARRAY'
                            or $throw->("Attribute replacement value must be an array reference, not '$v'");
                        @$v == 2
                            or $throw->("Attribute replacement value must have 2 elements, not " . @$v);
                        $_ => {
                            type  => AT_A_SET_ATTR,
                            param =>
                                $v->[0] eq 'text' ? _text($v->[1]) :
                                $v->[0] eq 'var' ? _var($throw, $v->[1]) :
                                $throw->("Invalid attribute replacement type (must be 'text' or 'var'): '$v->[0]'")
                        }
                    } keys %$attr
                },
            },
        }
    },

    transform_attribute_sub => fun ($throw, @args) {
        $throw->("Expected 2 arguments, got " . @args)
            if @args != 2;
        my ($attr, $fn) = @args;
        _is_callable $fn
            or $throw->("Argument must be a function");
        _mk_transform_attr $attr, $fn
    },

    transform_attribute_var => fun ($throw, @args) {
        $throw->("Expected 2 arguments, got " . @args)
            if @args != 2;
        my ($attr, $var) = @args;
        $var = _varify $throw, $var;
        +{
            %_nop,
            attrset => {
                type    => AT_AS_MODIFY_ATTRS,
                content => {
                    $attr => {
                        type  => AT_A_MODIFY_ATTR,
                        param => { type => AT_P_TRANSFORM, static => \&_id, dynamic => [$var] },
                    },
                },
            },
        }
    },

    add_attribute_word => fun ($throw, @args) {
        $throw->("Expected 2 or more arguments, not " . @args)
            if @args < 2;
        _attr_add_word $throw, @args
    },

    remove_attribute_word => fun ($throw, @args) {
        $throw->("Expected 2 or more arguments, not " . @args)
            if @args < 2;
        _attr_remove_word $throw, @args
    },

    add_class => fun ($throw, @args) {
        $throw->("Expected 1 or more arguments, not " . @args)
            if @args < 1;
        _attr_add_word $throw, 'class', @args
    },

    remove_class => fun ($throw, @args) {
        $throw->("Expected 1 or more arguments, not " . @args)
            if @args < 1;
        _attr_remove_word $throw, 'class', @args
    },

    repeat_outer => fun ($throw, @args) {
        $throw->("Expected 1 or more arguments, not " . @args)
            if @args < 1;
        my $var = _varify $throw, shift @args;
        my @inplace;
        if (@args && ref($args[0]) eq 'REF' && ref(${$args[0]}) eq 'ARRAY') {
            my $actions = ${shift @args};
            @inplace = map _parse_action(fun ($err) { $throw->("Root action: $err") }, $_), ref($actions->[0]) ? @$actions : $actions;
        }
        my @rules;
        for my $proto (@args) {
            my ($selector, $actions) = _parse_rule($proto);
            push @rules, [$selector, @$actions]
                if @$actions;
        }
        +{ type => AT_REPEAT_OUTER, var => $var, inplace => \@inplace, nested => \%_nop, rules => \@rules }
    },

    repeat_inner => fun ($throw, @args) {
        $throw->("Expected 1 or more arguments, not " . @args)
            if @args < 1;
        my $var = _varify $throw, shift @args;
        my @rules;
        for my $proto (@args) {
            my ($selector, $actions) = _parse_rule($proto, custom_action => {
                separator => fun ($throw, @args) {
                    $throw->("Expected 0 arguments, got " . @args)
                        if @args != 0;
                    +{ type => AT_REMOVE_IF, else => undef, cond => [[undef, \'iter0']] }
                },
            });
            push @rules, [$selector, @$actions]
                if @$actions;
        }
        +{ %_nop, repeat => [{ var => $var, rules => \@rules }] }
    },
);

fun _parse_action($throw, $action_proto, $custom_action = {}) {
    ref($action_proto) eq 'ARRAY'
        or $throw->("Not an ARRAY reference: '$action_proto'");
    @$action_proto
        or $throw->("Action cannot be empty");
    my ($type, @args) = @$action_proto;
    my $action_fn = $custom_action->{$type} // $actions{$type} // $throw->("Unknown action type '$type'" . ($type eq 'seperator' && $custom_action->{separator} ? " (did you mean 'separator'?)" : ""));
    $action_fn->(fun ($err) { $throw->("'$type': $err"); }, @args)
}

fun _parse_rule($proto, :$custom_action = {}) {
    my ($sel_str, @action_protos) = @$proto;
    my $selector = _parse_selector $sel_str;
    my @actions = map _parse_action(fun ($err) { croak "Invalid action for '$sel_str': $err" }, $_, $custom_action), @action_protos;
    $selector, \@actions
}

method add_rules(@rules) {
    my $ruleset = $self->{ruleset};
    for my $rule (@rules) {
        my ($selector, $actions) = _parse_rule $rule;
        $ruleset->add_rule($selector, @$actions)
            if @$actions;
    }
}

method apply_to_html($name, $html) {
    HTML::Blitz::Template->new(_codegen => $self->{ruleset}->compile($name, $html))
}

method apply_to_file($file) {
    my $html = do {
        open my $fh, '<:encoding(UTF-8)', $file
            or croak "Can't open $file: $!";
        local $/;
        readline $fh
    };
    $self->apply_to_html($file, $html)
}

1
__END__