File Coverage

File:blib/lib/Database/BI/Calc.pm
Coverage:84.5%

linestmtbrancondsubtimecode
1package Database::BI::Calc;
2
3
3
3
3
3
118929
2
36
use strict;
4
3
3
3
3
5
2
97
use warnings;
5
6
3
3
3
3
7
2
80
use Carp        qw(croak);
7
3
3
3
3
5
3
12
use POSIX       qw(floor ceil);
8
3
3
3
3
945
1460
63
use Readonly;
9
3
3
3
3
6
2
5136
use Scalar::Util        qw(looks_like_number);
10
11our $VERSION = '0.012.0';
12
13Readonly my $MAX_EXPR_LEN => 512;
14Readonly my $MAX_DEPTH    => 20;
15
16# --- token type constants ---
17Readonly my $T_NUM    => 'NUM';
18Readonly my $T_STR    => 'STR';
19Readonly my $T_IDENT  => 'IDENT';
20Readonly my $T_PLUS   => 'PLUS';
21Readonly my $T_MINUS  => 'MINUS';
22Readonly my $T_STAR   => 'STAR';
23Readonly my $T_SLASH  => 'SLASH';
24Readonly my $T_LPAREN => 'LPAREN';
25Readonly my $T_RPAREN => 'RPAREN';
26Readonly my $T_COMMA  => 'COMMA';
27Readonly my $T_EOF    => 'EOF';
28
29# Comparison operator tokens (two-char forms checked before single-char forms)
30Readonly my $T_EQ  => 'EQ';  # =
31Readonly my $T_NEQ => 'NEQ'; # !=
32Readonly my $T_LT  => 'LT';  # <
33Readonly my $T_LE  => 'LE';  # <=
34Readonly my $T_GT  => 'GT';  # >
35Readonly my $T_GE  => 'GE';  # >=
36
37our %MESSAGES = (
38        error_expr_too_long   => 'Expression too long (max %d characters)',
39        error_expr_too_deep   => 'Expression nesting too deep (max %d levels)',
40        error_unknown_fn      => "Unknown function '%s'",
41        error_unknown_col     => "Unknown column '%s'",
42        error_unexpected_tok  => "Unexpected token '%s' at position %d",
43        error_expected_tok    => "Expected '%s' at position %d, got '%s'",
44        error_unterminated    => 'Unterminated string at position %d',
45        error_bad_char        => "Unexpected character '%s' at position %d",
46        error_trailing        => "Unexpected token '%s' at position %d",
47        error_double_eq       => "Use = not == for equality comparison at position %d",
48);
49
50sub _fmt {
51
27
27
28
        my ($key, @args) = @_;
52
27
1023
        return sprintf $MESSAGES{$key}, @args;
53}
54
55# --- built-in function dispatch table ---
56# 'if' is handled as a special form in _parse_call (short-circuit branches).
57# All date functions accept ISO-8601 'YYYY-MM-DD' prefix only; non-matching
58# values return undef and appear in the empty-cell bucket rather than being
59# dropped.
60
61my %FUNCTIONS = (
62        # --- string functions ---
63        upper    => sub { defined $_[0] ? uc($_[0])      : undef },
64        lower    => sub { defined $_[0] ? lc($_[0])      : undef },
65        trim     => sub {
66                return undef unless defined $_[0];
67                my $s = $_[0];
68                $s =~ s/\A\s+|\s+\z//g;
69                $s;
70        },
71        len      => sub { defined $_[0] ? length($_[0])  : undef },
72        concat   => sub { join '', map { defined $_ ? $_ : '' } @_ },
73        substr   => sub {
74                my ($s, $start, $len) = @_;
75                return undef unless defined $s;
76                $start //= 0;
77                defined $len ? CORE::substr($s, $start, $len)
78                             : CORE::substr($s, $start);
79        },
80
81        # --- numeric functions ---
82        round    => sub {
83                my ($n, $d) = @_;
84                return undef unless defined $n && looks_like_number($n);
85                $d = (defined $d && looks_like_number($d)) ? int($d) : 0;
86                sprintf("%.${d}f", $n) + 0;
87        },
88        floor    => sub {
89                defined $_[0] && looks_like_number($_[0]) ? POSIX::floor($_[0]) : undef;
90        },
91        ceil     => sub {
92                defined $_[0] && looks_like_number($_[0]) ? POSIX::ceil($_[0]) : undef;
93        },
94        'abs'    => sub {
95                defined $_[0] && looks_like_number($_[0]) ? CORE::abs($_[0]) : undef;
96        },
97
98        # --- conditional / null-handling ---
99        isnull   => sub { defined $_[0] ? $_[0] : $_[1] },
100        coalesce => sub {
101                for my $v (@_) { return $v if defined $v }
102                return undef;
103        },
104
105        # --- date functions (ISO-8601 YYYY-MM-DD prefix; no external module) ---
106        year => sub {
107                return undef unless defined $_[0] && $_[0] =~ /\A(\d{4})-\d\d-\d\d/;
108                $1 + 0;
109        },
110        month => sub {
111                return undef unless defined $_[0] && $_[0] =~ /\A\d{4}-(\d\d)-\d\d/;
112                $1 + 0;
113        },
114        day => sub {
115                return undef unless defined $_[0] && $_[0] =~ /\A\d{4}-\d\d-(\d\d)/;
116                $1 + 0;
117        },
118        quarter => sub {
119                return undef unless defined $_[0] && $_[0] =~ /\A\d{4}-(\d\d)-/;
120                int(($1 - 1) / 3) + 1;
121        },
122        week => sub {
123                # Returns ISO 8601 week number (1-53); week containing the first
124                # Thursday of the year is week 1.
125                return undef unless defined $_[0] && $_[0] =~ /\A(\d{4})-(\d\d)-(\d\d)/;
126                my ($yr, $mo, $dy) = ($1 + 0, $2 + 0, $3 + 0);
127                my $t  = POSIX::mktime(0, 0, 12, $dy, $mo - 1, $yr - 1900);
128                my @lt = localtime($t);
129                POSIX::strftime('%V', @lt) + 0;
130        },
131        month_name => sub {
132                # Returns full English month name, e.g. 'January'.
133                my @M = qw(January February March April May June
134                           July August September October November December);
135                return undef unless defined $_[0] && $_[0] =~ /\A\d{4}-(\d\d)-/;
136                $M[$1 - 1] // undef;
137        },
138        weekday => sub {
139                # Returns ISO 8601 weekday: 1 = Monday, 7 = Sunday.
140                return undef unless defined $_[0] && $_[0] =~ /\A(\d{4})-(\d\d)-(\d\d)/;
141                my ($yr, $mo, $dy) = ($1 + 0, $2 + 0, $3 + 0);
142                my $t  = POSIX::mktime(0, 0, 12, $dy, $mo - 1, $yr - 1900);
143                my $wd = (localtime($t))[6];    # 0 = Sunday
144                $wd == 0 ? 7 : $wd;
145        },
146        now => sub {
147                # Returns today's date as 'YYYY-MM-DD'.  Takes no arguments.
148                my @t = (localtime)[3, 4, 5];   # mday, mon (0-based), year (since 1900)
149                sprintf '%04d-%02d-%02d', $t[2] + 1900, $t[1] + 1, $t[0];
150        },
151
152        # --- grouping / binning ---
153        bin => sub {
154                # bin(value, width) -> '[lo,hi)' label for the interval containing value.
155                # Width must be a positive number.  Both endpoints use %d when width is
156                # an integer, %g otherwise, to avoid spurious ".0" suffixes.
157                my ($v, $w) = @_;
158                return undef unless defined $v && defined $w;
159                return undef unless looks_like_number($v) && looks_like_number($w) && $w > 0;
160                my $lo  = POSIX::floor($v / $w) * $w;
161                my $hi  = $lo + $w;
162                my $fmt = ($w == int($w)) ? '%d' : '%g';
163                sprintf("[${fmt},${fmt})", $lo, $hi);
164        },
165);
166
167# ---------------------------------------------------------------------------
168# Constructor
169# ---------------------------------------------------------------------------
170
171sub new {
172
108
108
35519
        my ($class, %args) = @_;
173
108
139
        my $self = bless {
174                _error   => undef,
175                _code    => undef,
176                _columns => {},
177        }, $class;
178
179
108
50
117
        my $expr = $args{expr} // '';
180
108
108
50
54
110
        my @cols = @{ $args{columns} // [] };
181
108
137
        $self->{_columns}{$_} = 1 for @cols;
182
183
108
100
119
        if (length($expr) > $MAX_EXPR_LEN) {
184
1
3
                $self->{_error} = _fmt('error_expr_too_long', $MAX_EXPR_LEN);
185
1
1
                return $self;
186        }
187
188
107
221
        my $tokens;
189
107
107
93
58
98
67
        my $ok = eval { $tokens = _tokenize($expr); 1 };
190
107
100
1482
        unless ($ok) {
191
14
14
11
33
                my $err = $@; $err =~ s/ at \S+ line \d+\.?\n?$//;
192
14
97
                $self->{_error} = $err;
193
14
20
                return $self;
194        }
195
196
93
53
        my $pos   = 0;
197
93
44
        my $depth = 0;
198
93
53
        my $code;
199
93
93
82
39
88
55
        $ok = eval { $code = _parse_cmp($tokens, \$pos, \$depth, $self->{_columns}); 1 };
200
93
100
1963
        unless ($ok) {
201
11
11
10
38
                my $err = $@; $err =~ s/ at \S+ line \d+\.?\n?$//;
202
11
88
                $self->{_error} = $err;
203
11
31
                return $self;
204        }
205
206
82
100
68
        if ($tokens->[$pos]{type} ne $T_EOF) {
207                $self->{_error} = _fmt('error_trailing',
208
1
4
                        $tokens->[$pos]{val}, $tokens->[$pos]{pos});
209
1
7
                return $self;
210        }
211
212
81
161
        $self->{_code} = $code;
213
81
187
        return $self;
214}
215
216# ---------------------------------------------------------------------------
217# Public API
218# ---------------------------------------------------------------------------
219
220
28
28
50
sub error     { $_[0]->{_error} }
221
107
107
185
sub has_error { defined $_[0]->{_error} }
222
223sub evaluate {
224
94
94
109
        my ($self, $row) = @_;
225
94
50
84
        return undef unless defined $self->{_code};
226
94
41
        my $result;
227
94
94
94
52
69
158
        my $ok = eval { $result = $self->{_code}->($row); 1 };
228
94
50
68
        return undef unless $ok;
229
94
81
        return $result;
230}
231
232# ---------------------------------------------------------------------------
233# Tokenizer
234# ---------------------------------------------------------------------------
235
236sub _tokenize {
237
107
107
67
        my ($expr) = @_;
238
107
61
        my @tokens;
239
107
55
        my $pos = 0;
240
107
69
        my $len = length($expr);
241
107
110
        my %single_ops = (
242                '+' => $T_PLUS, '-' => $T_MINUS,
243                '*' => $T_STAR, '/' => $T_SLASH,
244                '(' => $T_LPAREN, ')' => $T_RPAREN, ',' => $T_COMMA,
245        );
246
247
107
988
        while ($pos < $len) {
248
598
350
                my $ch = substr($expr, $pos, 1);
249
250                # skip whitespace
251
598
110
110
100
439
47
79
                if ($ch =~ /\A\s/) { $pos++; next }
252
253                # number literal (integer, decimal, scientific)
254
488
100
456
                if (substr($expr, $pos) =~ /\A(\d+(?:\.\d+)?(?:[eE][+-]?\d+)?)/) {
255
96
69
                        push @tokens, { type => $T_NUM, val => $1, pos => $pos };
256
96
203
                        $pos += length($1);
257
96
62
                        next;
258                }
259
260                # double-quoted string
261
392
100
268
                if ($ch eq '"') {
262
9
15
                        my $end = index($expr, '"', $pos + 1);
263
9
100
13
                        croak _fmt('error_unterminated', $pos) if $end < 0;
264
8
14
                        push @tokens, {
265                                type => $T_STR,
266                                val  => substr($expr, $pos + 1, $end - $pos - 1),
267                                pos  => $pos,
268                        };
269
8
19
                        $pos = $end + 1;
270
8
7
                        next;
271                }
272
273                # single-quoted string
274
383
50
240
                if ($ch eq "'") {
275
0
0
                        my $end = index($expr, "'", $pos + 1);
276
0
0
0
                        croak _fmt('error_unterminated', $pos) if $end < 0;
277
0
0
                        push @tokens, {
278                                type => $T_STR,
279                                val  => substr($expr, $pos + 1, $end - $pos - 1),
280                                pos  => $pos,
281                        };
282
0
0
                        $pos = $end + 1;
283
0
0
                        next;
284                }
285
286                # identifier: letters/digits/underscore, leading letter or _
287
383
100
338
                if (substr($expr, $pos) =~ /\A([a-zA-Z_][a-zA-Z0-9_]*)/) {
288
129
124
                        push @tokens, { type => $T_IDENT, val => $1, pos => $pos };
289
129
345
                        $pos += length($1);
290
129
107
                        next;
291                }
292
293                # two-character comparison operators (must be tested before single-char)
294
254
100
166
                if ($pos + 1 < $len) {
295
202
113
                        my $two = substr($expr, $pos, 2);
296
202
100
125
                        if ($two eq '!=') {
297
2
2
                                push @tokens, { type => $T_NEQ, val => '!=', pos => $pos };
298
2
2
4
2
                                $pos += 2; next;
299                        }
300
200
100
127
                        if ($two eq '<=') {
301
3
4
                                push @tokens, { type => $T_LE, val => '<=', pos => $pos };
302
3
3
5
3
                                $pos += 2; next;
303                        }
304
197
100
128
                        if ($two eq '>=') {
305
3
1
                                push @tokens, { type => $T_GE, val => '>=', pos => $pos };
306
3
3
7
3
                                $pos += 2; next;
307                        }
308
194
100
105
                        if ($two eq '==') {
309
2
4
                                croak _fmt('error_double_eq', $pos);
310                        }
311                }
312
313                # single-character comparison operators
314
244
100
158
                if ($ch eq '=') {
315
4
4
                        push @tokens, { type => $T_EQ, val => '=', pos => $pos };
316
4
4
6
3
                        $pos++; next;
317                }
318
240
100
123
                if ($ch eq '<') {
319
3
3
                        push @tokens, { type => $T_LT, val => '<', pos => $pos };
320
3
3
6
2
                        $pos++; next;
321                }
322
237
100
143
                if ($ch eq '>') {
323
7
5
                        push @tokens, { type => $T_GT, val => '>', pos => $pos };
324
7
7
16
5
                        $pos++; next;
325                }
326
327                # single-character arithmetic operators and punctuation
328
230
100
151
                if (exists $single_ops{$ch}) {
329
219
208
                        push @tokens, { type => $single_ops{$ch}, val => $ch, pos => $pos };
330
219
116
                        $pos++;
331
219
149
                        next;
332                }
333
334
11
10
                croak _fmt('error_bad_char', $ch, $pos);
335        }
336
337
93
81
        push @tokens, { type => $T_EOF, val => '', pos => $pos };
338
93
240
        return \@tokens;
339}
340
341# ---------------------------------------------------------------------------
342# Parser  (each _parse_* returns a coderef  sub { my ($row) = @_; ... })
343# ---------------------------------------------------------------------------
344
345sub _check_depth {
346
395
395
226
        my ($depth_ref) = @_;
347
395
100
262
        croak _fmt('error_expr_too_deep', $MAX_DEPTH) if $$depth_ref >= $MAX_DEPTH;
348}
349
350sub _expect {
351
50
50
40
        my ($tokens, $pos_ref, $expected) = @_;
352
50
84
        my $tok = $tokens->[$$pos_ref];
353        croak _fmt('error_expected_tok', $expected, $tok->{pos}, $tok->{val})
354
50
50
40
                unless $tok->{type} eq $expected;
355
50
35
        $$pos_ref++;
356}
357
358# cmp_expr ::= add_expr (cmp_op add_expr)?
359# Comparison yields 1 (true), 0 (false), or undef (either operand undef).
360# When both operands look numeric, numeric comparison is used; otherwise
361# case-insensitive string comparison, matching _apply_filter_spec semantics.
362sub _parse_cmp {
363
187
187
120
        my ($tokens, $pos_ref, $depth_ref, $cols) = @_;
364
187
144
        _check_depth($depth_ref);
365
186
322
        $$depth_ref++;
366
367
186
134
        my $left = _parse_add($tokens, $pos_ref, $depth_ref, $cols);
368
369
166
97
        my $type = $tokens->[$$pos_ref]{type};
370
166
100
100
111
        if ($type eq $T_EQ || $type eq $T_NEQ
371         || $type eq $T_LT || $type eq $T_LE
372         || $type eq $T_GT || $type eq $T_GE) {
373
22
128
                my $op = $type;
374
22
14
                $$pos_ref++;
375
22
15
                my $right = _parse_add($tokens, $pos_ref, $depth_ref, $cols);
376
22
11
                my ($l, $r) = ($left, $right);
377                $left = sub {
378
25
25
18
                        my $lv = $l->($_[0]);
379
25
21
                        my $rv = $r->($_[0]);
380
25
100
67
32
                        return undef unless defined $lv && defined $rv;
381
24
100
67
37
                        if (looks_like_number($lv) && looks_like_number($rv)) {
382
22
100
100
100
100
100
100
100
100
100
100
100
20
                                return $op eq $T_EQ  ? ($lv == $rv ? 1 : 0)
383                                     : $op eq $T_NEQ ? ($lv != $rv ? 1 : 0)
384                                     : $op eq $T_LT  ? ($lv <  $rv ? 1 : 0)
385                                     : $op eq $T_LE  ? ($lv <= $rv ? 1 : 0)
386                                     : $op eq $T_GT  ? ($lv >  $rv ? 1 : 0)
387                                     :                 ($lv >= $rv ? 1 : 0);
388                        } else {
389
2
3
                                my $cmp = lc($lv) cmp lc($rv);
390
2
50
0
50
0
0
0
0
0
50
50
100
2
                                return $op eq $T_EQ  ? ($cmp == 0 ? 1 : 0)
391                                     : $op eq $T_NEQ ? ($cmp != 0 ? 1 : 0)
392                                     : $op eq $T_LT  ? ($cmp <  0 ? 1 : 0)
393                                     : $op eq $T_LE  ? ($cmp <= 0 ? 1 : 0)
394                                     : $op eq $T_GT  ? ($cmp >  0 ? 1 : 0)
395                                     :                 ($cmp >= 0 ? 1 : 0);
396                        }
397
22
32
                };
398        }
399
400
166
1296
        $$depth_ref--;
401
166
115
        return $left;
402}
403
404# add_expr ::= term ( ('+' | '-') term )*
405sub _parse_add {
406
208
208
114
        my ($tokens, $pos_ref, $depth_ref, $cols) = @_;
407
208
156
        _check_depth($depth_ref);
408
208
324
        $$depth_ref++;
409
410
208
138
        my $left = _parse_term($tokens, $pos_ref, $depth_ref, $cols);
411
412
188
100
149
        while ($tokens->[$$pos_ref]{type} eq $T_PLUS
413            || $tokens->[$$pos_ref]{type} eq $T_MINUS) {
414
11
29
                my $op = $tokens->[$$pos_ref]{type};
415
11
6
                $$pos_ref++;
416
11
9
                my $right = _parse_term($tokens, $pos_ref, $depth_ref, $cols);
417
11
21
                my ($l, $r) = ($left, $right);
418
11
100
8
                if ($op eq $T_PLUS) {
419                        $left = sub {
420
7
7
0
4
5
                                my $lv = $l->($_[0]); my $rv = $r->($_[0]);
421
7
50
33
8
                                return undef unless defined $lv && defined $rv;
422
7
100
67
13
                                return undef unless looks_like_number($lv) && looks_like_number($rv);
423
6
5
                                $lv + $rv;
424
8
31
                        };
425                } else {
426                        $left = sub {
427
7
7
6
6
6
                                my $lv = $l->($_[0]); my $rv = $r->($_[0]);
428
7
50
33
12
                                return undef unless defined $lv && defined $rv;
429
7
50
33
14
                                return undef unless looks_like_number($lv) && looks_like_number($rv);
430
7
8
                                $lv - $rv;
431
3
12
                        };
432                }
433        }
434
435
188
572
        $$depth_ref--;
436
188
113
        return $left;
437}
438
439# term ::= factor ( ('*' | '/') factor )*
440sub _parse_term {
441
219
219
139
        my ($tokens, $pos_ref, $depth_ref, $cols) = @_;
442
443
219
133
        my $left = _parse_factor($tokens, $pos_ref, $depth_ref, $cols);
444
445
199
100
198
        while ($tokens->[$$pos_ref]{type} eq $T_STAR
446            || $tokens->[$$pos_ref]{type} eq $T_SLASH) {
447
10
26
                my $op = $tokens->[$$pos_ref]{type};
448
10
6
                $$pos_ref++;
449
10
7
                my $right = _parse_factor($tokens, $pos_ref, $depth_ref, $cols);
450
10
7
                my ($l, $r) = ($left, $right);
451
10
100
7
                if ($op eq $T_STAR) {
452                        $left = sub {
453
5
5
4
3
                                my $lv = $l->($_[0]); my $rv = $r->($_[0]);
454
5
50
33
7
                                return undef unless defined $lv && defined $rv;
455
5
50
33
7
                                return undef unless looks_like_number($lv) && looks_like_number($rv);
456
5
15
                                $lv * $rv;
457
5
13
                        };
458                } else {
459                        $left = sub {
460
3
3
9
3
                                my $lv = $l->($_[0]); my $rv = $r->($_[0]);
461
3
50
33
4
                                return undef unless defined $lv && defined $rv;
462
3
50
33
7
                                return undef unless looks_like_number($lv) && looks_like_number($rv);
463
3
100
2
                                return undef if $rv == 0;
464
2
4
                                $lv / $rv;
465
5
16
                        };
466                }
467        }
468
469
199
674
        return $left;
470}
471
472# factor ::= unary | '(' cmp_expr ')' | number | string | column | call
473sub _parse_factor {
474
234
234
136
        my ($tokens, $pos_ref, $depth_ref, $cols) = @_;
475
234
130
        my $tok = $tokens->[$$pos_ref];
476
477        # unary minus
478
234
100
165
        if ($tok->{type} eq $T_MINUS) {
479
4
7
                $$pos_ref++;
480
4
4
                my $inner = _parse_factor($tokens, $pos_ref, $depth_ref, $cols);
481                return sub {
482
4
4
                        my $v = $inner->($_[0]);
483
4
50
33
8
                        return undef unless defined $v && looks_like_number($v);
484
4
4
                        -$v;
485
4
5
                };
486        }
487
488        # unary plus (no-op)
489
230
100
429
        if ($tok->{type} eq $T_PLUS) {
490
1
2
                $$pos_ref++;
491
1
2
                return _parse_factor($tokens, $pos_ref, $depth_ref, $cols);
492        }
493
494        # parenthesized sub-expression: allow full cmp_expr so (qty > 0) works
495
229
100
408
        if ($tok->{type} eq $T_LPAREN) {
496
13
20
                $$pos_ref++;
497
13
23
                my $inner = _parse_cmp($tokens, $pos_ref, $depth_ref, $cols);
498
3
3
                _expect($tokens, $pos_ref, $T_RPAREN);
499
3
2
                return $inner;
500        }
501
502        # number literal
503
216
100
376
        if ($tok->{type} eq $T_NUM) {
504
91
169
                my $val = $tok->{val} + 0;
505
91
49
                $$pos_ref++;
506
91
85
103
81
                return sub { $val };
507        }
508
509        # string literal
510
125
100
219
        if ($tok->{type} eq $T_STR) {
511
5
10
                my $val = $tok->{val};
512
5
2
                $$pos_ref++;
513
5
7
7
37
                return sub { $val };
514        }
515
516        # identifier -- function call or column reference
517
120
50
217
        if ($tok->{type} eq $T_IDENT) {
518
120
202
                my $name = $tok->{val};
519
120
69
                $$pos_ref++;
520                return $tokens->[$$pos_ref]{type} eq $T_LPAREN
521                        ? _parse_call($tokens, $pos_ref, $depth_ref, $cols, $name, $tok->{pos})
522
120
100
98
                        : _parse_colref($cols, $name, $tok->{pos});
523        }
524
525
0
0
        croak _fmt('error_unexpected_tok', $tok->{val}, $tok->{pos});
526}
527
528# Parse a function call.  'if' is a special form (short-circuit branches).
529# Arguments may be full cmp_expr (e.g. IF(qty > 0, amount/qty, 0)).
530sub _parse_call {
531
51
51
126
        my ($tokens, $pos_ref, $depth_ref, $cols, $name, $name_pos) = @_;
532
51
35
        my $lc = lc($name);
533
534        croak _fmt('error_unknown_fn', $name)
535
51
100
100
66
                unless exists $FUNCTIONS{$lc} || $lc eq 'if';
536
537
47
33
        $$pos_ref++;    # consume '('
538
47
21
        my @arg_fns;
539
47
100
38
        if ($tokens->[$$pos_ref]{type} ne $T_RPAREN) {
540
46
97
                push @arg_fns, _parse_cmp($tokens, $pos_ref, $depth_ref, $cols);
541
46
41
                while ($tokens->[$$pos_ref]{type} eq $T_COMMA) {
542
35
69
                        $$pos_ref++;
543
35
25
                        push @arg_fns, _parse_cmp($tokens, $pos_ref, $depth_ref, $cols);
544                }
545        }
546
47
110
        _expect($tokens, $pos_ref, $T_RPAREN);
547
548        # 'if' special form: short-circuit true/false branches
549
47
100
39
        if ($lc eq 'if') {
550
8
8
                my ($cond_fn, $true_fn, $false_fn) = @arg_fns;
551                return sub {
552
11
100
15
6
                        $cond_fn->($_[0]) ? $true_fn->($_[0]) : $false_fn->($_[0]);
553
8
14
                };
554        }
555
556
39
22
        my $fn = $FUNCTIONS{$lc};
557        return sub {
558
45
49
25
                my $row = $_[0];
559
45
63
37
39
                $fn->(map { $_->($row) } @arg_fns);
560
39
66
        };
561}
562
563# Parse a column reference; validates against the whitelist at compile time.
564# Underscores in the expression may match spaces in the actual column name,
565# and the comparison is case-insensitive, so  per_unit_price  can address
566# a column named "Per Unit Price".
567sub _parse_colref {
568
69
69
155
        my ($cols, $name, $name_pos) = @_;
569
570        # 1. Exact match
571
69
76
100
76
126
65
        return sub { $_[0]->{$name} } if $cols->{$name};
572
573        # 2. Underscore-to-space alias, case-insensitive
574
8
14
        (my $spaced = $name) =~ s/_/ /g;
575
8
10
        my $lc_spaced = lc($spaced);
576
8
8
6
10
        for my $col (keys %{$cols}) {
577
11
100
11
                if (lc($col) eq $lc_spaced) {
578
2
2
                        my $lookup = $col;
579
2
2
2
4
3
                        return sub { $_[0]->{$lookup} };
580                }
581        }
582
583
6
12
        croak _fmt('error_unknown_col', $name);
584}
585
586# ---------------------------------------------------------------------------
587# Standalone date-normalisation helper (used by Dashboard::_apply_date_normalization)
588# ---------------------------------------------------------------------------
589
590Readonly my %_MONTH_NAME_TO_NUM => (
591        jan => 1, feb => 2, mar => 3, apr => 4,  may => 5,  jun => 6,
592        jul => 7, aug => 8, sep => 9, oct => 10, nov => 11, dec => 12,
593);
594
595# date_normalise($value, $pattern) -> 'YYYY-MM-DD' or undef
596#
597# Converts $value from the given strptime-style $pattern to ISO-8601.
598# Returns undef when $value does not match the pattern or the pattern is
599# unknown.  No external modules required.
600#
601# Supported patterns:
602#   %m/%d/%Y  -- US slash-date (01/15/2026)
603#   %d/%m/%Y  -- EU slash-date (15/01/2026)
604#   %d-%b-%Y  -- DD-Mon-YYYY  (15-Jan-2026, case-insensitive month abbrev)
605sub date_normalise {
606
3
3
3
        my ($val, $pattern) = @_;
607
3
50
25
8
        return undef unless defined $val && defined $pattern && length $val;
608
3
50
0
0
3
        if ($pattern eq '%m/%d/%Y') {
609
3
50
7
                return undef unless $val =~ /\A(\d{1,2})\/(\d{1,2})\/(\d{4})\z/;
610
3
9
                return sprintf('%04d-%02d-%02d', $3, $1, $2);
611        } elsif ($pattern eq '%d/%m/%Y') {
612
0
0
                return undef unless $val =~ /\A(\d{1,2})\/(\d{1,2})\/(\d{4})\z/;
613
0
                return sprintf('%04d-%02d-%02d', $3, $2, $1);
614        } elsif ($pattern eq '%d-%b-%Y') {
615
0
0
                return undef unless $val =~ /\A(\d{1,2})-([A-Za-z]{3})-(\d{4})\z/;
616
0
                my $mon = $_MONTH_NAME_TO_NUM{lc($2)};
617
0
0
                return undef unless defined $mon;
618
0
                return sprintf('%04d-%02d-%02d', $3, $mon, $1);
619        }
620
0
        return undef;
621}
622
6231;
624