File Coverage

blib/lib/Language/Expr/Interpreter/default.pm
Criterion Covered Total %
statement 229 270 84.8
branch 100 166 60.2
condition 17 31 54.8
subroutine 36 40 90.0
pod 0 31 0.0
total 382 538 71.0


line stmt bran cond sub pod time code
1             package Language::Expr::Interpreter::default;
2              
3             our $DATE = '2016-06-29'; # DATE
4             our $VERSION = '0.27'; # VERSION
5              
6 2     2   41 use 5.010;
  2         5  
7 2     2   8 use strict;
  2         2  
  2         40  
8 2     2   5 use warnings;
  2         3  
  2         41  
9              
10 2     2   358 use Role::Tiny::With;
  2         3167  
  2         91  
11 2     2   309 use Mo qw(build default);
  2         323  
  2         9  
12             extends 'Language::Expr::Interpreter::Base';
13             with 'Language::Expr::InterpreterRole';
14 2     2   1345 use List::Util 'reduce';
  2         2  
  2         164  
15 2     2   7 use boolean;
  2         2  
  2         11  
16              
17             has vars => (is => 'rw', default => sub { {} });
18             has funcs => (is => 'rw', default => sub { {} });
19             has level => (is => 'rw', default => sub { 0 });
20              
21             sub rule_pair_simple {
22 10     10 0 19 my ($self, %args) = @_;
23 10         11 my $match = $args{match};
24 10         195 [$match->{key}, $match->{value}];
25             }
26              
27             sub rule_pair_string {
28 6     6 0 10 my ($self, %args) = @_;
29 6         7 my $match = $args{match};
30 6         114 [$match->{key}, $match->{value}];
31             }
32              
33             sub rule_or_xor {
34 8     8 0 12 my ($self, %args) = @_;
35 8         9 my $match = $args{match};
36 8         4 my $res = shift @{$match->{operand}};
  8         13  
37 8         7 for my $term (@{$match->{operand}}) {
  8         11  
38 8   50     6 my $op = shift @{$match->{op}//=[]};
  8         14  
39 8 50       17 last unless $op;
40 8 100 100     12 if ($op eq '||') { $res ||= $term }
  4 50       8  
    0          
41 4   100     13 elsif ($op eq '//') { $res //= $term }
42 0   0     0 elsif ($op eq '^^') { $res = ($res xor $term) }
43             }
44 8         164 $res;
45             }
46              
47             sub rule_ternary {
48 10     10 0 14 my ($self, %args) = @_;
49 10         12 my $match = $args{match};
50 10         10 my $opd = $match->{operand};
51 10 100       28 $opd->[0] ? $opd->[1] : $opd->[2];
52             }
53              
54             sub rule_and {
55 4     4 0 8 my ($self, %args) = @_;
56 4         3 my $match = $args{match};
57 4         4 my $res = shift @{$match->{operand}};
  4         7  
58 4         3 for my $term (@{$match->{operand}}) {
  4         6  
59 4   50     2 my $op = shift @{$match->{op}//=[]};
  4         13  
60 4 50       6 last unless $op;
61 4 50 66     7 if ($op eq '&&') { $res = $res && $term || false }
  4         18  
62             }
63 4         124 $res;
64             }
65              
66             sub rule_bit_or_xor {
67 2     2 0 4 my ($self, %args) = @_;
68 2         3 my $match = $args{match};
69 2         2 my $res = shift @{$match->{operand}};
  2         5  
70 2         2 for my $term (@{$match->{operand}}) {
  2         4  
71 2   50     2 my $op = shift @{$match->{op}//=[]};
  2         5  
72 2 50       5 last unless $op;
73 2 100       7 if ($op eq '|') { $res = $res+0 | $term }
  1 50       2  
74 1         3 elsif ($op eq '^') { $res = $res+0 ^ $term }
75             }
76 2         39 $res;
77             }
78              
79             sub rule_bit_and {
80 1     1 0 2 my ($self, %args) = @_;
81 1         2 my $match = $args{match};
82 1         1 my $res = shift @{$match->{operand}};
  1         2  
83 1         2 for my $term (@{$match->{operand}}) {
  1         2  
84 1   50     1 my $op = shift @{$match->{op}//=[]};
  1         3  
85 1 50       4 last unless $op;
86 1 50       2 if ($op eq '&') { $res = $res+0 & $term }
  1         3  
87             }
88 1         20 $res;
89             }
90              
91             sub rule_comparison3 {
92 5     5 0 10 my ($self, %args) = @_;
93 5         4 my $match = $args{match};
94 5         4 my $res = shift @{$match->{operand}};
  5         8  
95 5 50       5 return $res unless @{$match->{operand}};
  5         10  
96 5         7 my $last_term = $res;
97 5         6 for my $term (@{$match->{operand}}) {
  5         8  
98 5   50     4 my $op = shift @{$match->{op}//=[]};
  5         13  
99 5 50       8 last unless $op;
100 5 100       10 if ($op eq '<=>') { $res = ($last_term <=> $term) }
  4 50       5  
101 1         2 elsif ($op eq 'cmp') { $res = ($last_term cmp $term) }
102 5         8 $last_term = $term;
103             }
104 5         96 $res;
105             }
106              
107             sub rule_comparison {
108 43     43 0 64 my ($self, %args) = @_;
109 43         37 my $match = $args{match};
110 43         32 my $res = shift @{$match->{operand}};
  43         76  
111 43 50       34 return $res unless @{$match->{operand}};
  43         72  
112 43         40 my $last_term = $res;
113 43         33 for my $term (@{$match->{operand}}) {
  43         57  
114 46   50     32 my $op = shift @{$match->{op}//=[]};
  46         88  
115 46 50       65 last unless $op;
116 46 100       145 if ($op eq '==' ) { return false unless $res = ($last_term == $term ? true:false) }
  16 100       50  
    100          
    100          
    100          
    50          
    100          
    100          
    100          
    50          
    0          
    0          
    0          
    0          
117 4 100       10 elsif ($op eq '!=' ) { return false unless $res = ($last_term != $term ? true:false) }
    100          
118 2 100       6 elsif ($op eq 'eq' ) { return false unless $res = ($last_term eq $term ? true:false) }
    100          
119 0 0       0 elsif ($op eq 'ne' ) { return false unless $res = ($last_term ne $term ? true:false) }
    0          
120 3 100       11 elsif ($op eq '<' ) { return false unless $res = ($last_term < $term ? true:false) }
    100          
121 3 100       10 elsif ($op eq '<=' ) { return false unless $res = ($last_term <= $term ? true:false) }
    100          
122 13 100       32 elsif ($op eq '>' ) { return false unless $res = ($last_term > $term ? true:false) }
    100          
123 5 100       16 elsif ($op eq '>=' ) { return false unless $res = ($last_term >= $term ? true:false) }
    100          
124 0 0       0 elsif ($op eq 'lt' ) { return false unless $res = ($last_term lt $term ? true:false) }
    0          
125 0 0       0 elsif ($op eq 'gt' ) { return false unless $res = ($last_term gt $term ? true:false) }
    0          
126 0 0       0 elsif ($op eq 'le' ) { return false unless $res = ($last_term le $term ? true:false) }
    0          
127 0 0       0 elsif ($op eq 'ge' ) { return false unless $res = ($last_term ge $term ? true:false) }
    0          
128 23         185 $last_term = $term;
129             }
130 20 50       33 $res ? true : false;
131             }
132              
133             sub rule_bit_shift {
134 4     4 0 7 my ($self, %args) = @_;
135 4         6 my $match = $args{match};
136 4         2 my $res = shift @{$match->{operand}};
  4         8  
137 4         2 for my $term (@{$match->{operand}}) {
  4         8  
138 4   50     1 my $op = shift @{$match->{op}//=[]};
  4         10  
139 4 50       9 last unless $op;
140 4 100       9 if ($op eq '>>') { $res >>= $term }
  2 50       4  
141 2         3 elsif ($op eq '<<') { $res <<= $term }
142             }
143 4         75 $res;
144             }
145              
146             sub rule_add {
147 20     20 0 35 my ($self, %args) = @_;
148 20         20 my $match = $args{match};
149 20         19 my $res = shift @{$match->{operand}};
  20         34  
150 20         18 for my $term (@{$match->{operand}}) {
  20         37  
151 37   50     23 my $op = shift @{$match->{op}//=[]};
  37         81  
152 37 50       47 last unless $op;
153 37 100       59 if ($op eq '+') { $res += $term }
  30 100       32  
    50          
154 5         7 elsif ($op eq '-') { $res -= $term }
155 2         4 elsif ($op eq '.') { $res .= $term }
156             }
157 20         403 $res;
158             }
159              
160             sub rule_mult {
161 12     12 0 23 my ($self, %args) = @_;
162 12         12 my $match = $args{match};
163 12         8 my $res = shift @{$match->{operand}};
  12         24  
164 12         10 for my $term (@{$match->{operand}}) {
  12         21  
165 20   50     13 my $op = shift @{$match->{op}//=[]};
  20         40  
166 20 50       28 last unless $op;
167 20 100       74 if ($op eq '*') { $res *= $term }
  7 100       14  
    100          
    50          
168 6         8 elsif ($op eq '/') { $res /= $term }
169 3         5 elsif ($op eq '%') { $res %= $term }
170 4         9 elsif ($op eq 'x') { $res x= $term }
171             }
172 12         234 $res;
173             }
174              
175             sub rule_unary {
176 12     12 0 17 my ($self, %args) = @_;
177 12         13 my $match = $args{match};
178 12         11 my $res = $match->{operand};
179 12 50       19 if ($match->{op}) {
180 12         11 for my $op (reverse @{$match->{op}}) {
  12         19  
181 17 100       40 if ($op eq '!') { $res = $res ? false : true }
  5 100       16  
    100          
    50          
182 11         13 elsif ($op eq '-') { $res = -$res }
183 1         3 elsif ($op eq '~') { $res = ~($res+0) }
184             }
185             }
186 12         241 $res;
187             }
188              
189             sub rule_power {
190 3     3 0 7 my ($self, %args) = @_;
191 3         3 my $match = $args{match};
192 3     4   12 reduce { $b ** $a } reverse @{$match->{operand}};
  4         63  
  3         31  
193             }
194              
195             sub rule_subscripting_var {
196 2     2 0 5 my ($self, %args) = @_;
197 2         10 $self->rule_subscripting_expr(%args);
198             }
199              
200             sub rule_subscripting_expr {
201 9     9 0 18 my ($self, %args) = @_;
202 9         23 my $match = $args{match};
203 9         13 my $res = $match->{operand};
204 9         8 for my $i (@{$match->{subscript}}) {
  9         23  
205 10 100       33 if (ref($res) eq 'ARRAY' ) { $res = $res->[$i] }
  5 50       13  
206 5         11 elsif (ref($res) eq 'HASH') { $res = $res->{$i} }
207 0         0 else { die "Invalid subscript on nonhash/nonarray" }
208             }
209 9         256 $res;
210             }
211              
212             sub rule_array {
213 7     7 0 18 my ($self, %args) = @_;
214 7         10 my $match = $args{match};
215 7         169 $match->{element};
216             }
217              
218             sub rule_hash {
219 9     9 0 13 my ($self, %args) = @_;
220 9         10 my $match = $args{match};
221 9         7 return { map { $_->[0] => $_->[1] } @{ $match->{pair} } }
  15         174  
  9         33  
222             }
223              
224             sub rule_undef {
225 5     5 0 6 my ($self, %args) = @_;
226 5         7 my $match = $args{match};
227 5         100 undef;
228             }
229              
230             sub rule_squotestr {
231 10     10 0 19 my ($self, %args) = @_;
232             join("",
233 10         237 map { $_->{value} }
234 10         9 @{ $self->parse_squotestr($args{match}{part}) });
  10         35  
235             }
236              
237             sub rule_dquotestr {
238 48     48 0 69 my ($self, %args) = @_;
239             join("",
240             map { $_->{type} eq 'VAR' ?
241             $self->rule_var(match=>{var=>$_->{value}}) :
242             $_->{value}
243 48 100       1133 }
244 48         48 @{ $self->parse_dquotestr($args{match}{part}) });
  48         161  
245             }
246              
247             sub rule_bool {
248 2     2 0 3 my ($self, %args) = @_;
249 2         2 my $match = $args{match};
250 2 100       6 if ($match->{bool} eq 'true') { true } else { false }
  1         4  
  1         4  
251             }
252              
253             sub rule_num {
254 263     263 0 394 my ($self, %args) = @_;
255 263         236 my $match = $args{match};
256 263 50       548 if ($match->{num} eq 'inf') { "Inf"+0 }
  0 50       0  
257 0         0 elsif ($match->{num} eq 'nan') { "NaN"+0 }
258 263         5322 else { $match->{num}+0 }
259             }
260              
261             sub rule_var {
262 9     9 0 16 my ($self, %args) = @_;
263 9         11 my $match = $args{match};
264 9         25 $self->vars->{ $match->{var} };
265             }
266              
267             sub rule_func {
268 4     4 0 5 my ($self, %args) = @_;
269 4         5 my $match = $args{match};
270 4         5 my $f = $match->{func_name};
271 4         4 my $args = $match->{args};
272 4         3 my $res;
273 4 50       11 if ($self->funcs->{$f}) {
274 4         38 return $self->funcs->{$f}->(@$args);
275             } else {
276 0         0 die "Unknown function $f";
277             }
278             }
279              
280             sub _map_grep_usort {
281 0     0   0 my ($self, $which, %args) = @_;
282 0         0 my $match = $args{match};
283 0         0 my $ary = $match->{array};
284 0         0 my $expr = $match->{expr};
285 0 0       0 die "Second argument to map/grep/usort must be an array"
286             unless ref($ary) eq 'ARRAY';
287 0         0 local $self->{level} = $self->{level}+1;
288             #print "DEBUG: _map_grep_usort: level=$self->{level}, expr=`$expr`, array=[".join(",", @$ary),"]\n";
289 0         0 my $res;
290 0 0       0 if ($which eq 'map') {
    0          
    0          
291 0         0 $res = [];
292 0         0 local $self->{vars}{_};
293 0         0 for (@$ary) {
294 0         0 $self->{vars}{_} = $_;
295 0         0 push @$res, Language::Expr::Parser::parse_expr($expr, $self,
296             $self->level);
297 0         0 push @$res, $_;
298             }
299             } elsif ($which eq 'grep') {
300 0         0 local $self->{vars}{_};
301             $res = [ grep {
302 0         0 $self->{vars}{_} = $_;
  0         0  
303 0         0 $self->Language::Expr::Parser::parse_expr($expr, $self,
304             $self->level)
305             } @$ary];
306             } elsif ($which eq 'usort') {
307 0         0 local $self->{vars}{a};
308 0         0 local $self->{vars}{b};
309             $res = [ sort {
310 0         0 $self->{vars}{a} = $a;
  0         0  
311 0         0 $self->{vars}{b} = $b;
312 0         0 Language::Expr::Parser::parse_expr($expr, $self,
313             $self->level)
314             } @$ary];
315             }
316 0         0 $res;
317             }
318              
319             sub rule_func_map {
320 0     0 0 0 my ($self, %args) = @_;
321 0         0 $self->_map_grep_usort('map', %args);
322             }
323              
324             sub rule_func_grep {
325 0     0 0 0 my ($self, %args) = @_;
326 0         0 $self->_map_grep_usort('grep', %args);
327             }
328              
329             sub rule_func_usort {
330 0     0 0 0 my ($self, %args) = @_;
331 0         0 $self->_map_grep_usort('usort', %args);
332             }
333              
334       31 0   sub rule_parenthesis {}
335              
336       166 0   sub expr_preprocess {}
337              
338             sub expr_postprocess {
339 139     139 0 278 my ($self, %args) = @_;
340 139         131 my $result = $args{result};
341 139         417 $result;
342             }
343              
344             1;
345             # ABSTRACT: A default interpreter for Language::Expr
346              
347             __END__
348              
349             =pod
350              
351             =encoding UTF-8
352              
353             =head1 NAME
354              
355             Language::Expr::Interpreter::default - A default interpreter for Language::Expr
356              
357             =head1 VERSION
358              
359             This document describes version 0.27 of Language::Expr::Interpreter::default (from Perl distribution Language-Expr), released on 2016-06-29.
360              
361             =head1 SYNOPSIS
362              
363             use Language::Expr::Interpreter::default;
364             my $itp = Language::Expr::Interpreter::default->new;
365             $itp->vars->{a} = 'A';
366             say $itp->eval(q["$a b" . "c"]); # "A b c"
367              
368             =head1 DESCRIPTION
369              
370             Interprets Language::Expr expression. Some notes:
371              
372             =over 4
373              
374             =item * Uses L<boolean> module.
375              
376             =item * Follows Perl's notion of true and false.
377              
378             That is, this expression ' "" || "0" || 2 ' will result to 2 because
379             Perl thinks "" and "0" are false.
380              
381             =back
382              
383             =for Pod::Coverage ^(rule|expr)_.+
384              
385             =head1 BUGS/TODOS
386              
387             Currently subexpression (map/grep/usort) doesn't work yet.
388              
389             =head1 ATTRIBUTES
390              
391             =head2 vars => {NAME => VAL, ...}
392              
393             Store variables.
394              
395             =head2 funcs => {NAME => CODEREF, ...}
396              
397             List known functions.
398              
399             =head2 level => INT
400              
401             Current recursion level.
402              
403             =head1 METHODS
404              
405             =head1 HOMEPAGE
406              
407             Please visit the project's homepage at L<https://metacpan.org/release/Language-Expr>.
408              
409             =head1 SOURCE
410              
411             Source repository is at L<https://github.com/perlancar/perl-Language-Expr>.
412              
413             =head1 BUGS
414              
415             Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Language-Expr>
416              
417             When submitting a bug or request, please include a test-file or a
418             patch to an existing test-file that illustrates the bug or desired
419             feature.
420              
421             =head1 AUTHOR
422              
423             perlancar <perlancar@cpan.org>
424              
425             =head1 COPYRIGHT AND LICENSE
426              
427             This software is copyright (c) 2016 by perlancar@cpan.org.
428              
429             This is free software; you can redistribute it and/or modify it under
430             the same terms as the Perl 5 programming language system itself.
431              
432             =cut