File Coverage

blib/lib/JQ/Lite/Util/Parsing.pm
Criterion Covered Total %
statement 545 629 86.6
branch 291 434 67.0
condition 89 160 55.6
subroutine 33 37 89.1
pod n/a
total 958 1260 76.0


line stmt bran cond sub pod time code
1             package JQ::Lite::Util;
2              
3 176     176   1017 use strict;
  176         294  
  176         5806  
4 176     176   680 use warnings;
  176         235  
  176         6483  
5              
6 176     176   681 use JSON::PP ();
  176         245  
  176         3298  
7 176     176   580 use Scalar::Util qw(looks_like_number);
  176         275  
  176         8318  
8 176     176   730 use Encode qw(encode is_utf8);
  176         358  
  176         6287  
9 176     176   705 use JQ::Lite::Expression ();
  176         648  
  176         1082103  
10              
11             our $JSON_DECODER = _build_json_decoder();
12             our $FROMJSON_DECODER = _build_json_decoder();
13             our $TOJSON_ENCODER = JSON::PP->new->utf8->allow_nonref;
14              
15             sub _build_json_decoder {
16 352     352   2338 my $decoder = JSON::PP->new->utf8->allow_nonref;
17              
18 352 50       22417 if ($decoder->can('boolean_values')) {
19 352         1130 $decoder->boolean_values(JSON::PP::false, JSON::PP::true);
20             }
21              
22 352         5577 return $decoder;
23             }
24              
25             sub _encode_json {
26 195     195   308 my ($value) = @_;
27 195         554 return $TOJSON_ENCODER->encode($value);
28             }
29              
30             sub _decode_json {
31 6894     6894   8017 my ($text) = @_;
32              
33 6894 100 66     18603 if (defined $text && is_utf8($text, 1)) {
34 6         29 $text = encode('UTF-8', $text);
35             }
36              
37 6894         13312 return $JSON_DECODER->decode($text);
38             }
39              
40             sub _are_brackets_balanced {
41 22     22   38 my ($text) = @_;
42              
43 22 50 33     92 return 1 unless defined $text && length $text;
44              
45 22         61 my %pairs = (
46             '(' => ')',
47             '[' => ']',
48             '{' => '}',
49             );
50 22         56 my %closing = reverse %pairs;
51              
52 22         35 my @stack;
53             my $string;
54 22         32 my $escape = 0;
55              
56 22         116 for my $char (split //, $text) {
57 231 100       292 if (defined $string) {
58 27 50       32 if ($escape) {
59 0         0 $escape = 0;
60 0         0 next;
61             }
62              
63 27 50       55 if ($char eq '\\') {
64 0         0 $escape = 1;
65 0         0 next;
66             }
67              
68 27 100       34 if ($char eq $string) {
69 6         8 undef $string;
70             }
71              
72 27         46 next;
73             }
74              
75 204 100 66     393 if ($char eq "'" || $char eq '"') {
76 6         8 $string = $char;
77 6         7 next;
78             }
79              
80 198 100       241 if (exists $pairs{$char}) {
81 6         8 push @stack, $char;
82 6         10 next;
83             }
84              
85 192 100       258 if (exists $closing{$char}) {
86 8 100       39 return 0 unless @stack;
87 6         8 my $open = pop @stack;
88 6 50       11 return 0 unless $pairs{$open} eq $char;
89 6         8 next;
90             }
91             }
92              
93 20   33     113 return !@stack && !defined $string;
94             }
95              
96             sub _strip_wrapping_parens {
97 6040     6040   7342 my ($text) = @_;
98              
99 6040 50       8182 return '' unless defined $text;
100              
101 6040         6471 my $copy = $text;
102 6040         17134 $copy =~ s/^\s+|\s+$//g;
103              
104 6040         10652 while ($copy =~ /^\((.*)\)$/s) {
105 22         50 my $inner = $1;
106 22 100       40 last unless _are_brackets_balanced($inner);
107 20         68 $inner =~ s/^\s+|\s+$//g;
108 20         44 $copy = $inner;
109             }
110              
111 6040         9060 return $copy;
112             }
113              
114             sub _split_top_level_semicolons {
115 8     8   15 my ($text) = @_;
116              
117 8 50       14 return unless defined $text;
118              
119 8         39 my %pairs = (
120             '(' => ')',
121             '[' => ']',
122             '{' => '}',
123             );
124 8         21 my %closing = reverse %pairs;
125              
126 8         12 my @stack;
127             my $string;
128 8         11 my $escape = 0;
129 8         8 my @parts;
130 8         10 my $start = 0;
131              
132 8         21 for (my $i = 0; $i < length $text; $i++) {
133 103         105 my $char = substr($text, $i, 1);
134              
135 103 100       133 if (defined $string) {
136 1 50       2 if ($escape) {
137 0         0 $escape = 0;
138 0         0 next;
139             }
140              
141 1 50       3 if ($char eq '\\') {
142 0         0 $escape = 1;
143 0         0 next;
144             }
145              
146 1 50       4 if ($char eq $string) {
147 1         1 undef $string;
148             }
149              
150 1         2 next;
151             }
152              
153 102 100 66     206 if ($char eq "'" || $char eq '"') {
154 1         2 $string = $char;
155 1         2 next;
156             }
157              
158 101 50       146 if (exists $pairs{$char}) {
159 0         0 push @stack, $char;
160 0         0 next;
161             }
162              
163 101 50       121 if (exists $closing{$char}) {
164 0 0       0 return unless @stack;
165 0         0 my $open = pop @stack;
166 0 0       0 return unless $pairs{$open} eq $char;
167 0         0 next;
168             }
169              
170 101 100       177 next unless $char eq ';';
171              
172 9 50       23 if (!@stack) {
173 9         16 my $chunk = substr($text, $start, $i - $start);
174 9         11 push @parts, $chunk;
175 9         15 $start = $i + 1;
176             }
177             }
178              
179 8 50       21 push @parts, substr($text, $start) if $start <= length $text;
180              
181 8         30 return @parts;
182             }
183              
184             sub _split_top_level_pipes {
185 1739     1739   2716 my ($text) = @_;
186              
187 1739 50       3032 return unless defined $text;
188              
189 1739         5612 my %pairs = (
190             '(' => ')',
191             '[' => ']',
192             '{' => '}',
193             );
194 1739         5243 my %closing = reverse %pairs;
195              
196 1739         2348 my @stack;
197             my $string;
198 1739         2057 my $escape = 0;
199 1739         1856 my @parts;
200 1739         1902 my $start = 0;
201              
202 1739         2144 my $length = length $text;
203 1739         1935 my $in_try = 0;
204 1739         3405 for (my $i = 0; $i < $length; $i++) {
205 20890         22566 my $char = substr($text, $i, 1);
206              
207 20890 100       24884 if (defined $string) {
208 1528 100       1861 if ($escape) {
209 8         9 $escape = 0;
210 8         14 next;
211             }
212              
213 1520 100       1892 if ($char eq '\\') {
214 8         12 $escape = 1;
215 8         13 next;
216             }
217              
218 1512 100       1843 if ($char eq $string) {
219 336         427 undef $string;
220             }
221              
222 1512         1842 next;
223             }
224              
225 19362 100 100     37795 if ($char eq "'" || $char eq '"') {
226 336         456 $string = $char;
227 336         478 next;
228             }
229              
230 19026 100       24238 if (exists $pairs{$char}) {
231 776         1185 push @stack, $char;
232 776         1232 next;
233             }
234              
235 18250 50 100     44554 if (!$in_try && !@stack && !defined $string) {
      66        
236 15265 100       22574 if (substr($text, $i) =~ /^try\b/) {
237 14         15 $in_try = 1;
238 14         27 next;
239             }
240             }
241              
242 18236 100 100     24506 if ($in_try && !@stack && !defined $string) {
      66        
243 101 100       147 if (substr($text, $i) =~ /^catch\b/) {
244 10         12 $in_try = 0;
245 10         15 next;
246             }
247             }
248              
249 18226 100       23140 if (exists $closing{$char}) {
250 776 50       1701 return unless @stack;
251 776         1124 my $open = pop @stack;
252 776 50       1680 return unless $pairs{$open} eq $char;
253 776         1334 next;
254             }
255              
256 17450 100       28880 next unless $char eq '|';
257 482 100       840 next if $in_try;
258 480 50       930 if (substr($text, $i, 2) eq '||') {
259 0         0 $i++;
260 0         0 next;
261             }
262              
263 480 100       909 if (!@stack) {
264 474         789 my $chunk = substr($text, $start, $i - $start);
265 474         742 push @parts, $chunk;
266 474         825 $start = $i + 1;
267             }
268             }
269              
270 1739 50       4095 push @parts, substr($text, $start) if $start <= $length;
271              
272 1739         7504 return @parts;
273             }
274              
275             sub _split_top_level_commas {
276 1494     1494   2173 my ($text) = @_;
277              
278 1494 50       2402 return unless defined $text;
279              
280 1494         4175 my %pairs = (
281             '(' => ')',
282             '[' => ']',
283             '{' => '}',
284             );
285 1494         3861 my %closing = reverse %pairs;
286              
287 1494         1974 my @stack;
288             my $string;
289 1494         1846 my $escape = 0;
290 1494         1567 my @parts;
291 1494         1718 my $start = 0;
292              
293 1494         3172 for (my $i = 0; $i < length $text; $i++) {
294 15207         16598 my $char = substr($text, $i, 1);
295              
296 15207 100       18286 if (defined $string) {
297 1635 100       1938 if ($escape) {
298 8         10 $escape = 0;
299 8         11 next;
300             }
301              
302 1627 100       1965 if ($char eq '\\') {
303 8         8 $escape = 1;
304 8         14 next;
305             }
306              
307 1619 100       2057 if ($char eq $string) {
308 339         502 undef $string;
309             }
310              
311 1619         2037 next;
312             }
313              
314 13572 100 100     26979 if ($char eq "'" || $char eq '"') {
315 339         440 $string = $char;
316 339         470 next;
317             }
318              
319 13233 100       16664 if (exists $pairs{$char}) {
320 706         1046 push @stack, $char;
321 706         1100 next;
322             }
323              
324 12527 100       15898 if (exists $closing{$char}) {
325 706 50       1115 return unless @stack;
326 706         1015 my $open = pop @stack;
327 706 50       1441 return unless $pairs{$open} eq $char;
328 706         1157 next;
329             }
330              
331 11821 100       19383 next unless $char eq ',';
332              
333 126 100       251 if (!@stack) {
334 38         114 my $chunk = substr($text, $start, $i - $start);
335 38         53 push @parts, $chunk;
336 38         73 $start = $i + 1;
337             }
338             }
339              
340 1494 50       3560 push @parts, substr($text, $start) if $start <= length $text;
341              
342 1494         5307 return @parts;
343             }
344              
345             sub _split_top_level_operator {
346 1933     1933   3448 my ($text, $operator) = @_;
347              
348 1933 50 33     17674 return unless defined $text && defined $operator && length($operator) == 1;
      33        
349              
350 1933         4309 my %pairs = (
351             '(' => ')',
352             '[' => ']',
353             '{' => '}',
354             );
355 1933         4373 my %closing = reverse %pairs;
356              
357 1933         2554 my @stack;
358             my $string;
359 1933         2376 my $escape = 0;
360              
361 1933         3523 for (my $i = 0; $i < length $text; $i++) {
362 17009         17966 my $char = substr($text, $i, 1);
363              
364 17009 100       20085 if (defined $string) {
365 1473 100       1771 if ($escape) {
366 6         6 $escape = 0;
367 6         10 next;
368             }
369              
370 1467 100       1749 if ($char eq '\\') {
371 6         8 $escape = 1;
372 6         10 next;
373             }
374              
375 1461 100       1743 if ($char eq $string) {
376 322         376 undef $string;
377             }
378              
379 1461         1840 next;
380             }
381              
382 15536 100 100     29754 if ($char eq "'" || $char eq '"') {
383 322         368 $string = $char;
384 322         454 next;
385             }
386              
387 15214 100       19559 if (exists $pairs{$char}) {
388 711         1155 push @stack, $char;
389 711         1064 next;
390             }
391              
392 14503 100       17786 if (exists $closing{$char}) {
393 711 50       1192 return if !@stack;
394 711         1069 my $open = pop @stack;
395 711 50       1428 return if $pairs{$open} ne $char;
396 711         1104 next;
397             }
398              
399 13792 100       22721 next if $char ne $operator;
400              
401 68 100       139 if (!@stack) {
402 51 50 33     91 if ($operator eq '+' || $operator eq '-') {
403 51 50       101 my $prev = $i > 0 ? substr($text, $i - 1, 1) : '';
404 51 50       115 my $next = $i + 1 < length $text ? substr($text, $i + 1, 1) : '';
405 51 50 33     139 if ($prev =~ /[eE]/ && $next =~ /[0-9]/) {
406 0         0 next;
407             }
408 51 100       83 if ($next eq '=') {
409 2         4 next;
410             }
411             }
412              
413 49         60 my $lhs = substr($text, 0, $i);
414 49         68 my $rhs = substr($text, $i + 1);
415 49         179 return ($lhs, $rhs);
416             }
417             }
418              
419 1884         5952 return;
420             }
421              
422             sub _split_top_level_colon {
423 49     49   67 my ($text) = @_;
424              
425 49 50       97 return unless defined $text;
426              
427 49         146 my %pairs = (
428             '(' => ')',
429             '[' => ']',
430             '{' => '}',
431             );
432 49         113 my %closing = reverse %pairs;
433              
434 49         57 my @stack;
435             my $string;
436 49         66 my $escape = 0;
437              
438 49         93 for (my $i = 0; $i < length $text; $i++) {
439 313         336 my $char = substr($text, $i, 1);
440              
441 313 100       394 if (defined $string) {
442 132 50       238 if ($escape) {
443 0         0 $escape = 0;
444 0         0 next;
445             }
446              
447 132 50       213 if ($char eq '\\') {
448 0         0 $escape = 1;
449 0         0 next;
450             }
451              
452 132 100       160 if ($char eq $string) {
453 24         27 undef $string;
454             }
455              
456 132         165 next;
457             }
458              
459 181 100 66     373 if ($char eq "'" || $char eq '"') {
460 24         31 $string = $char;
461 24         40 next;
462             }
463              
464 157 50       214 if (exists $pairs{$char}) {
465 0         0 push @stack, $char;
466 0         0 next;
467             }
468              
469 157 50       206 if (exists $closing{$char}) {
470 0 0       0 return unless @stack;
471 0         0 my $open = pop @stack;
472 0 0       0 return unless $pairs{$open} eq $char;
473 0         0 next;
474             }
475              
476 157 100       241 next if $char ne ':';
477              
478 46 50       85 if (!@stack) {
479 46         150 my $lhs = substr($text, 0, $i);
480 46         68 my $rhs = substr($text, $i + 1);
481 46         166 return ($lhs, $rhs);
482             }
483             }
484              
485 3         12 return;
486             }
487              
488             sub _interpret_object_key {
489 13     13   29 my ($raw) = @_;
490              
491 13 50       20 return unless defined $raw;
492              
493 13         15 my $text = $raw;
494 13         43 $text =~ s/^\s+|\s+$//g;
495 13 50       39 return if $text eq '';
496              
497 13         16 my $decoded = eval { $FROMJSON_DECODER->decode($text) };
  13         37  
498 13 50 66     2831 if (!$@ && !ref $decoded) {
499 2         10 return $decoded;
500             }
501              
502 11 50       30 if ($text =~ /^'(.*)'$/s) {
503 0         0 my $inner = $1;
504 0         0 $inner =~ s/\\'/'/g;
505 0         0 return $inner;
506             }
507              
508 11         29 return $text;
509             }
510              
511             sub _split_top_level_semicolon {
512 0     0   0 my ($text) = @_;
513              
514 0         0 my @parts = _split_top_level_semicolons($text);
515 0 0       0 return unless @parts == 2;
516              
517 0         0 return @parts;
518             }
519              
520             sub _matches_keyword {
521 2126     2126   2363 my ($text, $pos, $keyword) = @_;
522              
523 2126 50       2397 return 0 unless defined $text;
524 2126 50       2321 return 0 if $pos < 0;
525              
526 2126         1928 my $kw_len = length $keyword;
527 2126 100       2628 return 0 if $pos + $kw_len > length $text;
528 2099 100       3667 return 0 if substr($text, $pos, $kw_len) ne $keyword;
529              
530 45 100       79 my $before = $pos == 0 ? '' : substr($text, $pos - 1, 1);
531 45 100       77 my $after = ($pos + $kw_len) < length $text ? substr($text, $pos + $kw_len, 1) : '';
532              
533 45 50       104 return 0 if $before =~ /[A-Za-z0-9_]/;
534 45 50       65 return 0 if $after =~ /[A-Za-z0-9_]/;
535              
536 45         153 return 1;
537             }
538              
539             sub _parse_if_expression {
540 1274     1274   1718 my ($expr) = @_;
541              
542 1274 50       1988 return undef unless defined $expr;
543              
544 1274         1597 my $copy = _strip_wrapping_parens($expr);
545 1274         3577 $copy =~ s/^\s+|\s+$//g;
546 1274 100       3594 return undef unless $copy =~ /^if\b/;
547              
548 9         17 my $len = length $copy;
549 9         12 my $pos = 0;
550              
551 9 50       20 return undef unless _matches_keyword($copy, $pos, 'if');
552 9         12 $pos += 2;
553              
554 9         11 my $depth = 1;
555 9         11 my $state = 'condition';
556 9         14 my $current = '';
557 9         16 my $condition;
558             my @branches;
559 9         0 my $else_expr;
560              
561 9         11 my $in_single = 0;
562 9         9 my $in_double = 0;
563 9         9 my $escape = 0;
564              
565 9         21 while ($pos < $len) {
566 333         351 my $char = substr($copy, $pos, 1);
567              
568 333 50       447 if ($escape) {
569 0         0 $current .= $char;
570 0         0 $escape = 0;
571 0         0 $pos++;
572 0         0 next;
573             }
574              
575 333 50       428 if ($in_single) {
576 0 0       0 if ($char eq '\\') {
    0          
577 0         0 $escape = 1;
578             }
579             elsif ($char eq "'") {
580 0         0 $in_single = 0;
581             }
582 0         0 $current .= $char;
583 0         0 $pos++;
584 0         0 next;
585             }
586              
587 333 100       373 if ($in_double) {
588 36 50       57 if ($char eq '\\') {
    100          
589 0         0 $escape = 1;
590             }
591             elsif ($char eq '"') {
592 14         19 $in_double = 0;
593             }
594 36         34 $current .= $char;
595 36         34 $pos++;
596 36         42 next;
597             }
598              
599 297 50       362 if ($char eq "'") {
600 0         0 $in_single = 1;
601 0         0 $current .= $char;
602 0         0 $pos++;
603 0         0 next;
604             }
605              
606 297 100       361 if ($char eq '"') {
607 14         48 $in_double = 1;
608 14         16 $current .= $char;
609 14         13 $pos++;
610 14         21 next;
611             }
612              
613 283 100       300 if (_matches_keyword($copy, $pos, 'if')) {
614 1         2 $depth++;
615 1         2 $current .= 'if';
616 1         1 $pos += 2;
617 1         3 next;
618             }
619              
620 282 100 100     299 if (_matches_keyword($copy, $pos, 'then') && $depth == 1 && $state eq 'condition') {
      66        
621 11         12 $condition = $current;
622 11         81 $condition =~ s/^\s+|\s+$//g;
623 11 50 33     48 return undef unless defined $condition && length $condition;
624              
625 11         13 $current = '';
626 11         12 $state = 'then';
627 11         10 $pos += 4;
628 11         18 next;
629             }
630              
631 271 50 66     284 if (_matches_keyword($copy, $pos, 'elif') && $depth == 1 && $state eq 'then') {
      66        
632 2         4 my $then_expr = $current;
633 2         5 $then_expr =~ s/^\s+|\s+$//g;
634 2 50       6 $then_expr = '.' if !length $then_expr;
635              
636 2 50       4 return undef unless defined $condition;
637 2         7 push @branches, { condition => $condition, then => $then_expr };
638              
639 2         2 $condition = undef;
640 2         3 $current = '';
641 2         2 $state = 'condition';
642 2         2 $pos += 4;
643 2         4 next;
644             }
645              
646 269 100 100     307 if (_matches_keyword($copy, $pos, 'else') && $depth == 1 && $state eq 'then') {
      66        
647 8         12 my $then_expr = $current;
648 8         47 $then_expr =~ s/^\s+|\s+$//g;
649 8 50       17 $then_expr = '.' if !length $then_expr;
650              
651 8 50       12 return undef unless defined $condition;
652 8         64 push @branches, { condition => $condition, then => $then_expr };
653              
654 8         14 $condition = undef;
655 8         12 $current = '';
656 8         9 $state = 'else';
657 8         11 $pos += 4;
658 8         19 next;
659             }
660              
661 261 100       276 if (_matches_keyword($copy, $pos, 'end')) {
662 10 100       67 if ($depth == 1) {
663 9 100       29 if ($state eq 'then') {
    50          
    0          
664 1         3 my $then_expr = $current;
665 1         7 $then_expr =~ s/^\s+|\s+$//g;
666 1 50       7 $then_expr = '.' if !length $then_expr;
667              
668 1 50       2 return undef unless defined $condition;
669 1         5 push @branches, { condition => $condition, then => $then_expr };
670             }
671             elsif ($state eq 'else') {
672 8         9 my $else = $current;
673 8         43 $else =~ s/^\s+|\s+$//g;
674 8 50       19 $else_expr = length $else ? $else : undef;
675             }
676             elsif ($state eq 'condition') {
677 0         0 return undef;
678             }
679              
680 9         11 $depth = 0;
681 9         11 $pos += 3;
682 9         11 $current = '';
683 9         11 $state = 'done';
684 9         12 last;
685             }
686             else {
687 1         11 $depth--;
688 1         2 $current .= 'end';
689 1         1 $pos += 3;
690 1         2 next;
691             }
692             }
693              
694 251 100 66     289 if (_matches_keyword($copy, $pos, 'then') && $depth > 1) {
695 1         3 $current .= 'then';
696 1         1 $pos += 4;
697 1         2 next;
698             }
699              
700 250 50 33     279 if (_matches_keyword($copy, $pos, 'elif') && $depth > 1) {
701 0         0 $current .= 'elif';
702 0         0 $pos += 4;
703 0         0 next;
704             }
705              
706 250 100 66     301 if (_matches_keyword($copy, $pos, 'else') && $depth > 1) {
707 1         2 $current .= 'else';
708 1         1 $pos += 4;
709 1         2 next;
710             }
711              
712 249         262 $current .= $char;
713 249         290 $pos++;
714             }
715              
716 9 50       20 return undef unless @branches;
717              
718 9 50       14 if ($pos < $len) {
719 0         0 my $remaining = substr($copy, $pos);
720 0         0 $remaining =~ s/^\s+//;
721 0 0       0 return undef if $remaining =~ /\S/;
722             }
723              
724             return {
725 9         51 branches => \@branches,
726             else => $else_expr,
727             };
728             }
729              
730             sub _parse_reduce_expression {
731 1265     1265   1808 my ($expr) = @_;
732              
733 1265 50       1999 return undef unless defined $expr;
734              
735 1265         1765 my $copy = _strip_wrapping_parens($expr);
736 1265 100       3455 return undef unless $copy =~ /^reduce\s+(.+?)\s+as\s+\$(\w+)\s*\((.*)\)$/s;
737              
738 4         21 my ($generator, $var_name, $body) = ($1, $2, $3);
739 4         6 my @parts = _split_top_level_semicolons($body);
740 4 50       7 return undef unless @parts == 2;
741 4         8 my ($init_expr, $update_expr) = @parts;
742              
743 4         15 $generator =~ s/^\s+|\s+$//g;
744 4         9 $init_expr =~ s/^\s+|\s+$//g;
745 4         23 $update_expr =~ s/^\s+|\s+$//g;
746              
747             return {
748 4         27 generator => $generator,
749             var_name => $var_name,
750             init_expr => $init_expr,
751             update_expr => $update_expr,
752             };
753             }
754              
755             sub _parse_foreach_expression {
756 1278     1278   1857 my ($expr) = @_;
757              
758 1278 50       2054 return undef unless defined $expr;
759              
760 1278         1927 my $copy = _strip_wrapping_parens($expr);
761 1278 100       4385 return undef unless $copy =~ /^foreach\s+(.+?)\s+as\s+\$(\w+)\s*\((.*)\)$/s;
762              
763 4         20 my ($generator, $var_name, $body) = ($1, $2, $3);
764 4         8 my @parts = _split_top_level_semicolons($body);
765 4 50 33     11 return undef unless @parts >= 2 && @parts <= 3;
766              
767 4         31 my ($init_expr, $update_expr, $extract_expr) = @parts;
768              
769 4         9 for ($generator, $init_expr, $update_expr) {
770 12 50       14 next unless defined $_;
771 12         40 s/^\s+|\s+$//g;
772             }
773              
774 4 100       7 if (defined $extract_expr) {
775 1         3 $extract_expr =~ s/^\s+|\s+$//g;
776             }
777              
778             return {
779 4         39 generator => $generator,
780             var_name => $var_name,
781             init_expr => $init_expr,
782             update_expr => $update_expr,
783             extract_expr => $extract_expr,
784             };
785             }
786              
787             sub _resolve_variable_reference {
788 48     48   75 my ($self, $name) = @_;
789              
790 48 50 33     173 return (undef, 0) unless defined $self && ref($self) eq 'JQ::Lite';
791 48 50 33     132 return (undef, 0) unless defined $name && length $name;
792              
793 48   50     96 my $vars = $self->{_vars} || {};
794 48 100       91 return (undef, 0) unless exists $vars->{$name};
795              
796 47         115 return ($vars->{$name}, 1);
797             }
798              
799             sub _evaluate_variable_reference {
800 48     48   98 my ($self, $name, $suffix) = @_;
801              
802 48         110 my ($value, $exists) = _resolve_variable_reference($self, $name);
803 48 100       93 return () unless $exists;
804              
805 47 100 66     168 return ($value) if !defined $suffix || $suffix !~ /\S/;
806              
807 9         17 my $expr = $suffix;
808 9         20 $expr =~ s/^\s+//;
809              
810 9         41 my ($values, $ok) = _evaluate_value_expression($self, $value, $expr);
811 9 50       36 return $ok ? @$values : ();
812             }
813              
814             sub _evaluate_value_expression {
815 771     771   1450 my ($self, $context, $expr) = @_;
816              
817 771 50       1322 return ([], 0) unless defined $expr;
818              
819 771         1339 my $copy = _strip_wrapping_parens($expr);
820 771         1941 $copy =~ s/^\s+|\s+$//g;
821 771 50       1462 return ([], 0) if $copy eq '';
822              
823 771 100       1239 if (_looks_like_expression($copy)) {
824             my %builtins = (
825             floor => sub {
826 0     0   0 my ($value) = @_;
827 0         0 my $numeric = _coerce_number_strict($value, 'floor() argument');
828 0         0 return _floor($numeric);
829             },
830             ceil => sub {
831 0     0   0 my ($value) = @_;
832 0         0 my $numeric = _coerce_number_strict($value, 'ceil() argument');
833 0         0 return _ceil($numeric);
834             },
835             round => sub {
836 0     0   0 my ($value) = @_;
837 0         0 my $numeric = _coerce_number_strict($value, 'round() argument');
838 0         0 return _round($numeric);
839             },
840             tonumber => sub {
841 1     1   2 my ($value) = @_;
842 1         3 return _tonumber($value);
843             },
844 62         768 );
845              
846             my ($ok, $value) = JQ::Lite::Expression::evaluate(
847             expr => $copy,
848             context => $context,
849             resolve_path => sub {
850 17     17   24 my ($ctx, $path) = @_;
851 17 50 33     47 return $ctx if !defined $path || $path eq '';
852 17         42 my @values = _traverse($ctx, $path);
853 17 50       39 return @values ? $values[0] : undef;
854             },
855 62         425 coerce_number => \&_coerce_number_strict,
856             builtins => \%builtins,
857             );
858              
859 55 100       597 if ($ok) {
860 6         67 return ([ $value ], 1);
861             }
862             }
863              
864 758         1450 my @pipeline_parts = _split_top_level_pipes($copy);
865 758 100       1425 if (@pipeline_parts > 1) {
866 5 50 33     59 if (defined $self && $self->can('run_query')) {
867 5         13 my $json = _encode_json($context);
868 5         1190 my @outputs = $self->run_query($json, $copy);
869 5         91 return ([ @outputs ], 1);
870             }
871             }
872              
873 753 100       1548 if ($copy =~ /^\$(\w+)(.*)$/s) {
874 32   50     94 my ($var, $suffix) = ($1, $2 // '');
875 32         61 my @values = _evaluate_variable_reference($self, $var, $suffix);
876 32         64 return (\@values, 1);
877             }
878              
879 721 100       1649 if ($copy =~ /^\[(.*)$/s) {
880 1         2 $copy = ".$copy";
881             }
882              
883 721 100       1315 if ($copy eq '.') {
884 31         76 return ([ $context ], 1);
885             }
886              
887 690 100       1398 if ($copy =~ /^\.(.*)$/s) {
888 128         276 my $path = $1;
889 128         399 $path =~ s/^\s+|\s+$//g;
890              
891 128 50 66     446 if ($path !~ /\s/ && $path !~ /[+\-*\/]/) {
892 70 50       159 return ([], 1) unless defined $context;
893 70 50       171 return ([], 1) if $path eq '';
894              
895 70         206 my @values = _traverse($context, $path);
896 70         205 return (\@values, 1);
897             }
898             }
899              
900 620         1234 my ($lhs_expr, $rhs_expr) = _split_top_level_operator($copy, '+');
901 620 100 66     1298 if (defined $lhs_expr && defined $rhs_expr) {
902 37         131 $lhs_expr =~ s/^\s+|\s+$//g;
903 37         155 $rhs_expr =~ s/^\s+|\s+$//g;
904              
905 37 50 33     100 if (length $lhs_expr && length $rhs_expr) {
906 37         126 my ($lhs_values, $lhs_ok) = _evaluate_value_expression($self, $context, $lhs_expr);
907 37         47 my $lhs;
908 37 50       61 if ($lhs_ok) {
909 37 50       61 $lhs = @$lhs_values ? $lhs_values->[0] : undef;
910             }
911             else {
912 0         0 my @outputs = $self->run_query(_encode_json($context), $lhs_expr);
913 0 0       0 $lhs = @outputs ? $outputs[0] : undef;
914             }
915              
916 37         73 my ($rhs_values, $rhs_ok) = _evaluate_value_expression($self, $context, $rhs_expr);
917 37         38 my $rhs;
918 37 50       61 if ($rhs_ok) {
919 37 50       65 $rhs = @$rhs_values ? $rhs_values->[0] : undef;
920             }
921             else {
922 0         0 my @outputs = $self->run_query(_encode_json($context), $rhs_expr);
923 0 0       0 $rhs = @outputs ? $outputs[0] : undef;
924             }
925              
926 37         62 my $combined = _apply_addition($lhs, $rhs);
927 35         151 return ([ $combined ], 1);
928             }
929             }
930              
931 583         848 my $decoded = eval { _decode_json($copy) };
  583         992  
932 583 100       135311 if (!$@) {
933 47         185 return ([ $decoded ], 1);
934             }
935              
936 536 50       1360 if ($copy =~ /^'(.*)'$/s) {
937 0         0 my $text = $1;
938 0         0 $text =~ s/\\'/'/g;
939 0         0 return ([ $text ], 1);
940             }
941              
942 536 100 33     6098 if ($copy !~ /\bthen\b/i
      100        
943             && $copy !~ /\belse\b/i
944             && $copy !~ /\bend\b/i
945             && $copy =~ /(?:==|!=|>=|<=|>|<|\band\b|\bor\b|\bcontains\b|\bhas\b|\bmatch\b)/)
946             {
947 13         53 my $bool = _evaluate_condition($context, $copy);
948 13 100       89 my $json_bool = $bool ? JSON::PP::true : JSON::PP::false;
949 13         78 return ([ $json_bool ], 1);
950             }
951              
952 523         2084 return ([], 0);
953             }
954              
955             sub _apply_addition {
956 46     46   64 my ($left, $right) = @_;
957              
958 46 50       91 return $right if !defined $left;
959 46 50       84 return $left if !defined $right;
960              
961 46 50       76 if (ref($left) eq 'JSON::PP::Boolean') {
962 0 0       0 $left = $left ? 1 : 0;
963             }
964              
965 46 50       74 if (ref($right) eq 'JSON::PP::Boolean') {
966 0 0       0 $right = $right ? 1 : 0;
967             }
968              
969 46 50 66     159 if (!ref $left && !ref $right) {
970 45         105 my $left_is_string = _is_string_scalar($left);
971 45         82 my $right_is_string = _is_string_scalar($right);
972              
973 45 100 66     109 if ($left_is_string || $right_is_string) {
974 13 100 66     110 die 'addition operands must both be strings' if !$left_is_string || !$right_is_string;
975 10 50       15 $left = '' unless defined $left;
976 10 50       32 $right = '' unless defined $right;
977 10         25 return "$left$right";
978             }
979              
980 32 50 33     133 if (looks_like_number($left) && looks_like_number($right)) {
981 32         68 return 0 + $left + $right;
982             }
983              
984 0         0 die 'addition operands must both be numbers or both be strings';
985             }
986              
987 1 50 33     4 if (ref $left eq 'ARRAY' && ref $right eq 'ARRAY') {
988 0         0 return [ @$left, @$right ];
989             }
990              
991 1 50       3 if (ref $left eq 'ARRAY') {
992 0         0 return [ @$left, $right ];
993             }
994              
995 1 50       2 if (ref $right eq 'ARRAY') {
996 0         0 return [ $left, @$right ];
997             }
998              
999 1 50 33     5 if (ref $left eq 'HASH' && ref $right eq 'HASH') {
1000 1         6 return { %$left, %$right };
1001             }
1002              
1003 0 0 0     0 return $right if !ref $left && ref $right eq 'HASH';
1004 0 0 0     0 return $left if ref $left eq 'HASH' && !ref $right;
1005              
1006 0         0 return undef;
1007             }
1008              
1009             sub _coerce_number_strict {
1010 30     30   46 my ($value, $label) = @_;
1011              
1012 30   50     43 $label ||= 'value';
1013              
1014 30 50       40 die "$label must be a number" unless defined $value;
1015              
1016 30 50       40 if (ref($value) eq 'JSON::PP::Boolean') {
1017 0 0       0 return $value ? 1 : 0;
1018             }
1019              
1020 30 50       41 die "$label must be a number" if ref $value;
1021 30 50       69 die "$label must be a number" unless looks_like_number($value);
1022              
1023 30         43 return 0 + $value;
1024             }
1025              
1026             sub _tonumber {
1027 3     3   6 my ($value) = @_;
1028              
1029 3 50       15 return undef unless defined $value;
1030              
1031 3 50       7 if (ref($value) eq 'JSON::PP::Boolean') {
1032 0 0       0 return $value ? 1 : 0;
1033             }
1034              
1035 3 50       12 if (ref $value) {
1036 0         0 die 'tonumber(): argument must be a string or number';
1037             }
1038              
1039 3         8 my $text = "$value";
1040 3         7 $text =~ s/^\s+|\s+$//g;
1041              
1042 3 50 33     15 die 'tonumber(): not a numeric string' unless length $text && looks_like_number($text);
1043              
1044 3         9 return 0 + $text;
1045             }
1046              
1047             sub _looks_like_expression {
1048 2118     2118   3129 my ($expr) = @_;
1049              
1050 2118 50       3381 return 0 unless defined $expr;
1051              
1052 2118 100       5362 return 1 if $expr =~ /\b(?:floor|ceil|round|tonumber)\b/;
1053 2083 100       4400 return 0 if $expr =~ /^\s*[\{\[]/;
1054 2059 100       4964 return 0 if $expr =~ /^[A-Za-z_]\w*\s*\(/;
1055 1632 100       3026 return 1 if $expr =~ /[\-*\/%]/;
1056 1589 100       5122 return 1 if $expr =~ /(?:==|!=|>=|<=|>|<|\band\b|\bor\b)/i;
1057              
1058 1546         3236 return 0;
1059             }
1060              
1061             sub _looks_like_assignment {
1062 1184     1184   1713 my ($expr) = @_;
1063              
1064 1184 50       2033 return 0 unless defined $expr;
1065 1184 100       3290 return 0 if $expr =~ /[()]/;
1066 795 50       2269 return 0 if $expr =~ /(?:==|!=|>=|<=|=>|=<)/;
1067 795         2202 return ($expr =~ /=/);
1068             }
1069              
1070             sub _parse_assignment_expression {
1071 16     16   19 my ($expr) = @_;
1072              
1073 16   50     27 $expr //= '';
1074              
1075 16         103 my ($lhs, $op, $rhs) = ($expr =~ /^(.*?)\s*([+\-*\/]?=)\s*(.*)$/);
1076              
1077 16   50     29 $lhs //= '';
1078 16   50     32 $rhs //= '';
1079 16   50     40 $op //= '=';
1080              
1081 16         64 $lhs =~ s/^\s+|\s+$//g;
1082 16         33 $rhs =~ s/^\s+|\s+$//g;
1083              
1084 16         26 $lhs =~ s/^\.//;
1085              
1086 16         25 my $value_spec = _parse_assignment_value($rhs);
1087              
1088 16         47 return ($lhs, $value_spec, $op);
1089             }
1090              
1091             sub _parse_assignment_value {
1092 16     16   23 my ($raw) = @_;
1093              
1094 16   50     22 $raw //= '';
1095 16         30 $raw =~ s/^\s+|\s+$//g;
1096              
1097 16 100       28 if ($raw =~ /^\.(.+)$/) {
1098 1         4 return { type => 'path', value => $1 };
1099             }
1100              
1101 15         89 my $decoded = eval { _decode_json($raw) };
  15         22  
1102 15 100       1847 if (!$@) {
1103 11         39 return { type => 'literal', value => $decoded };
1104             }
1105              
1106 4 100       13 if ($raw =~ /^'(.*)'$/) {
1107 2         5 my $text = $1;
1108 2         4 $text =~ s/\\'/'/g;
1109 2         7 return { type => 'literal', value => $text };
1110             }
1111              
1112 2         8 return { type => 'expression', value => $raw };
1113             }
1114              
1115             1;