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   1296 use strict;
  176         374  
  176         7563  
4 176     176   907 use warnings;
  176         359  
  176         8924  
5              
6 176     176   983 use JSON::PP ();
  176         323  
  176         4710  
7 176     176   851 use Scalar::Util qw(looks_like_number);
  176         396  
  176         11453  
8 176     176   992 use Encode qw(encode is_utf8);
  176         402  
  176         8601  
9 176     176   1084 use JQ::Lite::Expression ();
  176         1066  
  176         1560066  
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   3113 my $decoder = JSON::PP->new->utf8->allow_nonref;
17              
18 352 50       30498 if ($decoder->can('boolean_values')) {
19 352         1808 $decoder->boolean_values(JSON::PP::false, JSON::PP::true);
20             }
21              
22 352         7934 return $decoder;
23             }
24              
25             sub _encode_json {
26 195     195   1686 my ($value) = @_;
27 195         922 return $TOJSON_ENCODER->encode($value);
28             }
29              
30             sub _decode_json {
31 6894     6894   13739 my ($text) = @_;
32              
33 6894 100 66     34155 if (defined $text && is_utf8($text, 1)) {
34 6         47 $text = encode('UTF-8', $text);
35             }
36              
37 6894         23091 return $JSON_DECODER->decode($text);
38             }
39              
40             sub _are_brackets_balanced {
41 22     22   52 my ($text) = @_;
42              
43 22 50 33     119 return 1 unless defined $text && length $text;
44              
45 22         126 my %pairs = (
46             '(' => ')',
47             '[' => ']',
48             '{' => '}',
49             );
50 22         79 my %closing = reverse %pairs;
51              
52 22         43 my @stack;
53             my $string;
54 22         58 my $escape = 0;
55              
56 22         118 for my $char (split //, $text) {
57 231 100       417 if (defined $string) {
58 27 50       46 if ($escape) {
59 0         0 $escape = 0;
60 0         0 next;
61             }
62              
63 27 50       89 if ($char eq '\\') {
64 0         0 $escape = 1;
65 0         0 next;
66             }
67              
68 27 100       42 if ($char eq $string) {
69 6         11 undef $string;
70             }
71              
72 27         40 next;
73             }
74              
75 204 100 66     645 if ($char eq "'" || $char eq '"') {
76 6         10 $string = $char;
77 6         7 next;
78             }
79              
80 198 100       357 if (exists $pairs{$char}) {
81 6         10 push @stack, $char;
82 6         8 next;
83             }
84              
85 192 100       359 if (exists $closing{$char}) {
86 8 100       30 return 0 unless @stack;
87 6         13 my $open = pop @stack;
88 6 50       26 return 0 unless $pairs{$open} eq $char;
89 6         13 next;
90             }
91             }
92              
93 20   33     178 return !@stack && !defined $string;
94             }
95              
96             sub _strip_wrapping_parens {
97 6040     6040   10443 my ($text) = @_;
98              
99 6040 50       11904 return '' unless defined $text;
100              
101 6040         9414 my $copy = $text;
102 6040         28023 $copy =~ s/^\s+|\s+$//g;
103              
104 6040         16204 while ($copy =~ /^\((.*)\)$/s) {
105 22         73 my $inner = $1;
106 22 100       63 last unless _are_brackets_balanced($inner);
107 20         141 $inner =~ s/^\s+|\s+$//g;
108 20         92 $copy = $inner;
109             }
110              
111 6040         13815 return $copy;
112             }
113              
114             sub _split_top_level_semicolons {
115 8     8   18 my ($text) = @_;
116              
117 8 50       25 return unless defined $text;
118              
119 8         40 my %pairs = (
120             '(' => ')',
121             '[' => ']',
122             '{' => '}',
123             );
124 8         31 my %closing = reverse %pairs;
125              
126 8         16 my @stack;
127             my $string;
128 8         15 my $escape = 0;
129 8         24 my @parts;
130 8         14 my $start = 0;
131              
132 8         23 for (my $i = 0; $i < length $text; $i++) {
133 103         174 my $char = substr($text, $i, 1);
134              
135 103 100       188 if (defined $string) {
136 1 50       3 if ($escape) {
137 0         0 $escape = 0;
138 0         0 next;
139             }
140              
141 1 50       4 if ($char eq '\\') {
142 0         0 $escape = 1;
143 0         0 next;
144             }
145              
146 1 50       3 if ($char eq $string) {
147 1         1 undef $string;
148             }
149              
150 1         2 next;
151             }
152              
153 102 100 66     384 if ($char eq "'" || $char eq '"') {
154 1         2 $string = $char;
155 1         2 next;
156             }
157              
158 101 50       239 if (exists $pairs{$char}) {
159 0         0 push @stack, $char;
160 0         0 next;
161             }
162              
163 101 50       195 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       263 next unless $char eq ';';
171              
172 9 50       29 if (!@stack) {
173 9         23 my $chunk = substr($text, $start, $i - $start);
174 9         21 push @parts, $chunk;
175 9         31 $start = $i + 1;
176             }
177             }
178              
179 8 50       28 push @parts, substr($text, $start) if $start <= length $text;
180              
181 8         70 return @parts;
182             }
183              
184             sub _split_top_level_pipes {
185 1739     1739   6139 my ($text) = @_;
186              
187 1739 50       4241 return unless defined $text;
188              
189 1739         8157 my %pairs = (
190             '(' => ')',
191             '[' => ']',
192             '{' => '}',
193             );
194 1739         7670 my %closing = reverse %pairs;
195              
196 1739         3453 my @stack;
197             my $string;
198 1739         3082 my $escape = 0;
199 1739         2647 my @parts;
200 1739         2842 my $start = 0;
201              
202 1739         3008 my $length = length $text;
203 1739         2765 my $in_try = 0;
204 1739         5081 for (my $i = 0; $i < $length; $i++) {
205 20890         54082 my $char = substr($text, $i, 1);
206              
207 20890 100       37365 if (defined $string) {
208 1528 100       2832 if ($escape) {
209 8         14 $escape = 0;
210 8         18 next;
211             }
212              
213 1520 100       2908 if ($char eq '\\') {
214 8         14 $escape = 1;
215 8         19 next;
216             }
217              
218 1512 100       2937 if ($char eq $string) {
219 336         599 undef $string;
220             }
221              
222 1512         2850 next;
223             }
224              
225 19362 100 100     60531 if ($char eq "'" || $char eq '"') {
226 336         600 $string = $char;
227 336         705 next;
228             }
229              
230 19026 100       36207 if (exists $pairs{$char}) {
231 776         1858 push @stack, $char;
232 776         1780 next;
233             }
234              
235 18250 50 100     68902 if (!$in_try && !@stack && !defined $string) {
      66        
236 15265 100       34587 if (substr($text, $i) =~ /^try\b/) {
237 14         23 $in_try = 1;
238 14         939 next;
239             }
240             }
241              
242 18236 100 100     36188 if ($in_try && !@stack && !defined $string) {
      66        
243 101 100       276 if (substr($text, $i) =~ /^catch\b/) {
244 10         18 $in_try = 0;
245 10         26 next;
246             }
247             }
248              
249 18226 100       33521 if (exists $closing{$char}) {
250 776 50       1762 return unless @stack;
251 776         1598 my $open = pop @stack;
252 776 50       2303 return unless $pairs{$open} eq $char;
253 776         1995 next;
254             }
255              
256 17450 100       47848 next unless $char eq '|';
257 482 100       1205 next if $in_try;
258 480 50       1414 if (substr($text, $i, 2) eq '||') {
259 0         0 $i++;
260 0         0 next;
261             }
262              
263 480 100       1234 if (!@stack) {
264 474         1396 my $chunk = substr($text, $start, $i - $start);
265 474         1125 push @parts, $chunk;
266 474         1307 $start = $i + 1;
267             }
268             }
269              
270 1739 50       7054 push @parts, substr($text, $start) if $start <= $length;
271              
272 1739         11222 return @parts;
273             }
274              
275             sub _split_top_level_commas {
276 1494     1494   6095 my ($text) = @_;
277              
278 1494 50       3667 return unless defined $text;
279              
280 1494         9102 my %pairs = (
281             '(' => ')',
282             '[' => ']',
283             '{' => '}',
284             );
285 1494         6008 my %closing = reverse %pairs;
286              
287 1494         2810 my @stack;
288             my $string;
289 1494         2405 my $escape = 0;
290 1494         2388 my @parts;
291 1494         2390 my $start = 0;
292              
293 1494         4759 for (my $i = 0; $i < length $text; $i++) {
294 15207         23694 my $char = substr($text, $i, 1);
295              
296 15207 100       27297 if (defined $string) {
297 1635 100       2943 if ($escape) {
298 8         14 $escape = 0;
299 8         17 next;
300             }
301              
302 1627 100       4033 if ($char eq '\\') {
303 8         17 $escape = 1;
304 8         19 next;
305             }
306              
307 1619 100       2945 if ($char eq $string) {
308 339         857 undef $string;
309             }
310              
311 1619         3169 next;
312             }
313              
314 13572 100 100     40348 if ($char eq "'" || $char eq '"') {
315 339         570 $string = $char;
316 339         709 next;
317             }
318              
319 13233 100       24994 if (exists $pairs{$char}) {
320 706         1633 push @stack, $char;
321 706         1592 next;
322             }
323              
324 12527 100       22613 if (exists $closing{$char}) {
325 706 50       1667 return unless @stack;
326 706         1423 my $open = pop @stack;
327 706 50       1976 return unless $pairs{$open} eq $char;
328 706         1896 next;
329             }
330              
331 11821 100       29547 next unless $char eq ',';
332              
333 126 100       391 if (!@stack) {
334 38         96 my $chunk = substr($text, $start, $i - $start);
335 38         5073 push @parts, $chunk;
336 38         252 $start = $i + 1;
337             }
338             }
339              
340 1494 50       5371 push @parts, substr($text, $start) if $start <= length $text;
341              
342 1494         8595 return @parts;
343             }
344              
345             sub _split_top_level_operator {
346 1933     1933   5007 my ($text, $operator) = @_;
347              
348 1933 50 33     10449 return unless defined $text && defined $operator && length($operator) == 1;
      33        
349              
350 1933         6812 my %pairs = (
351             '(' => ')',
352             '[' => ']',
353             '{' => '}',
354             );
355 1933         6861 my %closing = reverse %pairs;
356              
357 1933         4511 my @stack;
358             my $string;
359 1933         3311 my $escape = 0;
360              
361 1933         5302 for (my $i = 0; $i < length $text; $i++) {
362 17009         26396 my $char = substr($text, $i, 1);
363              
364 17009 100       29580 if (defined $string) {
365 1473 100       2727 if ($escape) {
366 6         10 $escape = 0;
367 6         14 next;
368             }
369              
370 1467 100       2788 if ($char eq '\\') {
371 6         11 $escape = 1;
372 6         13 next;
373             }
374              
375 1461 100       2705 if ($char eq $string) {
376 322         593 undef $string;
377             }
378              
379 1461         3007 next;
380             }
381              
382 15536 100 100     45826 if ($char eq "'" || $char eq '"') {
383 322         599 $string = $char;
384 322         682 next;
385             }
386              
387 15214 100       28089 if (exists $pairs{$char}) {
388 711         1643 push @stack, $char;
389 711         1565 next;
390             }
391              
392 14503 100       26662 if (exists $closing{$char}) {
393 711 50       1535 return if !@stack;
394 711         1513 my $open = pop @stack;
395 711 50       1902 return if $pairs{$open} ne $char;
396 711         1804 next;
397             }
398              
399 13792 100       35604 next if $char ne $operator;
400              
401 68 100       234 if (!@stack) {
402 51 50 33     132 if ($operator eq '+' || $operator eq '-') {
403 51 50       151 my $prev = $i > 0 ? substr($text, $i - 1, 1) : '';
404 51 50       139 my $next = $i + 1 < length $text ? substr($text, $i + 1, 1) : '';
405 51 50 33     216 if ($prev =~ /[eE]/ && $next =~ /[0-9]/) {
406 0         0 next;
407             }
408 51 100       136 if ($next eq '=') {
409 2         6 next;
410             }
411             }
412              
413 49         105 my $lhs = substr($text, 0, $i);
414 49         108 my $rhs = substr($text, $i + 1);
415 49         246 return ($lhs, $rhs);
416             }
417             }
418              
419 1884         9948 return;
420             }
421              
422             sub _split_top_level_colon {
423 49     49   113 my ($text) = @_;
424              
425 49 50       115 return unless defined $text;
426              
427 49         245 my %pairs = (
428             '(' => ')',
429             '[' => ']',
430             '{' => '}',
431             );
432 49         176 my %closing = reverse %pairs;
433              
434 49         144 my @stack;
435             my $string;
436 49         101 my $escape = 0;
437              
438 49         165 for (my $i = 0; $i < length $text; $i++) {
439 313         482 my $char = substr($text, $i, 1);
440              
441 313 100       508 if (defined $string) {
442 132 50       235 if ($escape) {
443 0         0 $escape = 0;
444 0         0 next;
445             }
446              
447 132 50       362 if ($char eq '\\') {
448 0         0 $escape = 1;
449 0         0 next;
450             }
451              
452 132 100       229 if ($char eq $string) {
453 24         47 undef $string;
454             }
455              
456 132         226 next;
457             }
458              
459 181 100 66     542 if ($char eq "'" || $char eq '"') {
460 24         52 $string = $char;
461 24         69 next;
462             }
463              
464 157 50       348 if (exists $pairs{$char}) {
465 0         0 push @stack, $char;
466 0         0 next;
467             }
468              
469 157 50       342 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       355 next if $char ne ':';
477              
478 46 50       180 if (!@stack) {
479 46         102 my $lhs = substr($text, 0, $i);
480 46         137 my $rhs = substr($text, $i + 1);
481 46         314 return ($lhs, $rhs);
482             }
483             }
484              
485 3         23 return;
486             }
487              
488             sub _interpret_object_key {
489 13     13   39 my ($raw) = @_;
490              
491 13 50       32 return unless defined $raw;
492              
493 13         27 my $text = $raw;
494 13         82 $text =~ s/^\s+|\s+$//g;
495 13 50       34 return if $text eq '';
496              
497 13         25 my $decoded = eval { $FROMJSON_DECODER->decode($text) };
  13         88  
498 13 50 66     4536 if (!$@ && !ref $decoded) {
499 2         5 return $decoded;
500             }
501              
502 11 50       39 if ($text =~ /^'(.*)'$/s) {
503 0         0 my $inner = $1;
504 0         0 $inner =~ s/\\'/'/g;
505 0         0 return $inner;
506             }
507              
508 11         45 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   3870 my ($text, $pos, $keyword) = @_;
522              
523 2126 50       4061 return 0 unless defined $text;
524 2126 50       3972 return 0 if $pos < 0;
525              
526 2126         3000 my $kw_len = length $keyword;
527 2126 100       4065 return 0 if $pos + $kw_len > length $text;
528 2099 100       6370 return 0 if substr($text, $pos, $kw_len) ne $keyword;
529              
530 45 100       142 my $before = $pos == 0 ? '' : substr($text, $pos - 1, 1);
531 45 100       117 my $after = ($pos + $kw_len) < length $text ? substr($text, $pos + $kw_len, 1) : '';
532              
533 45 50       145 return 0 if $before =~ /[A-Za-z0-9_]/;
534 45 50       116 return 0 if $after =~ /[A-Za-z0-9_]/;
535              
536 45         222 return 1;
537             }
538              
539             sub _parse_if_expression {
540 1274     1274   2508 my ($expr) = @_;
541              
542 1274 50       3009 return undef unless defined $expr;
543              
544 1274         2457 my $copy = _strip_wrapping_parens($expr);
545 1274         5432 $copy =~ s/^\s+|\s+$//g;
546 1274 100       5749 return undef unless $copy =~ /^if\b/;
547              
548 9         17 my $len = length $copy;
549 9         19 my $pos = 0;
550              
551 9 50       28 return undef unless _matches_keyword($copy, $pos, 'if');
552 9         16 $pos += 2;
553              
554 9         17 my $depth = 1;
555 9         22 my $state = 'condition';
556 9         17 my $current = '';
557 9         25 my $condition;
558             my @branches;
559 9         0 my $else_expr;
560              
561 9         24 my $in_single = 0;
562 9         14 my $in_double = 0;
563 9         15 my $escape = 0;
564              
565 9         23 while ($pos < $len) {
566 333         572 my $char = substr($copy, $pos, 1);
567              
568 333 50       638 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       688 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       643 if ($in_double) {
588 36 50       104 if ($char eq '\\') {
    100          
589 0         0 $escape = 1;
590             }
591             elsif ($char eq '"') {
592 14         75 $in_double = 0;
593             }
594 36         55 $current .= $char;
595 36         51 $pos++;
596 36         71 next;
597             }
598              
599 297 50       593 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       567 if ($char eq '"') {
607 14         29 $in_double = 1;
608 14         24 $current .= $char;
609 14         18 $pos++;
610 14         35 next;
611             }
612              
613 283 100       533 if (_matches_keyword($copy, $pos, 'if')) {
614 1         3 $depth++;
615 1         2 $current .= 'if';
616 1         2 $pos += 2;
617 1         4 next;
618             }
619              
620 282 100 100     490 if (_matches_keyword($copy, $pos, 'then') && $depth == 1 && $state eq 'condition') {
      66        
621 11         21 $condition = $current;
622 11         108 $condition =~ s/^\s+|\s+$//g;
623 11 50 33     66 return undef unless defined $condition && length $condition;
624              
625 11         32 $current = '';
626 11         20 $state = 'then';
627 11         18 $pos += 4;
628 11         33 next;
629             }
630              
631 271 50 66     472 if (_matches_keyword($copy, $pos, 'elif') && $depth == 1 && $state eq 'then') {
      66        
632 2         4 my $then_expr = $current;
633 2         15 $then_expr =~ s/^\s+|\s+$//g;
634 2 50       8 $then_expr = '.' if !length $then_expr;
635              
636 2 50       4 return undef unless defined $condition;
637 2         11 push @branches, { condition => $condition, then => $then_expr };
638              
639 2         5 $condition = undef;
640 2         4 $current = '';
641 2         3 $state = 'condition';
642 2         4 $pos += 4;
643 2         7 next;
644             }
645              
646 269 100 100     464 if (_matches_keyword($copy, $pos, 'else') && $depth == 1 && $state eq 'then') {
      66        
647 8         18 my $then_expr = $current;
648 8         82 $then_expr =~ s/^\s+|\s+$//g;
649 8 50       43 $then_expr = '.' if !length $then_expr;
650              
651 8 50       41 return undef unless defined $condition;
652 8         49 push @branches, { condition => $condition, then => $then_expr };
653              
654 8         15 $condition = undef;
655 8         15 $current = '';
656 8         38 $state = 'else';
657 8         16 $pos += 4;
658 8         24 next;
659             }
660              
661 261 100       496 if (_matches_keyword($copy, $pos, 'end')) {
662 10 100       28 if ($depth == 1) {
663 9 100       34 if ($state eq 'then') {
    50          
    0          
664 1         3 my $then_expr = $current;
665 1         10 $then_expr =~ s/^\s+|\s+$//g;
666 1 50       5 $then_expr = '.' if !length $then_expr;
667              
668 1 50       4 return undef unless defined $condition;
669 1         5 push @branches, { condition => $condition, then => $then_expr };
670             }
671             elsif ($state eq 'else') {
672 8         15 my $else = $current;
673 8         62 $else =~ s/^\s+|\s+$//g;
674 8 50       41 $else_expr = length $else ? $else : undef;
675             }
676             elsif ($state eq 'condition') {
677 0         0 return undef;
678             }
679              
680 9         17 $depth = 0;
681 9         15 $pos += 3;
682 9         16 $current = '';
683 9         17 $state = 'done';
684 9         25 last;
685             }
686             else {
687 1         3 $depth--;
688 1         2 $current .= 'end';
689 1         3 $pos += 3;
690 1         3 next;
691             }
692             }
693              
694 251 100 66     467 if (_matches_keyword($copy, $pos, 'then') && $depth > 1) {
695 1         3 $current .= 'then';
696 1         3 $pos += 4;
697 1         19 next;
698             }
699              
700 250 50 33     444 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     407 if (_matches_keyword($copy, $pos, 'else') && $depth > 1) {
707 1         3 $current .= 'else';
708 1         2 $pos += 4;
709 1         4 next;
710             }
711              
712 249         447 $current .= $char;
713 249         491 $pos++;
714             }
715              
716 9 50       21 return undef unless @branches;
717              
718 9 50       21 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         77 branches => \@branches,
726             else => $else_expr,
727             };
728             }
729              
730             sub _parse_reduce_expression {
731 1265     1265   2716 my ($expr) = @_;
732              
733 1265 50       3021 return undef unless defined $expr;
734              
735 1265         2463 my $copy = _strip_wrapping_parens($expr);
736 1265 100       5258 return undef unless $copy =~ /^reduce\s+(.+?)\s+as\s+\$(\w+)\s*\((.*)\)$/s;
737              
738 4         30 my ($generator, $var_name, $body) = ($1, $2, $3);
739 4         13 my @parts = _split_top_level_semicolons($body);
740 4 50       14 return undef unless @parts == 2;
741 4         12 my ($init_expr, $update_expr) = @parts;
742              
743 4         21 $generator =~ s/^\s+|\s+$//g;
744 4         14 $init_expr =~ s/^\s+|\s+$//g;
745 4         33 $update_expr =~ s/^\s+|\s+$//g;
746              
747             return {
748 4         45 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   2888 my ($expr) = @_;
757              
758 1278 50       2999 return undef unless defined $expr;
759              
760 1278         3004 my $copy = _strip_wrapping_parens($expr);
761 1278 100       8455 return undef unless $copy =~ /^foreach\s+(.+?)\s+as\s+\$(\w+)\s*\((.*)\)$/s;
762              
763 4         30 my ($generator, $var_name, $body) = ($1, $2, $3);
764 4         12 my @parts = _split_top_level_semicolons($body);
765 4 50 33     17 return undef unless @parts >= 2 && @parts <= 3;
766              
767 4         13 my ($init_expr, $update_expr, $extract_expr) = @parts;
768              
769 4         32 for ($generator, $init_expr, $update_expr) {
770 12 50       21 next unless defined $_;
771 12         53 s/^\s+|\s+$//g;
772             }
773              
774 4 100       8 if (defined $extract_expr) {
775 1         5 $extract_expr =~ s/^\s+|\s+$//g;
776             }
777              
778             return {
779 4         37 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   122 my ($self, $name) = @_;
789              
790 48 50 33     257 return (undef, 0) unless defined $self && ref($self) eq 'JQ::Lite';
791 48 50 33     224 return (undef, 0) unless defined $name && length $name;
792              
793 48   50     153 my $vars = $self->{_vars} || {};
794 48 100       164 return (undef, 0) unless exists $vars->{$name};
795              
796 47         153 return ($vars->{$name}, 1);
797             }
798              
799             sub _evaluate_variable_reference {
800 48     48   117 my ($self, $name, $suffix) = @_;
801              
802 48         168 my ($value, $exists) = _resolve_variable_reference($self, $name);
803 48 100       139 return () unless $exists;
804              
805 47 100 66     280 return ($value) if !defined $suffix || $suffix !~ /\S/;
806              
807 9         21 my $expr = $suffix;
808 9         27 $expr =~ s/^\s+//;
809              
810 9         45 my ($values, $ok) = _evaluate_value_expression($self, $value, $expr);
811 9 50       57 return $ok ? @$values : ();
812             }
813              
814             sub _evaluate_value_expression {
815 771     771   2199 my ($self, $context, $expr) = @_;
816              
817 771 50       1941 return ([], 0) unless defined $expr;
818              
819 771         1952 my $copy = _strip_wrapping_parens($expr);
820 771         3015 $copy =~ s/^\s+|\s+$//g;
821 771 50       2182 return ([], 0) if $copy eq '';
822              
823 771 100       1785 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         4 return _tonumber($value);
843             },
844 62         1197 );
845              
846             my ($ok, $value) = JQ::Lite::Expression::evaluate(
847             expr => $copy,
848             context => $context,
849             resolve_path => sub {
850 17     17   43 my ($ctx, $path) = @_;
851 17 50 33     69 return $ctx if !defined $path || $path eq '';
852 17         68 my @values = _traverse($ctx, $path);
853 17 50       64 return @values ? $values[0] : undef;
854             },
855 62         644 coerce_number => \&_coerce_number_strict,
856             builtins => \%builtins,
857             );
858              
859 55 100       913 if ($ok) {
860 6         86 return ([ $value ], 1);
861             }
862             }
863              
864 758         2022 my @pipeline_parts = _split_top_level_pipes($copy);
865 758 100       2189 if (@pipeline_parts > 1) {
866 5 50 33     92 if (defined $self && $self->can('run_query')) {
867 5         18 my $json = _encode_json($context);
868 5         1434 my @outputs = $self->run_query($json, $copy);
869 5         29 return ([ @outputs ], 1);
870             }
871             }
872              
873 753 100       2207 if ($copy =~ /^\$(\w+)(.*)$/s) {
874 32   50     139 my ($var, $suffix) = ($1, $2 // '');
875 32         107 my @values = _evaluate_variable_reference($self, $var, $suffix);
876 32         126 return (\@values, 1);
877             }
878              
879 721 100       2005 if ($copy =~ /^\[(.*)$/s) {
880 1         2 $copy = ".$copy";
881             }
882              
883 721 100       2010 if ($copy eq '.') {
884 31         144 return ([ $context ], 1);
885             }
886              
887 690 100       2067 if ($copy =~ /^\.(.*)$/s) {
888 128         355 my $path = $1;
889 128         553 $path =~ s/^\s+|\s+$//g;
890              
891 128 50 66     681 if ($path !~ /\s/ && $path !~ /[+\-*\/]/) {
892 70 50       164 return ([], 1) unless defined $context;
893 70 50       148 return ([], 1) if $path eq '';
894              
895 70         342 my @values = _traverse($context, $path);
896 70         297 return (\@values, 1);
897             }
898             }
899              
900 620         1679 my ($lhs_expr, $rhs_expr) = _split_top_level_operator($copy, '+');
901 620 100 66     1965 if (defined $lhs_expr && defined $rhs_expr) {
902 37         188 $lhs_expr =~ s/^\s+|\s+$//g;
903 37         177 $rhs_expr =~ s/^\s+|\s+$//g;
904              
905 37 50 33     162 if (length $lhs_expr && length $rhs_expr) {
906 37         141 my ($lhs_values, $lhs_ok) = _evaluate_value_expression($self, $context, $lhs_expr);
907 37         61 my $lhs;
908 37 50       81 if ($lhs_ok) {
909 37 50       93 $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         78 my ($rhs_values, $rhs_ok) = _evaluate_value_expression($self, $context, $rhs_expr);
917 37         60 my $rhs;
918 37 50       81 if ($rhs_ok) {
919 37 50       90 $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         89 my $combined = _apply_addition($lhs, $rhs);
927 35         167 return ([ $combined ], 1);
928             }
929             }
930              
931 583         1118 my $decoded = eval { _decode_json($copy) };
  583         1654  
932 583 100       209520 if (!$@) {
933 47         213 return ([ $decoded ], 1);
934             }
935              
936 536 50       2166 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     9014 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         71 my $bool = _evaluate_condition($context, $copy);
948 13 100       76 my $json_bool = $bool ? JSON::PP::true : JSON::PP::false;
949 13         130 return ([ $json_bool ], 1);
950             }
951              
952 523         3076 return ([], 0);
953             }
954              
955             sub _apply_addition {
956 46     46   92 my ($left, $right) = @_;
957              
958 46 50       116 return $right if !defined $left;
959 46 50       132 return $left if !defined $right;
960              
961 46 50       117 if (ref($left) eq 'JSON::PP::Boolean') {
962 0 0       0 $left = $left ? 1 : 0;
963             }
964              
965 46 50       152 if (ref($right) eq 'JSON::PP::Boolean') {
966 0 0       0 $right = $right ? 1 : 0;
967             }
968              
969 46 50 66     183 if (!ref $left && !ref $right) {
970 45         171 my $left_is_string = _is_string_scalar($left);
971 45         109 my $right_is_string = _is_string_scalar($right);
972              
973 45 100 66     172 if ($left_is_string || $right_is_string) {
974 13 100 66     124 die 'addition operands must both be strings' if !$left_is_string || !$right_is_string;
975 10 50       23 $left = '' unless defined $left;
976 10 50       18 $right = '' unless defined $right;
977 10         36 return "$left$right";
978             }
979              
980 32 50 33     198 if (looks_like_number($left) && looks_like_number($right)) {
981 32         110 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       2 if (ref $left eq 'ARRAY') {
992 0         0 return [ @$left, $right ];
993             }
994              
995 1 50       3 if (ref $right eq 'ARRAY') {
996 0         0 return [ $left, @$right ];
997             }
998              
999 1 50 33     4 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   61 my ($value, $label) = @_;
1011              
1012 30   50     63 $label ||= 'value';
1013              
1014 30 50       64 die "$label must be a number" unless defined $value;
1015              
1016 30 50       74 if (ref($value) eq 'JSON::PP::Boolean') {
1017 0 0       0 return $value ? 1 : 0;
1018             }
1019              
1020 30 50       59 die "$label must be a number" if ref $value;
1021 30 50       94 die "$label must be a number" unless looks_like_number($value);
1022              
1023 30         68 return 0 + $value;
1024             }
1025              
1026             sub _tonumber {
1027 3     3   8 my ($value) = @_;
1028              
1029 3 50       11 return undef unless defined $value;
1030              
1031 3 50       9 if (ref($value) eq 'JSON::PP::Boolean') {
1032 0 0       0 return $value ? 1 : 0;
1033             }
1034              
1035 3 50       34 if (ref $value) {
1036 0         0 die 'tonumber(): argument must be a string or number';
1037             }
1038              
1039 3         9 my $text = "$value";
1040 3         19 $text =~ s/^\s+|\s+$//g;
1041              
1042 3 50 33     25 die 'tonumber(): not a numeric string' unless length $text && looks_like_number($text);
1043              
1044 3         16 return 0 + $text;
1045             }
1046              
1047             sub _looks_like_expression {
1048 2118     2118   4306 my ($expr) = @_;
1049              
1050 2118 50       8735 return 0 unless defined $expr;
1051              
1052 2118 100       8129 return 1 if $expr =~ /\b(?:floor|ceil|round|tonumber)\b/;
1053 2083 100       6299 return 0 if $expr =~ /^\s*[\{\[]/;
1054 2059 100       7532 return 0 if $expr =~ /^[A-Za-z_]\w*\s*\(/;
1055 1632 100       4407 return 1 if $expr =~ /[\-*\/%]/;
1056 1589 100       8261 return 1 if $expr =~ /(?:==|!=|>=|<=|>|<|\band\b|\bor\b)/i;
1057              
1058 1546         4623 return 0;
1059             }
1060              
1061             sub _looks_like_assignment {
1062 1184     1184   2398 my ($expr) = @_;
1063              
1064 1184 50       2840 return 0 unless defined $expr;
1065 1184 100       5819 return 0 if $expr =~ /[()]/;
1066 795 50       3343 return 0 if $expr =~ /(?:==|!=|>=|<=|=>|=<)/;
1067 795         3205 return ($expr =~ /=/);
1068             }
1069              
1070             sub _parse_assignment_expression {
1071 16     16   50 my ($expr) = @_;
1072              
1073 16   50     39 $expr //= '';
1074              
1075 16         184 my ($lhs, $op, $rhs) = ($expr =~ /^(.*?)\s*([+\-*\/]?=)\s*(.*)$/);
1076              
1077 16   50     48 $lhs //= '';
1078 16   50     58 $rhs //= '';
1079 16   50     32 $op //= '=';
1080              
1081 16         71 $lhs =~ s/^\s+|\s+$//g;
1082 16         48 $rhs =~ s/^\s+|\s+$//g;
1083              
1084 16         36 $lhs =~ s/^\.//;
1085              
1086 16         40 my $value_spec = _parse_assignment_value($rhs);
1087              
1088 16         74 return ($lhs, $value_spec, $op);
1089             }
1090              
1091             sub _parse_assignment_value {
1092 16     16   45 my ($raw) = @_;
1093              
1094 16   50     41 $raw //= '';
1095 16         52 $raw =~ s/^\s+|\s+$//g;
1096              
1097 16 100       40 if ($raw =~ /^\.(.+)$/) {
1098 1         8 return { type => 'path', value => $1 };
1099             }
1100              
1101 15         79 my $decoded = eval { _decode_json($raw) };
  15         33  
1102 15 100       2998 if (!$@) {
1103 11         60 return { type => 'literal', value => $decoded };
1104             }
1105              
1106 4 100       24 if ($raw =~ /^'(.*)'$/) {
1107 2         7 my $text = $1;
1108 2         8 $text =~ s/\\'/'/g;
1109 2         11 return { type => 'literal', value => $text };
1110             }
1111              
1112 2         9 return { type => 'expression', value => $raw };
1113             }
1114              
1115             1;