File Coverage

blib/lib/Language/Expr/Parser.pm

Criterion	Covered	Total	%
statement	15	97	15.4
branch	3	40	7.5
condition	1	53	1.8
subroutine	3	3	100.0
pod	1	1	100.0
total	23	194	11.8

package Language::Expr::Parser;

our $DATE = '2016-07-01'; # DATE
our $VERSION = '0.28'; # VERSION

use 5.010001;
# now can't compile with this on?
#use strict;
#use warnings;

use Regexp::Grammars;

require Exporter;
our @ISA = qw(Exporter);
our @EXPORT_OK = qw(parse_expr);

my $MAX_LEVELS = 3;

# WARN: this is not thread-safe!?
our $obj;

sub parse_expr {
    my ($str, $obj_arg, $level) = @_;

    $level //= 0;
    die "Recursion level ($level) too deep (max $MAX_LEVELS)" if $level >= $MAX_LEVELS;

    # WARN: this is not thread-safe!?
    local $subexpr_stack = [];

    # create not just 1 but 0..$MAX_LEVELS-1 of grammar objects, each
    # for each recursion level (e.g. for map/grep/usort), fearing that
    # the grammar is not reentrant. but currently no luck yet, still
    # results in segfault/bus error.

    state $grammars = [ map { qr{
                ^\s*<answer>\s*$

                <rule: answer>
                        <MATCH=or_xor>

# precedence level: left     =>
                <rule: pair>
                        <key=(\w++)> =\> <value=answer>
                        (?{ $MATCH = $obj->rule_pair_simple(match=>\%MATCH) })
                    | <key=squotestr> =\> <value=answer>
                        (?{ $MATCH = $obj->rule_pair_string(match=>\%MATCH) })
                    | <key=dquotestr> =\> <value=answer>
                        (?{ $MATCH = $obj->rule_pair_string(match=>\%MATCH) })

# precedence level: left     || // ^^
                <rule: or_xor>
                        <[operand=ternary]> ** <[op=(\|\||//|\^\^)]>
                        (?{
                                if ($MATCH{op} && @{ $MATCH{op} }) {
                                        $MATCH = $obj->rule_or_xor(match=>\%MATCH);
                                } else {
                                        $MATCH = $MATCH{operand}[0];
                                }
                        })

# precedence level: right    ?:
                <rule: ternary>
                        <[operand=and]> ** <[op=(\?|:)]>
                        (?{
                                if ($MATCH{op} && @{ $MATCH{op} }) {
                                        unless (@{ $MATCH{op} } == 2 &&
                                                        $MATCH{op}[0] eq '?' &&
                                                        $MATCH{op}[1] eq ':') {
                                                die "Invalid syntax for ternary, please use X ? Y : Z syntax";
                                        }
                                        $MATCH = $obj->rule_ternary(match=>\%MATCH);
                                } else {
                                        $MATCH = $MATCH{operand}[0];
                                }
                        })

# precedence level: left     &&
                <rule: and>
                        <[operand=bit_or_xor]> ** <[op=(&&)]>
                        (?{
                                if ($MATCH{op} && @{ $MATCH{op} }) {
                                        $MATCH = $obj->rule_and(match=>\%MATCH);
                                } else {
                                        $MATCH = $MATCH{operand}[0];
                                }
                        })

# precedence level: left     | ^
                <rule: bit_or_xor>
                        <[operand=bit_and]> ** <[op=(\||\^)]>
                        (?{
                                if ($MATCH{op} && @{ $MATCH{op} }) {
                                        $MATCH = $obj->rule_bit_or_xor(match=>\%MATCH);
                                } else {
                                        $MATCH = $MATCH{operand}[0];
                                }
                        })

# precedence level: left     &
                <rule: bit_and>
                        <[operand=comparison3]> ** <[op=(&)]>
                        (?{
                                if ($MATCH{op} && @{ $MATCH{op} }) {
                                        $MATCH = $obj->rule_bit_and(match=>\%MATCH);
                                } else {
                                        $MATCH = $MATCH{operand}[0];
                                }
                        })

                        # NOTE: \x3c = "<", \x3e = ">"

# precedence level: nonassoc (currently the grammar says assoc) <=> cmp
                <rule: comparison3>
                        <[operand=comparison]> ** <[op=(\x3c=\x3e|cmp)]>
                        (?{
                                if ($MATCH{op} && @{ $MATCH{op} }) {
                                        $MATCH = $obj->rule_comparison3(match=>\%MATCH);
                                } else {
                                        $MATCH = $MATCH{operand}[0];
                                }
                        })

# precedence level: left == != eq ne < > <= >= ge gt le lt
                <rule: comparison>
                        <[operand=bit_shift]> ** <[op=(==|!=|eq|ne|\x3c=?|\x3e=?|lt|gt|le|ge)]>
                        (?{
                                if ($MATCH{op} && @{ $MATCH{op} }) {
                                        $MATCH = $obj->rule_comparison(match=>\%MATCH);
                                } else {
                                        $MATCH = $MATCH{operand}[0];
                                }
                        })

# precedence level: left     << >>
                <rule: bit_shift>
                        <[operand=add]> ** <[op=(\x3c\x3c|\x3e\x3e)]>
                        (?{
                                if ($MATCH{op} && @{ $MATCH{op} }) {
                                        $MATCH = $obj->rule_bit_shift(match=>\%MATCH);
                                } else {
                                        $MATCH = $MATCH{operand}[0];
                                }
                        })

# precedence level: left     + - .
                <rule: add>
                        <[operand=mult]> ** <[op=(\+|-|\.)]>
                        (?{
                                if ($MATCH{op} && @{ $MATCH{op} }) {
                                        $MATCH = $obj->rule_add(match=>\%MATCH);
                                } else {
                                        $MATCH = $MATCH{operand}[0];
                                }
                        })

# precedence level: left     * / % x
                <rule: mult>
                        <[operand=unary]> ** <[op=(\*|/|%|x)]>
                        (?{
                                if ($MATCH{op} && @{ $MATCH{op} }) {
                                        $MATCH = $obj->rule_mult(match=>\%MATCH);
                                } else {
                                        $MATCH = $MATCH{operand}[0];
                                }
                        })

# precedence level: right    ! ~ unary+ unary-
                <rule: unary>
                        <[op=(!|~|\+|-)]>* <operand=power>
                        (?{
                                if ($MATCH{op} && @{ $MATCH{op} }) {
                                        $MATCH = $obj->rule_unary(match=>\%MATCH);
                                } else {
                                        $MATCH = $MATCH{operand};
                                }
                        })

# precedence level: right    **
                <rule: power>
                        <[operand=subscripting]> ** <[op=(\*\*)]>
                        (?{
                                if ($MATCH{op} && @{ $MATCH{op} }) {
                                        $MATCH = $obj->rule_power(match=>\%MATCH);
                                } else {
                                        $MATCH = $MATCH{operand}[0];
                                }
                        })

# precedence level: left    hash[s], array[i]
                <rule: subscripting>
                        <operand=var0> <[subscript]>*
                        (?{
                                if ($MATCH{subscript} && @{ $MATCH{subscript} }) {
                                        $MATCH = $obj->rule_subscripting_var(match=>\%MATCH);
                                } else {
                                        $MATCH = $MATCH{operand};
                                }
                        })
                    | <operand=term> <[subscript]>*
                        (?{
                                if ($MATCH{subscript} && @{ $MATCH{subscript} }) {
                                        $MATCH = $obj->rule_subscripting_expr(match=>\%MATCH);
                                } else {
                                        $MATCH = $MATCH{operand};
                                }
                        })

                <rule: subscript>
                            \[ <MATCH=term> \]

# precedence level: left     term (variable, str/num literals, func(), (paren))
                <rule: term>
                        <MATCH=func>
                    | <MATCH=var0>
                    | <MATCH=str0>
                    | <MATCH=undef>
                    | <MATCH=num0>
                    | <MATCH=bool0>
                    | <MATCH=array>
                    | <MATCH=hash>
                    | \( <answer> \)
                        (?{ $MATCH = $obj->rule_parenthesis(match=>\%MATCH) // $MATCH{answer} })

                <rule: array>
                        \[ \]
                        (?{ $MATCH = $obj->rule_array(match=>{element=>[]}) })
                    | \[ <[element=answer]> ** (,) \]
                        (?{ $MATCH = $obj->rule_array(match=>\%MATCH) })

                <rule: hash>
                        \{ \}
                        (?{ $MATCH = $obj->rule_hash(match=>{pair=>[]}) })
                    | \{ <[pair]> ** (,) \}
                        (?{ $MATCH = $obj->rule_hash(match=>\%MATCH) })

                <token: undef>
                        undef
                        (?{ $MATCH = $obj->rule_undef() })

                <token: bool0>
                        <bool=(true|false)>
                        (?{ $MATCH = $obj->rule_bool(match=>\%MATCH) })

                <token: num0>
                        <sign0a=([+-]?+)> 0x <num0a=([0-9A-Fa-f]++)>
                        (?{ $MATCH = $obj->rule_num(match=>{num=>
                                ($MATCH{sign0a} eq '-' ? -1:1) * hex($MATCH{num0a})}) })
                    | <sign0b=([+-]?+)> 0o <num0b=([0-7]++)>
                        (?{ $MATCH = $obj->rule_num(match=>{num=>
                                ($MATCH{sign0b} eq '-' ? -1:1) * oct($MATCH{num0b})}) })
                    | <sign0c=([+-]?+)> 0b <num0c=([0-1]++)>
                        (?{ $MATCH = $obj->rule_num(match=>{num=>
                                ($MATCH{sign0c} eq '-' ? -1:1) * oct("0b".$MATCH{num0c})}) })
                    | <num0c=( [+-]?\d++(?:\.\d++)?+ | inf | nan)>
                        (?{ $MATCH = $obj->rule_num(match=>{num=>$MATCH{num0c}}) })

                <rule: str0>
                        <MATCH=squotestr>
                    | <MATCH=dquotestr>

                <token: squotestr>
                        '<[part=(\\\\|\\'|\\|[^\\']++)]>*'
                        (?{ $MATCH = $obj->rule_squotestr(match=>\%MATCH) })

                <token: dquotestr>
                        "<[part=([^"\044\\]++|\$\.\.?|\$\w+|\$\{[^\}]+\}|\\\\|\\'|\\"|\\[tnrfbae\$]|\\[0-7]{1,3}|\\x[0-9A-Fa-f]{1,2}|\\x\{[0-9A-Fa-f]{1,4}\}|\\)]>*"
                        (?{ $MATCH = $obj->rule_dquotestr(match=>\%MATCH) })

                <rule: var0>
                        \$ <var=(\w++(?:::\w+)*+)>
                        (?{ $MATCH = $obj->rule_var(match=>\%MATCH) })
                    | \$ \{ <var=([^\}]++)> \}
                        (?{ $MATCH = $obj->rule_var(match=>\%MATCH) })

                <rule: func>
                        <func_name=([A-Za-z_]\w*+)> \( \)
                        (?{ $MATCH = $obj->rule_func(match=>{func_name=>$MATCH{func_name}, args=>[]}) })
                    | <func_name=(map|grep|usort)> \( \{ <expr=answer> \} (?{ push @$subexpr_stack, $CONTEXT }), <input_array=answer> \)
                        (?{ my $meth = "rule_func_$MATCH{func_name}";
                                $MATCH = $obj->$meth(match=>{expr=>pop(@$subexpr_stack), array=>$MATCH{input_array}}) })
                    | <func_name=([A-Za-z_]\w*+)> \( <[args=answer]> ** (,) \)
                        (?{ $MATCH = $obj->rule_func(match=>\%MATCH) })

        }xms } 0..($MAX_LEVELS-1)];

    $obj = $obj_arg;
    $obj_arg->expr_preprocess(string_ref => \$str, level => $level);
    #print "DEBUG: Parsing expression `$str` with grammars->[$level] ...\n";
    die "Invalid syntax in expression `$str`" unless $str =~ $grammars->[$level];
    $obj_arg->expr_postprocess(result => $/{answer});
}

1;
# ABSTRACT: Parse Language::Expr expression

__END__

=pod

=encoding UTF-8

=head1 NAME

Language::Expr::Parser - Parse Language::Expr expression

=head1 VERSION

This document describes version 0.28 of Language::Expr::Parser (from Perl distribution Language-Expr), released on 2016-07-01.

=head1 KNOWN BUGS

=over 4

=item * Ternary operator is not chainable yet.

=back

=head1 METHODS

=head2 parse_expr($str, $obj)

Parse expression in $str. Will call various rule_*() methods in $obj.

=head1 HOMEPAGE

Please visit the project's homepage at L<https://metacpan.org/release/Language-Expr>.

=head1 SOURCE

Source repository is at L<https://github.com/perlancar/perl-Language-Expr>.

=head1 BUGS

Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Language-Expr>

When submitting a bug or request, please include a test-file or a
patch to an existing test-file that illustrates the bug or desired
feature.

=head1 AUTHOR

perlancar <[e-mail]>

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2016 by [e-mail].

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.

=cut