File Coverage

blib/lib/Algorithm/ToNumberMunger.pm
Criterion Covered Total %
statement 735 833 88.2
branch 516 696 74.1
condition 211 317 66.5
subroutine 102 111 91.8
pod 5 5 100.0
total 1569 1962 79.9


line stmt bran cond sub pod time code
1             package Algorithm::ToNumberMunger;
2              
3 5     5   496073 use 5.006;
  5         24  
4 5     5   29 use strict;
  5         20  
  5         138  
5 5     5   24 use warnings;
  5         20  
  5         316  
6              
7 5     5   22 use Carp qw(carp croak);
  5         11  
  5         270  
8 5     5   35 use Scalar::Util qw(looks_like_number);
  5         5  
  5         89026  
9              
10             =head1 NAME
11              
12             Algorithm::ToNumberMunger - Compile declarative specs into closures that munge raw values into numbers.
13              
14             =head1 VERSION
15              
16             Version 0.0.1
17              
18             =cut
19              
20             our $VERSION = '0.0.1';
21              
22             # Feature hashing (the 'hash' munger) is a tight per-byte FNV-1a loop with a
23             # 32-bit modular multiply. That is exactly the kind of work XS is good at and
24             # pure Perl is bad at (both for speed and, on a 32-bit perl, for correctness of
25             # the wrap-around), so we compile it in C when we can. Everything else here is a
26             # hash lookup or a couple of flops -- crossing the XS boundary per row would
27             # only make those slower, so they stay pure Perl. If the XS did not build (no
28             # compiler at install time) we fall back to a pure-Perl FNV-1a, which is exact
29             # on a 64-bit perl.
30             our $HAVE_XS = 0;
31             eval {
32             require XSLoader;
33             XSLoader::load( __PACKAGE__, $VERSION );
34             $HAVE_XS = 1;
35             1;
36             };
37              
38             =head1 SYNOPSIS
39              
40             use Algorithm::ToNumberMunger;
41              
42             # one munger from a spec hash
43             my $code = Algorithm::ToNumberMunger->build(
44             { munger => 'enum', map => { GET => 0, POST => 1, PUT => 2 } },
45             );
46             my $n = $code->('POST'); # 1
47              
48             # a whole table of them at once, from a 'field => spec' hash
49             my $by_tag = Algorithm::ToNumberMunger->build_all(
50             \%mungers,
51             );
52             my $row_value = $by_tag->{method}->($raw{method});
53              
54             =head1 DESCRIPTION
55              
56             Many numeric pipelines -- anomaly detectors, feature stores, CSV loaders --
57             want every column to be a number, but the values they are handed are not always
58             numbers to begin with: an HTTP method is a string, a timestamp is a formatted
59             date, a high-cardinality label wants bucketing. An B turns such a
60             raw value into a single number. Munging happens on the input side, before a row
61             is stored.
62              
63             Mungers are declared as a plain data spec -- a hash naming a built-in munger and
64             carrying that munger's parameters -- so a table of them can be read straight out
65             of JSON or a config file:
66              
67             {
68             "method": { "munger": "enum", "map": { "GET": 0, "POST": 1 } },
69             "bytes": { "munger": "log", "offset": 1 },
70             "label": { "munger": "hash", "buckets": 1024 }
71             }
72              
73             B and is passed through unchanged; this module
74             is only concerned with fields that name a munger.
75              
76             This class does not read or write files. It B a spec into a closure
77             that maps one raw value to one number, so a caller can build its mungers once
78             from configuration and then apply them per row with no re-parsing. All
79             configuration errors are caught at build time; the returned closure only croaks
80             on genuinely un-mungeable I.
81              
82             =head1 CLASS METHODS
83              
84             =head2 build
85              
86             my $code = ...->build( \%spec );
87             my $code = ...->build( \%spec, $tag_name ); # $tag_name only sharpens errors
88              
89             Compile a single munger spec into a coderef. C<%spec> must contain a C
90             key naming one of the L; the remaining keys are that munger's
91             parameters. Croaks on an unknown munger name or an invalid parameter set. The
92             optional second argument is only used to make error messages point at a tag.
93              
94             =cut
95              
96             # name => builder. Each builder validates its slice of the spec up front and
97             # returns the per-value closure. Keeping them in a table (rather than a big
98             # if/elsif) is what makes known_mungers() and has_munger() cheap and honest.
99             my %BUILDERS = (
100             enum => \&_build_enum,
101             frozen_freq_map => \&_build_frozen_freq_map,
102             bool => \&_build_bool,
103             length => \&_build_length,
104             entropy => \&_build_entropy,
105             ngram => \&_build_ngram,
106             char => \&_build_char,
107             run => \&_build_run,
108             count => \&_build_count,
109             match => \&_build_match,
110             bucket => \&_build_bucket,
111             quantile => \&_build_quantile,
112             scale => \&_build_scale,
113             zscore => \&_build_zscore,
114             log => \&_build_log,
115             clamp => \&_build_clamp,
116             num => \&_build_num,
117             bit => \&_build_bit,
118             ip_class => \&_build_ip_class,
119             cidr => \&_build_cidr,
120             datetime => \&_build_datetime,
121             hash => \&_build_hash,
122             chain => \&_build_chain,
123             eps => \&_build_eps,
124             mgcp_enum => \&_build_mgcp_enum,
125             );
126              
127             # Status-class mungers (http_enum, smtp_enum, sip_enum, ...) are one transform
128             # -- collapse a numeric reply code to its leading digit, int(code/div), with a
129             # divisor of 100 (10 for gemini's two-digit codes) -- differing only in which
130             # range 'strict' accepts. Register them all from this table so a new protocol
131             # is a single line and they can never drift apart. mgcp_enum is deliberately
132             # NOT a row here: its strict range has a hole (8xx exists, 6xx/7xx do not),
133             # which a single [lo, hi] cannot express, so it has its own builder below.
134             my %STATUS_PROTO = (
135             http => [ 100, 599 ], # 1xx-5xx
136             smtp => [ 200, 599 ], # 2xx-5xx; SMTP never issues 1yz in practice
137             sip => [ 100, 699 ], # 1xx-6xx; SIP adds a 6xx global-failure class
138             ftp => [ 100, 599 ], # 1xx-5xx FTP reply codes
139             rtsp => [ 100, 599 ], # RTSP (RFC 2326) reuses HTTP's status scheme
140             nntp => [ 100, 599 ], # 1xx-5xx NNTP (RFC 3977), SMTP-convention codes
141             dict => [ 100, 599 ], # DICT (RFC 2229) uses SMTP-style codes
142             gemini => [ 10, 69, 10 ], # two-digit codes, 1x-6x; class = int(code/10)
143             );
144             for my $proto ( keys %STATUS_PROTO ) {
145             my ( $lo, $hi, $div ) = @{ $STATUS_PROTO{$proto} };
146             $div = 100 unless defined $div;
147             $BUILDERS{"${proto}_enum"}
148             = sub { _status_class_munger( $proto, $lo, $hi, $div, @_ ) };
149             }
150              
151             # ratio and combine consume several source fields at once, so they are only
152             # buildable through compile()'s multi-input form ('from' as an arrayref) -- a
153             # scalar build can never hand them more than one value. Registering a stub
154             # keeps known_mungers() honest and turns "used it as a scalar munger" into a
155             # pointed error instead of an unknown-munger one.
156             for my $name (qw(ratio combine)) {
157             $BUILDERS{$name} = sub {
158             my ( $spec, $where ) = @_;
159             croak "$name munger$where combines several inputs; it is only usable "
160             . "via compile() with 'from' as an arrayref of source fields";
161             };
162             }
163              
164             sub build {
165 273     273 1 236322 my ( $class, $spec, $tag ) = @_;
166 273 100       797 my $where = defined $tag ? " for tag '$tag'" : '';
167              
168 273 50       884 croak "munger spec$where must be a hashref"
169             unless ref $spec eq 'HASH';
170              
171 273         514 my $name = $spec->{munger};
172 273 50 33     1251 croak "munger spec$where has no 'munger' name"
173             unless defined $name && length $name;
174              
175 273 100       907 my $builder = $BUILDERS{$name}
176             or croak "unknown munger '$name'$where (known: " . join( ', ', $class->known_mungers ) . ')';
177              
178 272         717 return $builder->( $spec, $where );
179             } ## end sub build
180              
181             =head2 build_all
182              
183             my $by_tag = ...->build_all( $info->{mungers} );
184              
185             Compile a whole C hash (tag name => spec) into a hash of tag name =>
186             coderef. A false/absent argument yields an empty hashref (every tag is raw).
187             Croaks if any spec is invalid, naming the offending tag.
188              
189             =cut
190              
191             sub build_all {
192 2     2 1 643 my ( $class, $mungers ) = @_;
193 2 100       12 return {} unless $mungers;
194              
195 1 50       5 croak "'mungers' must be a hashref"
196             unless ref $mungers eq 'HASH';
197              
198 1         2 my %by_tag;
199 1         22 for my $tag ( keys %$mungers ) {
200 2         11 $by_tag{$tag} = $class->build( $mungers->{$tag}, $tag );
201             }
202 1         5 return \%by_tag;
203             } ## end sub build_all
204              
205             =head2 compile
206              
207             my $plan = ...->compile( tags => \@tags, mungers => $info->{mungers} );
208             my $row = $plan->apply_named( \%named_input ); # numbers, in tags order
209              
210             Compile a set's C and (optional) C into a B object that maps
211             one input record to a fully-numeric row in tag order. Unlike L (which
212             just compiles each spec in isolation), C understands the whole set:
213              
214             =over 4
215              
216             =item * a scalar munger, keyed by its output tag, fills that one column; its
217             input is read from the tag's own name, or from C<< from => 'other' >> to alias a
218             source field;
219              
220             =item * an B munger, keyed by any label and carrying C<< into =>
221             [tag, ...] >>, reads one source (C, defaulting to the label) and fills
222             several columns at once -- this is how a single timestamp becomes both a
223             C/C pair without the two ever drifting apart (see L);
224              
225             =item * a B munger, keyed by its output tag and carrying a C
226             B (C<< from => ['bytes_out', 'bytes_in'] >>), reads several source
227             fields and fills that one column -- this is how a ratio becomes a single
228             feature without precomputing it upstream (see L and L). The
229             sources are raw input fields, not other (possibly munged) columns;
230              
231             =item * every remaining tag is B and passed through unchanged.
232              
233             =back
234              
235             Coverage is validated up front: C croaks if two mungers write the same
236             column, if an C names a column not in C, if a munger key is neither a
237             tag nor an expander, if an expander's output count does not match its C,
238             or if a C list is given to a munger that cannot combine inputs. The
239             returned plan has two methods, both returning an arrayref of numbers in C
240             order: C (keyed by field name, the only form that supports
241             expanders and combiners) and C (positional; croaks if
242             the set has any expanding or combining munger, since a shared or combined
243             source cannot be expressed by position).
244              
245             =cut
246              
247             # name => builder returning ($list_returning_code, $arity), for the mungers that
248             # can fan one input out into several columns via 'into'.
249             my %MULTI_BUILDERS = (
250             datetime => \&_build_datetime_multi,
251             eps => \&_build_eps_multi,
252             chain => \&_build_chain_multi,
253             );
254              
255             sub _build_multi {
256 9     9   24 my ( $class, $spec, $where ) = @_;
257 9         19 my $name = $spec->{munger};
258 9 50 33     51 croak "munger spec$where has no 'munger' name"
259             unless defined $name && length $name;
260 9 100       207 my $builder = $MULTI_BUILDERS{$name}
261             or croak "munger '$name'$where does not support multiple outputs "
262             . "('into'); only these do: "
263             . join( ', ', sort keys %MULTI_BUILDERS );
264 8         28 return $builder->( $spec, $where );
265             } ## end sub _build_multi
266              
267             # name => builder returning the N-input closure, for the mungers that combine
268             # several source fields ('from' as an arrayref) into one column. The builder is
269             # handed the source count so arity errors surface at compile time.
270             my %COMBINE_BUILDERS = (
271             ratio => \&_build_ratio,
272             combine => \&_build_combine_op,
273             );
274              
275             sub _build_combine {
276 14     14   32 my ( $class, $spec, $where, $nsrc ) = @_;
277 14         23 my $name = $spec->{munger};
278 14 50 33     51 croak "munger spec$where has no 'munger' name"
279             unless defined $name && length $name;
280 14 100       245 my $builder = $COMBINE_BUILDERS{$name}
281             or croak "munger '$name'$where does not support multiple inputs "
282             . "(a 'from' list); only these do: "
283             . join( ', ', sort keys %COMBINE_BUILDERS );
284 13         32 return $builder->( $spec, $where, $nsrc );
285             } ## end sub _build_combine
286              
287             sub compile {
288 24     24 1 146040 my ( $class, %args ) = @_;
289              
290 24         56 my $tags = $args{tags};
291 24 50 33     156 croak "compile requires a non-empty 'tags' arrayref"
292             unless ref $tags eq 'ARRAY' && @$tags;
293 24   100     69 my $mungers = $args{mungers} || {};
294 24 50       64 croak "compile: 'mungers' must be a hashref"
295             unless ref $mungers eq 'HASH';
296              
297 24         40 my %pos;
298 24         81 for my $i ( 0 .. $#$tags ) {
299             croak "compile: duplicate tag '$tags->[$i]'"
300 39 50       95 if exists $pos{ $tags->[$i] };
301 39         105 $pos{ $tags->[$i] } = $i;
302             }
303              
304 24         45 my ( @scalar, @expand, @combine, %claimed );
305             my $claim = sub {
306 23     23   41 my ( $tag, $by ) = @_;
307             croak "munger '$by' targets unknown column '$tag'"
308 23 100       214 unless exists $pos{$tag};
309             croak "two mungers write column '$tag'"
310 22 100       249 if $claimed{$tag}++;
311 24         131 };
312              
313 24         103 for my $key ( sort keys %$mungers ) {
314 31         67 my $spec = $mungers->{$key};
315 31 50       84 croak "munger '$key' spec must be a hashref"
316             unless ref $spec eq 'HASH';
317 31 100       82 my $from = defined $spec->{from} ? $spec->{from} : $key;
318              
319 31 100       88 if ( ref $from eq 'ARRAY' ) {
    100          
320 17 100       194 croak "munger '$key': a 'from' list needs at least 2 source fields"
321             unless @$from >= 2;
322             croak "munger '$key': 'into' cannot be combined with a 'from' list"
323 16 100       189 if defined $spec->{into};
324             croak "munger '$key' is not a declared tag and has no 'into'"
325 15 100       219 unless exists $pos{$key};
326 14         49 my $code = $class->_build_combine( $spec, " for '$key'", scalar @$from );
327 9         21 $claim->( $key, $key );
328 9         35 push @combine, { tag => $key, from => [@$from], code => $code };
329             } elsif ( defined $spec->{into} ) {
330 9         18 my $into = $spec->{into};
331 9 50 33     46 croak "munger '$key': 'into' must be a non-empty arrayref"
332             unless ref $into eq 'ARRAY' && @$into;
333 9         41 my ( $code, $arity ) = $class->_build_multi( $spec, " for '$key'" );
334 7 100       165 croak "munger '$key' produces $arity value(s) but 'into' lists " . scalar(@$into)
335             unless $arity == @$into;
336 6         17 $claim->( $_, $key ) for @$into;
337 5         25 push @expand, { from => $from, into => [@$into], code => $code };
338             } else {
339             croak "munger '$key' is not a declared tag and has no 'into'"
340 5 100       164 unless exists $pos{$key};
341 4         11 $claim->( $key, $key );
342 3         9 push @scalar, { tag => $key, from => $from, code => $class->build( $spec, $key ) };
343             }
344             } ## end for my $key ( sort keys %$mungers )
345              
346 10         17 for my $tag (@$tags) {
347             push @scalar, { tag => $tag, from => $tag, code => undef }
348 24 100       84 unless $claimed{$tag};
349             }
350              
351 10         122 return bless {
352             tags => [@$tags],
353             pos => \%pos,
354             scalar => \@scalar,
355             expand => \@expand,
356             combine => \@combine,
357             },
358             "${class}::Plan";
359             } ## end sub compile
360              
361             =head2 known_mungers
362              
363             my @names = ...->known_mungers;
364              
365             The sorted list of built-in munger names this version understands.
366              
367             =head2 has_munger
368              
369             if ( ...->has_munger('enum') ) { ... }
370              
371             True if the named munger is built in.
372              
373             =cut
374              
375 2     2 1 78 sub known_mungers { my @names = sort keys %BUILDERS; return @names }
  2         280  
376 4     4 1 136212 sub has_munger { return exists $BUILDERS{ $_[1] } }
377              
378             =head1 BUILT-IN MUNGERS
379              
380             Every munger returns a plain number and, where the input cannot be interpreted,
381             croaks -- the Writer would reject a non-numeric field anyway, so failing at the
382             munger gives a better message. Parameters are validated when the munger is
383             built, not per row.
384              
385             =head2 enum
386              
387             { munger => 'enum', map => { GET => 0, POST => 1 }, default => -1 }
388              
389             Categorical string to number via an explicit C. All map values must be
390             numeric. Without a C, an unmapped input croaks; with one, unmapped
391             inputs (including C) yield the default.
392              
393             =cut
394              
395             sub _build_enum {
396 4     4   9 my ( $spec, $where ) = @_;
397              
398 4         30 my $map = $spec->{map};
399 4 50       14 croak "enum munger$where requires a 'map' hashref"
400             unless ref $map eq 'HASH';
401              
402 4         15 for my $k ( keys %$map ) {
403             croak "enum munger$where: map value for '$k' ('"
404             . ( defined $map->{$k} ? $map->{$k} : 'undef' )
405             . "') is not numeric"
406 7 0       30 unless looks_like_number( $map->{$k} );
    50          
407             }
408              
409 4         10 my $has_default = exists $spec->{default};
410 4         9 my $default = $spec->{default};
411 4 50 66     17 croak "enum munger$where: 'default' must be numeric"
412             if $has_default && !looks_like_number($default);
413              
414             # Copy so a later edit of the caller's spec cannot mutate a live munger.
415 4         15 my %m = %$map;
416             return sub {
417 7     7   31 my ($v) = @_;
418 7 100 100     44 return $m{$v} if defined $v && exists $m{$v};
419 3 100       10 return $default if $has_default;
420 1 50       147 croak "enum munger$where: no mapping for '" . ( defined $v ? $v : 'undef' ) . "'";
421 4         25 };
422             } ## end sub _build_enum
423              
424             =head2 frozen_freq_map
425              
426             { munger => 'frozen_freq_map', counts => { jpg => 40213, exe => 12, scr => 3 },
427             total => 67560 }
428             # defaults: mode => 'neg_log_prob', smoothing => 1, unseen => 'rare'
429              
430             Frequency-encoding from a B count table: the rarer a value
431             was when the table was built, the more anomalous it scores. This is C's
432             cousin -- a value-to-number map -- except the numbers are derived from observed
433             C rather than hand-authored, with the smoothing and unseen-value policy
434             that "rare = interesting" needs. It stays a stateless munger: the table is
435             computed offline and shipped in C; this class only I it.
436              
437             C maps each value to how many times it was seen. C is the overall
438             observation count; it defaults to the sum of C, but may be given
439             explicitly and larger so you can B out of C while
440             still computing correct probabilities. The emitted number depends on C:
441              
442             =over 4
443              
444             =item * C (default) - self-information C<-ln(prob)>: rare values
445             score high, common ones low. This is the axis "rare = interesting" describes and
446             what an Isolation Forest splits on most naturally.
447              
448             =item * C - the probability itself, C<(count + smoothing) / denom>.
449              
450             =item * C - C, the count with its heavy tail tamed.
451              
452             =item * C - the raw count.
453              
454             =back
455              
456             Probabilities use add-one style C (default C<1>), treating "unseen" as
457             one aggregate bucket: C
458             where C is the number of listed values. C controls what a value absent
459             from the table maps to -- C<'rare'> (default) emits that value under the current
460             mode as if it had been seen zero times (for C/C this is the
461             smoothed unseen bucket, for C/C it is C<0>), or a number to
462             force a fixed default. Because an unseen value is usually the very thing you are
463             hunting, mapping it to "maximally rare" rather than erroring is the point.
464              
465             C only suits B columns (extensions,
466             vendor classes, named pipes, keyboard layouts, link addresses): the table lives
467             in C, so a huge one bloats every read -- building one past
468             C<$Algorithm::ToNumberMunger::FROZEN_FREQ_MAP_WARN_KEYS>
469             values (default 10000) warns. For unbounded cardinality (JA3, full user-agents)
470             use L instead, which needs no table but keeps only decorrelation, not
471             commonness.
472              
473             =cut
474              
475             # name => 1 for the recognized frozen_freq_map output modes.
476             my %FREQ_MODE = map { $_ => 1 } qw(neg_log_prob freq log_count count);
477              
478             # Building a table larger than this warns: info.json ships the whole map, so a
479             # high-cardinality column belongs in the 'hash' munger instead.
480             our $FROZEN_FREQ_MAP_WARN_KEYS = 10_000;
481              
482             sub _build_frozen_freq_map {
483 10     10   14 my ( $spec, $where ) = @_;
484              
485 10         16 my $counts = $spec->{counts};
486 10 100 66     157 croak "frozen_freq_map munger$where requires a non-empty 'counts' hashref"
487             unless ref $counts eq 'HASH' && %$counts;
488              
489 9         13 my $sum = 0;
490 9         24 for my $k ( keys %$counts ) {
491 13         17 my $c = $counts->{$k};
492 13 0 33     47 croak "frozen_freq_map munger$where: count for '$k' ('"
    50          
493             . ( defined $c ? $c : 'undef' )
494             . "') is not a non-negative number"
495             unless looks_like_number($c) && $c >= 0;
496 13         29 $sum += $c;
497             }
498              
499 9         15 my $V = keys %$counts;
500 9 100       144 carp "frozen_freq_map munger$where: 'counts' has $V keys; a table this large bloats "
501             . "info.json -- consider the 'hash' munger for unbounded cardinality"
502             if $V > $FROZEN_FREQ_MAP_WARN_KEYS;
503              
504 9 100       25 my $total = defined $spec->{total} ? $spec->{total} : $sum;
505 9 50       20 croak "frozen_freq_map munger$where: 'total' must be numeric"
506             unless looks_like_number($total);
507 9 100       125 croak "frozen_freq_map munger$where: 'total' ($total) must be >= sum of counts ($sum)"
508             if $total < $sum;
509              
510 8 100       31 my $mode = defined $spec->{mode} ? $spec->{mode} : 'neg_log_prob';
511             croak "frozen_freq_map munger$where: unknown mode '$mode' (known: " . join( ', ', sort keys %FREQ_MODE ) . ')'
512 8 100       141 unless $FREQ_MODE{$mode};
513              
514 7 100       13 my $s = defined $spec->{smoothing} ? $spec->{smoothing} : 1;
515 7 50 33     34 croak "frozen_freq_map munger$where: 'smoothing' must be a non-negative number"
516             unless looks_like_number($s) && $s >= 0;
517              
518 7 100       923 my $unseen = defined $spec->{unseen} ? $spec->{unseen} : 'rare';
519 7 50 66     22 croak "frozen_freq_map munger$where: 'unseen' must be 'rare' or a number"
520             unless $unseen eq 'rare' || looks_like_number($unseen);
521              
522             # An unseen value under neg_log_prob has probability s/denom; with no
523             # smoothing that is 0 and -ln(0) is infinite, which would poison the column.
524             # Refuse to build rather than emit inf.
525 7 100 66     137 croak "frozen_freq_map munger$where: mode 'neg_log_prob' with unseen => 'rare' needs "
      100        
526             . "smoothing > 0 (an unseen value would otherwise be infinitely surprising)"
527             if $mode eq 'neg_log_prob' && $unseen eq 'rare' && $s == 0;
528              
529             # Smoothed-probability denominator, treating "unseen" as one extra bucket.
530 6         10 my $denom = $total + $s * ( $V + 1 );
531              
532             # raw count -> emitted number under the chosen mode.
533             my $emit_for = sub {
534 15     15   21 my ($c) = @_;
535 15 100       35 return $c if $mode eq 'count';
536 8 50       12 return log( 1 + $c ) if $mode eq 'log_count';
537 8         12 my $p = ( $c + $s ) / $denom;
538 8 100       17 return $p if $mode eq 'freq';
539 5         18 return -log($p); # neg_log_prob
540 6         32 };
541              
542 6         20 my %emit = map { $_ => $emit_for->( $counts->{$_} ) } keys %$counts;
  10         18  
543 6 100       16 my $unseen_value = $unseen eq 'rare' ? $emit_for->(0) : $unseen;
544              
545             return sub {
546 13     13   61 my ($v) = @_;
547 13 100 66     74 return defined $v && exists $emit{$v} ? $emit{$v} : $unseen_value;
548 6         76 };
549             } ## end sub _build_frozen_freq_map
550              
551             =head2 http_enum
552              
553             { munger => 'http_enum' }
554             { munger => 'http_enum', strict => 1 }
555              
556             Collapse an HTTP status code to its class: C<1xx> to C<1>, C<2xx> to C<2>, C<3xx>
557             to C<3>, and so on (i.e. C). This is the usual bucketing for an
558             HTTP status column -- the forest cares far more about "was this a 4xx vs a 2xx"
559             than about C<403> vs C<404>, and it keeps the feature low-cardinality without
560             having to spell out every code in an C C. The input must be numeric.
561              
562             By default any numeric input is bucketed, so a bogus C<700> would quietly become
563             C<7>. With a true C, inputs outside the valid HTTP status range
564             (C<100>-C<599>) croak instead, so a malformed code is caught at write time rather
565             than smuggled into the model as a spurious class.
566              
567             =head2 smtp_enum
568              
569             { munger => 'smtp_enum' }
570             { munger => 'smtp_enum', strict => 1 }
571              
572             The SMTP counterpart of L: collapse an SMTP reply code to its leading
573             digit (C), since that digit I the reply's meaning -- C<2yz>
574             completion, C<3yz> intermediate, C<4yz> transient failure, C<5yz> permanent
575             failure. As with C this keeps the column low-cardinality and lets the
576             forest weigh "a 5xx where a 2xx was expected" without enumerating every code.
577              
578             With a true C, inputs outside the valid SMTP reply range (C<200>-C<599>)
579             croak. SMTP never issues C<1yz> replies in practice (no command permits a
580             positive-preliminary reply), so the strict floor is C<200> rather than
581             C's C<100>.
582              
583             =head2 sip_enum
584              
585             { munger => 'sip_enum' }
586             { munger => 'sip_enum', strict => 1 }
587              
588             The SIP counterpart of L: collapse a SIP status code to its leading
589             digit (C). SIP reuses HTTP's class scheme but adds a sixth
590             class -- C<1xx> provisional, C<2xx> success, C<3xx> redirection, C<4xx> client
591             error, C<5xx> server error, C<6xx> global failure.
592              
593             With a true C, inputs outside the valid SIP status range (C<100>-C<699>)
594             croak. The ceiling is C<699> rather than C's C<599> precisely because
595             of that C<6xx> global-failure class.
596              
597             =head2 ftp_enum
598              
599             { munger => 'ftp_enum' }
600             { munger => 'ftp_enum', strict => 1 }
601              
602             The FTP counterpart of L, for FTP reply codes: C,
603             bucketing into C<1yz>-C<5yz>. With a true C, inputs outside C<100>-C<599>
604             croak.
605              
606             =head2 rtsp_enum
607              
608             { munger => 'rtsp_enum' }
609             { munger => 'rtsp_enum', strict => 1 }
610              
611             The RTSP counterpart of L. RTSP (RFC 2326) deliberately reuses
612             HTTP's status scheme, so codes collapse to their leading digit the same way.
613             With a true C, inputs outside C<100>-C<599> croak.
614              
615             =head2 nntp_enum
616              
617             { munger => 'nntp_enum' }
618             { munger => 'nntp_enum', strict => 1 }
619              
620             The NNTP counterpart of L, for NNTP (RFC 3977) reply codes, which
621             follow the SMTP convention -- C<1xx> informational, C<2xx> success, C<3xx>
622             send-more-input, C<4xx> transient failure, C<5xx> permanent failure. Unlike
623             SMTP, NNTP does issue C<1xx> replies (help text, capability lists), so the
624             strict floor is C<100> rather than C's C<200>. With a true
625             C, inputs outside C<100>-C<599> croak.
626              
627             =head2 dict_enum
628              
629             { munger => 'dict_enum' }
630             { munger => 'dict_enum', strict => 1 }
631              
632             The DICT counterpart of L, for DICT protocol (RFC 2229) status
633             codes, which use the SMTP-style code classes. With a true C, inputs
634             outside C<100>-C<599> croak.
635              
636             =head2 gemini_enum
637              
638             { munger => 'gemini_enum' }
639             { munger => 'gemini_enum', strict => 1 }
640              
641             Like L but for the Gemini protocol, whose status codes are B
642             digits -- C<1x> input expected, C<2x> success, C<3x> redirect, C<4x> temporary
643             failure, C<5x> permanent failure, C<6x> client certificate required -- so the
644             class is C. With a true C, inputs outside C<10>-C<69>
645             croak.
646              
647             =cut
648              
649             # Shared closure for the status-class mungers registered from %STATUS_PROTO.
650             sub _status_class_munger {
651 16     16   46 my ( $proto, $lo, $hi, $div, $spec, $where ) = @_;
652 16 100       41 my $strict = $spec->{strict} ? 1 : 0;
653             return sub {
654 62     62   2981 my ($v) = @_;
655 62 50       574 croak "${proto}_enum munger$where: '" . ( defined $v ? $v : 'undef' ) . "' is not a numeric status code"
    100          
656             unless looks_like_number($v);
657 59 100 100     2325 croak "${proto}_enum munger$where: status code '$v' is out of range " . "($lo-$hi)"
      100        
658             if $strict && ( $v < $lo || $v > $hi );
659 47         271 return int( $v / $div );
660 16         131 };
661             } ## end sub _status_class_munger
662              
663             =head2 mgcp_enum
664              
665             { munger => 'mgcp_enum' }
666             { munger => 'mgcp_enum', strict => 1 }
667              
668             The MGCP counterpart of L, for MGCP (RFC 3435) response codes:
669             C. MGCP's classes are C<1xx> provisional, C<2xx> success,
670             C<4xx> transient error, C<5xx> permanent error, and C<8xx> package-specific --
671             there are no C<6xx> or C<7xx> codes, so the valid set has a B in it.
672             With a true C, inputs outside C<100>-C<599> B outside
673             C<800>-C<899> croak. (That hole is why this is a hand-written builder rather
674             than another row of the shared status-class table, which can only express one
675             contiguous range.)
676              
677             =cut
678              
679             # MGCP's strict range is [100,599] union [800,899] -- 8xx package-specific
680             # codes are real, 6xx/7xx are not -- which %STATUS_PROTO's single [lo, hi]
681             # cannot express, hence this dedicated builder.
682             sub _build_mgcp_enum {
683 2     2   5 my ( $spec, $where ) = @_;
684 2 100       8 my $strict = $spec->{strict} ? 1 : 0;
685             return sub {
686 15     15   1942 my ($v) = @_;
687 15 50       230 croak "mgcp_enum munger$where: '" . ( defined $v ? $v : 'undef' ) . "' is not a numeric status code"
    100          
688             unless looks_like_number($v);
689 14 100 100     641 croak "mgcp_enum munger$where: status code '$v' is out of range " . "(100-599 or 800-899)"
      100        
690             if $strict && !( ( $v >= 100 && $v <= 599 ) || ( $v >= 800 && $v <= 899 ) );
691 10         64 return int( $v / 100 );
692 2         19 };
693             } ## end sub _build_mgcp_enum
694              
695             =head2 dns_rcode_enum
696              
697             { munger => 'dns_rcode_enum' }
698             { munger => 'dns_rcode_enum', default => -1 }
699              
700             The first of the B: like L, except the C is baked
701             in from a well-known registry instead of hand-authored (and inevitably
702             typo'd). All named-map enums share the same lookup rules: names are matched
703             B; where the emitted numbers are the protocol's own wire
704             encoding (as here -- rcode C<3> I C), a numeric input is passed
705             through unchanged, so mixed feeds (one tool logs C, another logs
706             C<3>) land in one consistent column; and an unmapped value croaks unless the
707             spec supplies a numeric C. As with C, an unrecognized value is
708             often exactly the anomaly worth keeping, so C<< default => -1 >> is the usual
709             escape hatch.
710              
711             This one maps DNS RCODE names to their IANA values: C 0, C
712             1, C 2, C 3, C 4 (alias C), C 5,
713             C 6, C 7, C 8, C 9, C 10,
714             C 11, and the extended rcodes C/C 16, C
715             17, C 18, C 19, C 20, C 21, C 22,
716             C 23.
717              
718             =head2 dns_qtype_enum
719              
720             { munger => 'dns_qtype_enum', default => -1 }
721              
722             Named-map enum (lookup rules as L; numeric inputs pass
723             through) mapping DNS RR type names to their IANA numbers: C 1, C 2,
724             C 5, C 6, C 10, C 12, C 15, C 16, C 28,
725             C 33, C 35, C 43, C 46, C 48, C 52,
726             C 64, C 65, C 252, C (or C<*>) 255, C 256,
727             C 257, and the rest of the commonly-observed registry. The query-type mix
728             is a classic DNS-tunneling feature -- C/C-heavy traffic where
729             C/C is normal.
730              
731             =head2 syslog_severity_enum
732              
733             { munger => 'syslog_severity_enum' }
734              
735             Named-map enum (lookup rules as L; numeric inputs pass
736             through) mapping syslog severity names to their RFC 5424 codes: C 0
737             (alias C), C 1, C 2, C 3 (alias C),
738             C 4 (alias C), C 5, C 6 (alias
739             C), C 7. Genuinely ordinal -- lower is more severe --
740             so a threshold split on it is meaningful.
741              
742             =head2 syslog_facility_enum
743              
744             { munger => 'syslog_facility_enum' }
745              
746             Named-map enum (lookup rules as L; numeric inputs pass
747             through) mapping syslog facility names to their RFC 5424 codes: C 0,
748             C 1, C 2, C 3, C 4 (alias C), C 5,
749             C 6, C 7, C 8, C 9, C 10, C 11, C
750             12, C 13, C 14, C 15, and C-C 16-23.
751              
752             =head2 ip_proto_enum
753              
754             { munger => 'ip_proto_enum', default => -1 }
755              
756             Named-map enum (lookup rules as L; numeric inputs pass
757             through) mapping IP protocol names to their IANA protocol numbers: C 1,
758             C 2, C 4 (alias C), C 6, C 8, C 17,
759             C 33, C 41, C 46, C 47, C 50, C 51,
760             C 58 (alias C), C 89, C 103, C 132,
761             C 136. The map is frozen here rather than delegated to
762             C so a value munges to the same number on every host.
763              
764             =head2 tls_version_enum
765              
766             { munger => 'tls_version_enum', default => -1 }
767              
768             Named-map enum (lookup rules as L) mapping a TLS/SSL protocol
769             version name to an B: C 0, C 1, C 2, C
770             3, C 4, C 5, with the common spelling variants (C,
771             C, ...) accepted. Ordinal so "older than expected" is a monotone
772             feature a threshold split can express. Because these ordinals are this
773             module's invention rather than a wire encoding, numeric inputs are B
774             passed through -- a C<1.2> would land on the wrong scale -- and croak like
775             any other unmapped value (or take the C).
776              
777             =head2 http_method_enum
778              
779             { munger => 'http_method_enum', default => -1 }
780              
781             Named-map enum (lookup rules as L) for the registered HTTP
782             request methods: C 0, C 1, C 2, C 3, C 4,
783             C 5, C 6, C 7, C 8. HTTP has no numeric
784             method encoding, so these are unordered ordinals of this module's invention
785             (a canonical map beats every set inventing its own numbering) and numeric
786             inputs are not passed through. An unlisted -- possibly probing -- method
787             croaks unless a C is given, and that unlisted-method signal is often
788             the interesting one.
789              
790             =head2 sip_method_enum
791              
792             { munger => 'sip_method_enum', default => -1 }
793              
794             Named-map enum (lookup rules as L) for the SIP request
795             methods: C 0, C 1, C 2, C 3, C 4,
796             C 5, C 6, C 7, C 8, C 9,
797             C 10, C 11, C 12, C 13. Like
798             L these are ordinals of this module's invention, so
799             numeric inputs are not passed through.
800              
801             =head2 dhcp_msgtype_enum
802              
803             { munger => 'dhcp_msgtype_enum' }
804              
805             Named-map enum (lookup rules as L; numeric inputs pass
806             through) mapping DHCP message-type names to their option-53 values:
807             C 1, C 2, C 3, C 4, C 5, C 6,
808             C 7, C 8 -- each also accepted with the C prefix
809             (C, ...) that most tooling logs.
810              
811             =head2 app_proto_enum
812              
813             { munger => 'app_proto_enum', default => -1 }
814              
815             Named-map enum (lookup rules as L) for Suricata's
816             C field -- the detected application-layer protocol on a flow or
817             alert (C, C, C, C, C, C, C, ...),
818             including C and C, which are usually the very rows worth
819             keeping. These are unordered ordinals of this module's invention (Suricata
820             logs a string, not a number), so numeric inputs are B passed through.
821             C is accepted as an alias for C and C for C. This is
822             distinct from L, which numbers the L4 protocol
823             (C/C/...) rather than the app layer riding on it.
824              
825             =head2 tcp_state_enum
826              
827             { munger => 'tcp_state_enum', default => -1 }
828              
829             Named-map enum (lookup rules as L) mapping the TCP state
830             machine, as Suricata logs it under C, to an B along
831             the connection lifecycle: C 0, C 1, C 2,
832             C 3, C 4, C 5, C 6, C
833             7, C 8, C 9, C 10. Ordinal so "further along
834             teardown than expected" is a monotone feature a threshold split can express.
835             Being ordinals of our own invention, numeric inputs are not passed through.
836              
837             =head2 flow_state_enum
838              
839             { munger => 'flow_state_enum', default => -1 }
840              
841             Named-map enum (lookup rules as L) for Suricata's
842             C: C 0, C 1, C 2, C 3,
843             C 4 -- roughly ordinal along the flow lifecycle. Numeric inputs
844             are not passed through.
845              
846             =head2 flow_reason_enum
847              
848             { munger => 'flow_reason_enum', default => -1 }
849              
850             Named-map enum (lookup rules as L) for Suricata's
851             C, why a flow was logged out: C 0, C 1,
852             C 2, C 3. Numeric inputs are not passed through.
853              
854             =head2 suricata_action_enum
855              
856             { munger => 'suricata_action_enum', default => -1 }
857              
858             Named-map enum (lookup rules as L) for Suricata's
859             C and the related rule/drop actions: C 0, C
860             1, C 2, C 3, C 4, C 5. In IDS mode the field is
861             C/C; the rule-action names are accepted too for IPS feeds
862             and C events. Numeric inputs are not passed through.
863              
864             =head2 postfix_status_enum
865              
866             { munger => 'postfix_status_enum', default => -1 }
867              
868             Named-map enum (lookup rules as L) for Postfix's delivery
869             C disposition, numbered in a rough sent-to-failed severity order so
870             a threshold split is meaningful: C 0, C 1, C 2,
871             C 3, C 4, C 5, C 6, C 7,
872             C 8, C 9, C 10. Stock delivery agents emit only
873             C/C/C/C; C/C come
874             from address verification (C), and the remainder cover HOLD/DISCARD
875             actions and values common log normalizers emit. Being labels of this module's
876             numbering, numeric inputs are not passed through.
877              
878             =head2 spf_result_enum
879              
880             { munger => 'spf_result_enum', default => -1 }
881              
882             Named-map enum (lookup rules as L) for an SPF check result
883             (RFC 7208), as logged by policyd-spf or carried in an C
884             header, numbered pass-to-fail: C 0, C 1, C 2, C
885             3, C 4, C 5, C 6. The older spellings C
886             (for C) and C (for C) are accepted as aliases.
887             Numeric inputs are not passed through.
888              
889             =head2 dkim_result_enum
890              
891             { munger => 'dkim_result_enum', default => -1 }
892              
893             Named-map enum (lookup rules as L) for a DKIM verification
894             result (RFC 8601), as logged by opendkim or carried in an
895             C header, numbered pass-to-fail: C 0, C
896             1, C 2, C 3, C 4, C 5, C 6. The older
897             spellings C (for C) and C (for C) are
898             accepted as aliases. Numeric inputs are not passed through.
899              
900             =head2 dmarc_result_enum
901              
902             { munger => 'dmarc_result_enum', default => -1 }
903              
904             Named-map enum (lookup rules as L) for a DMARC evaluation
905             result (RFC 7489 / RFC 8601), as logged by opendmarc or carried in an
906             C header: C 0, C 1, C 2, C
907             3, C 4, and opendmarc's C 5. This is the DMARC
908             I (did the message pass alignment), not the policy I
909             (C/C/C) -- for that, use a plain L. Numeric
910             inputs are not passed through.
911              
912             =head2 sasl_mech_enum
913              
914             { munger => 'sasl_mech_enum', default => -1 }
915              
916             Named-map enum (lookup rules as L) for the SASL
917             authentication mechanism -- as Dovecot logs C, Postfix logs
918             C, and submission/IMAP/POP3 auth report -- numbered in a rough
919             B order so the ordinal carries a little signal on its
920             own: the cleartext and C mechanisms sort low, the legacy
921             challenge-response ones (C, C, C, ...) in the
922             middle, then C/C, the OAuth/federated tokens, and finally the
923             Kerberos/GSS and certificate (C) mechanisms. About two dozen
924             mechanisms are baked in, covering the IANA registry plus the ubiquitous
925             non-registered C, C, and C. Being ordinals of this
926             module's numbering, numeric inputs are not passed through; an unlisted
927             mechanism croaks unless a numeric C is given.
928              
929             If you would rather the number carry B implied gradient, see
930             L, which numbers the same set alphabetically.
931              
932             =head2 sasl_mech_iana_enum
933              
934             { munger => 'sasl_mech_iana_enum', default => -1 }
935              
936             The nominal counterpart of L: the B set of SASL
937             mechanisms (the two share one list, so they can never cover different
938             mechanisms), but numbered B rather than by strength -- a
939             purely categorical encoding for when a strength gradient would be a
940             misleading feature. Lookup rules and the no-numeric-passthrough behaviour are
941             as L.
942              
943             =head2 http_version_enum
944              
945             { munger => 'http_version_enum', default => -1 }
946              
947             Named-map enum (lookup rules as L) mapping the HTTP protocol
948             version to an B: C 0, C 1, C 2,
949             C 3, C 4. The access-log spelling (C), the bare
950             number (C<1.1>), and the ALPN/shorthand forms (C

, C, C

) are all

951             accepted, so an Apache/nginx C<%H> field and a Suricata C land
952             in one column. Ordinal so "older than expected" (a C<0.9>/C<1.0> request from
953             a scanner) is a monotone feature a threshold split can express. Because these
954             are ordinals of our own numbering -- and a logged C<2> denotes version C<2.0>,
955             not the integer two -- numeric inputs are B passed through.
956              
957             =head2 spamassassin_autolearn_enum
958              
959             { munger => 'spamassassin_autolearn_enum', default => -1 }
960              
961             Named-map enum (lookup rules as L) for SpamAssassin's
962             C field: C 0, C 1, C 2, C 3, C 4,
963             C 5, C 6. The numbering is essentially nominal (the
964             Bayes auto-learn outcome is a category, not a scale), arranged only so the
965             "nothing was learned" states cluster away from the ham/spam ones. The spam
966             I is already a number for L, and the spam/ham verdict a L;
967             this covers the one autolearn field neither derives. Numeric inputs are not
968             passed through.
969              
970             =head2 rspamd_action_enum
971              
972             { munger => 'rspamd_action_enum', default => -1 }
973              
974             Named-map enum (lookup rules as L) for rspamd's action,
975             numbered by B so the ordinal is a usable feature on its
976             own: C 0, C 1, C 2, C 3,
977             C 4, C 5. Both the space and underscore spellings rspamd
978             emits (C/C, C/C, ...) are
979             accepted. Numeric inputs are not passed through.
980              
981             =head2 ssh_auth_method_enum
982              
983             { munger => 'ssh_auth_method_enum', default => -1 }
984              
985             Named-map enum (lookup rules as L) for the OpenSSH
986             authentication method logged by C (the word after C/C,
987             or the C field): C 0, C 1, C 2,
988             C 3, C 4, C 5, C 6, with
989             bare C aliased to C. Numbered roughly
990             B so "weaker credential than expected" is a monotone
991             feature; the ordering is a judgement call, not a registry. Numeric inputs are
992             not passed through.
993              
994             =head2 amavis_category_enum
995              
996             { munger => 'amavis_category_enum', default => -1 }
997              
998             Named-map enum (lookup rules as L) for the amavisd-new
999             content category, ordered clean-to-worst: C 0, C 1,
1000             C 2, C 3, C 4, C 5, C 6,
1001             C 7, C 8. The hyphenated spellings (C,
1002             C) and the legacy C (for C) are accepted as
1003             aliases. The Passed/Blocked I itself is a L; this is the
1004             finer-grained reason. Numeric inputs are not passed through.
1005              
1006             =head2 systemd_result_enum
1007              
1008             { munger => 'systemd_result_enum', default => -1 }
1009              
1010             Named-map enum (lookup rules as L) for a systemd unit
1011             C (as in C): C 0, C
1012             1, C 2, C 3, C 4, C 5, C 6,
1013             C 7, C 8, C 9. The underscore spellings
1014             (C, C, C, C) are accepted as
1015             aliases. Numeric inputs are not passed through.
1016              
1017             =head2 clamav_result_enum
1018              
1019             { munger => 'clamav_result_enum', default => -1 }
1020              
1021             Named-map enum (lookup rules as L) for a ClamAV per-target
1022             verdict as logged by C / clamav-milter: C 0, C 1, C
1023             2. Small but exactly the signal worth flagging (a C line). Numeric
1024             inputs are not passed through.
1025              
1026             =head2 kerberos_etype_enum
1027              
1028             { munger => 'kerberos_etype_enum', default => -1 }
1029              
1030             Named-map enum for the Kerberos ticket encryption type -- Windows events
1031             4768/4769 (logged as hex, C<0x17>) and any other AD/Kerberos source. The
1032             values are the RFC 3961 etype numbers, which B the wire encoding, so
1033             (unlike most of the enums here) a decimal input passes through unchanged: the
1034             map exists only to resolve the hex spellings (C<0x17> => 23, C<0x12> => 18,
1035             ...) and the RFC/MIT names (C/C/C => 23,
1036             C/C => 18, C => 17, C => 16,
1037             C => 3, C => 1) onto that same number. The classic
1038             use is flagging C (0x17) as a downgrade/roasting signal against an
1039             C baseline. Lookup is case-insensitive; an unlisted etype croaks
1040             unless a numeric C is given.
1041              
1042             =head2 windows_integrity_level_enum
1043              
1044             { munger => 'windows_integrity_level_enum', default => -1 }
1045              
1046             Named-map enum (lookup rules as L) for the Windows / Sysmon
1047             process integrity level, as an B: C 0, C 1, C
1048             2, C 3, C 4 (with C folded into C). The
1049             C mandatory-label SIDs Windows sometimes logs in place of the word
1050             (C => 3, ...) are accepted as aliases. Ordinal so "higher
1051             privilege than expected" is a monotone feature. Numeric inputs are not passed
1052             through.
1053              
1054             =head2 windows_logon_status_enum
1055              
1056             { munger => 'windows_logon_status_enum', default => -1 }
1057              
1058             Named-map enum (lookup rules as L) for the NTSTATUS
1059             sub-status on a failed Windows logon (events 4625/4776), collapsed to a
1060             compact B rather than the raw 32-bit code: C<0xC0000064>
1061             (no such user) 0, C<0xC000006A> (bad password) 1, C<0xC000006D> (generic bad
1062             user/pass) 2, C<0xC000006F> (outside hours) 3, C<0xC0000070> (workstation
1063             restriction) 4, C<0xC0000071> (password expired) 5, C<0xC0000072> (disabled)
1064             6, C<0xC0000193> (account expired) 7, C<0xC0000133> (clock skew) 8,
1065             C<0xC0000224> (must change password) 9, C<0xC0000234> (locked out) 10,
1066             C<0xC000015B> (logon type not granted) 11. Keys are the hex codes exactly as
1067             logged (matched case-insensitively); only the common logon subset is baked in,
1068             so an unlisted code croaks unless a numeric C is given. Numeric
1069             inputs are not passed through.
1070              
1071             =head2 windows_impersonation_level_enum
1072              
1073             { munger => 'windows_impersonation_level_enum', default => -1 }
1074              
1075             Named-map enum (lookup rules as L) for the event 4624
1076             impersonation level, ordered by reach: C 0, C 1,
1077             C 2, C 3. The C<%%1832> / C<%%1833> message tokens
1078             Windows often emits in place of the words (Identification / Impersonation) are
1079             accepted as aliases. Numeric inputs are not passed through.
1080              
1081             =head2 aad_signin_error_enum
1082              
1083             { munger => 'aad_signin_error_enum', default => -1 }
1084              
1085             Named-map enum for the Azure AD / Entra sign-in C error code,
1086             collapsed to a compact B rather than the raw code: C<0>
1087             (success) 0, invalid-password (C<50126>, C<50056>) 1, no-such-user (C<50034>)
1088             2, disabled (C<50057>) 3, locked / smart-lockout (C<50053>) 4, password-expired
1089             (C<50055>, C<50144>) 5, MFA-required (C<50074>, C<50076>, C<50079>) 6,
1090             MFA-failed (C<500121>, C<50158>) 7, blocked-by-conditional-access (C<53003>,
1091             C<53000>, C<53001>, C<530032>) 8, session-expired (C<50173>) 9. Although
1092             C is already numeric, the code space is huge and sparse and its
1093             magnitude carries no signal -- this maps the common codes onto a handful of
1094             meaningful buckets (and, unlike L, keeps related codes together). Keys
1095             are the codes as logged; only the common subset is baked in, so an unlisted
1096             code croaks unless a numeric C is given. Because the output is a
1097             category of our own numbering, numeric inputs are B passed through.
1098              
1099             =head2 risk_level_enum
1100              
1101             { munger => 'risk_level_enum', default => -1 }
1102              
1103             Named-map enum (lookup rules as L) for the Entra Identity
1104             Protection C as an B: C 0, C 1, C 2,
1105             C 3. C and C are left to the C
1106             (they are not points on the scale). Numeric inputs are not passed through.
1107              
1108             =head2 aws_principal_type_enum
1109              
1110             { munger => 'aws_principal_type_enum', default => -1 }
1111              
1112             Named-map enum (lookup rules as L) for the CloudTrail
1113             C: C 0, C 1, C 2,
1114             C 3, C 4, C 5, C 6,
1115             C 7, C 8, C 9, C 10. The
1116             numbering is nominal (distinct stable numbers, not a scale); C is the
1117             value you actually alert on. Numeric inputs are not passed through.
1118              
1119             =head2 aad_client_app_enum
1120              
1121             { munger => 'aad_client_app_enum', default => -1 }
1122              
1123             Named-map enum (lookup rules as L) for the Azure AD
1124             C, numbered so the modern clients sort low (C 0,
1125             C 1) and the B protocols -- which
1126             cannot satisfy MFA -- sort high (C, C, C,
1127             C, C, C, C
1128             Online PowerShell>, C, C, C
1129             clients>, from 2 up). A "C<< >= 2 >> means legacy auth" threshold is the
1130             intended feature. C/C/C short forms are accepted as aliases.
1131             Numeric inputs are not passed through.
1132              
1133             =head2 risk_state_enum
1134              
1135             { munger => 'risk_state_enum', default => -1 }
1136              
1137             Named-map enum (lookup rules as L) for the Entra Identity
1138             Protection C: C 0, C 1, C 2,
1139             C 3, C 4, C 5. Numeric inputs are not
1140             passed through.
1141              
1142             =head2 vpc_flow_log_status_enum
1143              
1144             { munger => 'vpc_flow_log_status_enum', default => -1 }
1145              
1146             Named-map enum (lookup rules as L) for the AWS VPC Flow Logs
1147             C: C 0, C 1, C 2. (The per-flow
1148             C/C action is a plain L; this is the capture-health
1149             field.) Numeric inputs are not passed through.
1150              
1151             =head2 aws_event_type_enum
1152              
1153             { munger => 'aws_event_type_enum', default => -1 }
1154              
1155             Named-map enum (lookup rules as L) for the CloudTrail
1156             C: C 0, C 1, C 2,
1157             C 3, C 4. C is the
1158             one worth flagging. Numeric inputs are not passed through.
1159              
1160             =head2 conditional_access_result_enum
1161              
1162             { munger => 'conditional_access_result_enum', default => -1 }
1163              
1164             Named-map enum (lookup rules as L) for the Azure AD sign-in
1165             C: C 0, C 1, C 2,
1166             C 3, C 4. Numeric inputs are not passed through.
1167              
1168             =cut
1169              
1170             # Named-map enums: baked-in value->number maps for well-known registries,
1171             # registered as "_enum". Keys are stored lowercase; lookup lowercases
1172             # the input, giving the case-insensitive matching the POD promises. 'numeric'
1173             # says whether a numeric input is passed through as-is -- set only where the
1174             # numbers are the protocol's own encoding (a qtype 28 IS AAAA on the wire);
1175             # where they are ordinals of our own invention (tls_version, the method
1176             # enums), passthrough would mix scales, so a number croaks like any other
1177             # unmapped value.
1178              
1179             # SASL mechanism names, ordered weakest-to-strongest, for sasl_mech_enum. The
1180             # same set is numbered alphabetically for sasl_mech_iana_enum, so the two
1181             # mungers can never end up covering different mechanisms. Includes the IANA
1182             # registry plus the ubiquitous non-registered login/xoauth2/apop.
1183             my @SASL_MECHS_BY_STRENGTH = qw(
1184             anonymous plain login
1185             apop cram-md5 digest-md5 ntlm skey otp securid rpa kerberos_v4
1186             srp scram-sha-1 scram-sha-1-plus scram-sha-256 scram-sha-256-plus
1187             xoauth2 oauthbearer openid20 saml20
1188             gssapi gs2-krb5 gss-spnego external
1189             );
1190              
1191             my %NAMED_ENUM = (
1192             dns_rcode => {
1193             numeric => 1,
1194             map => {
1195             noerror => 0,
1196             formerr => 1,
1197             servfail => 2,
1198             nxdomain => 3,
1199             notimp => 4,
1200             notimpl => 4,
1201             refused => 5,
1202             yxdomain => 6,
1203             yxrrset => 7,
1204             nxrrset => 8,
1205             notauth => 9,
1206             notzone => 10,
1207             dsotypeni => 11,
1208             badvers => 16,
1209             badsig => 16,
1210             badkey => 17,
1211             badtime => 18,
1212             badmode => 19,
1213             badname => 20,
1214             badalg => 21,
1215             badtrunc => 22,
1216             badcookie => 23,
1217             },
1218             },
1219             dns_qtype => {
1220             numeric => 1,
1221             map => {
1222             a => 1,
1223             ns => 2,
1224             cname => 5,
1225             soa => 6,
1226             mb => 7,
1227             mg => 8,
1228             mr => 9,
1229             'null' => 10,
1230             wks => 11,
1231             ptr => 12,
1232             hinfo => 13,
1233             minfo => 14,
1234             mx => 15,
1235             txt => 16,
1236             rp => 17,
1237             afsdb => 18,
1238             sig => 24,
1239             key => 25,
1240             aaaa => 28,
1241             loc => 29,
1242             srv => 33,
1243             naptr => 35,
1244             kx => 36,
1245             cert => 37,
1246             dname => 39,
1247             opt => 41,
1248             ds => 43,
1249             sshfp => 44,
1250             ipseckey => 45,
1251             rrsig => 46,
1252             nsec => 47,
1253             dnskey => 48,
1254             dhcid => 49,
1255             nsec3 => 50,
1256             nsec3param => 51,
1257             tlsa => 52,
1258             smimea => 53,
1259             hip => 55,
1260             cds => 59,
1261             cdnskey => 60,
1262             openpgpkey => 61,
1263             csync => 62,
1264             zonemd => 63,
1265             svcb => 64,
1266             https => 65,
1267             eui48 => 108,
1268             eui64 => 109,
1269             tkey => 249,
1270             tsig => 250,
1271             ixfr => 251,
1272             axfr => 252,
1273             any => 255,
1274             '*' => 255,
1275             uri => 256,
1276             caa => 257,
1277             },
1278             },
1279             syslog_severity => {
1280             numeric => 1,
1281             map => {
1282             emerg => 0,
1283             panic => 0,
1284             alert => 1,
1285             crit => 2,
1286             err => 3,
1287             error => 3,
1288             warning => 4,
1289             warn => 4,
1290             notice => 5,
1291             info => 6,
1292             informational => 6,
1293             debug => 7,
1294             },
1295             },
1296             syslog_facility => {
1297             numeric => 1,
1298             map => {
1299             kern => 0,
1300             user => 1,
1301             mail => 2,
1302             daemon => 3,
1303             auth => 4,
1304             security => 4,
1305             syslog => 5,
1306             lpr => 6,
1307             news => 7,
1308             uucp => 8,
1309             cron => 9,
1310             authpriv => 10,
1311             ftp => 11,
1312             ntp => 12,
1313             audit => 13,
1314             alert => 14,
1315             clock => 15,
1316             ( map { ( "local$_" => 16 + $_ ) } 0 .. 7 ),
1317             },
1318             },
1319             ip_proto => {
1320             numeric => 1,
1321             map => {
1322             icmp => 1,
1323             igmp => 2,
1324             ipip => 4,
1325             ipencap => 4,
1326             tcp => 6,
1327             egp => 8,
1328             udp => 17,
1329             dccp => 33,
1330             ipv6 => 41,
1331             rsvp => 46,
1332             gre => 47,
1333             esp => 50,
1334             ah => 51,
1335             icmpv6 => 58,
1336             'ipv6-icmp' => 58,
1337             ospf => 89,
1338             pim => 103,
1339             sctp => 132,
1340             udplite => 136,
1341             },
1342             },
1343             tls_version => {
1344             numeric => 0,
1345             map => {
1346             sslv2 => 0,
1347             ssl2 => 0,
1348             sslv3 => 1,
1349             ssl3 => 1,
1350             tlsv1 => 2,
1351             'tlsv1.0' => 2,
1352             tls1 => 2,
1353             'tls1.0' => 2,
1354             'tlsv1.1' => 3,
1355             'tls1.1' => 3,
1356             'tlsv1.2' => 4,
1357             'tls1.2' => 4,
1358             'tlsv1.3' => 5,
1359             'tls1.3' => 5,
1360             },
1361             },
1362             http_method => {
1363             numeric => 0,
1364             map => {
1365             get => 0,
1366             head => 1,
1367             post => 2,
1368             put => 3,
1369             delete => 4,
1370             connect => 5,
1371             options => 6,
1372             trace => 7,
1373             patch => 8,
1374             },
1375             },
1376             sip_method => {
1377             numeric => 0,
1378             map => {
1379             invite => 0,
1380             ack => 1,
1381             bye => 2,
1382             cancel => 3,
1383             register => 4,
1384             options => 5,
1385             prack => 6,
1386             subscribe => 7,
1387             notify => 8,
1388             publish => 9,
1389             info => 10,
1390             refer => 11,
1391             message => 12,
1392             update => 13,
1393             },
1394             },
1395             dhcp_msgtype => {
1396             numeric => 1,
1397             map => {
1398             (
1399             map { ( $_->[0] => $_->[1], "dhcp$_->[0]" => $_->[1] ) } [ discover => 1 ],
1400             [ offer => 2 ],
1401             [ request => 3 ],
1402             [ decline => 4 ],
1403             [ ack => 5 ],
1404             [ nak => 6 ],
1405             [ release => 7 ],
1406             [ inform => 8 ]
1407             ),
1408             },
1409             },
1410             app_proto => {
1411             numeric => 0,
1412             map => {
1413             # Ordinals of our own invention (Suricata's app_proto is a string
1414             # label with no wire number), assigned from a fixed order so a value
1415             # munges to the same number on every host. 'failed'/'unknown' are
1416             # kept as their own classes -- an un-parsed app layer is often the
1417             # interesting row.
1418             do {
1419             my @order = qw(
1420             unknown failed http http2 ftp ftp-data smtp imap
1421             tls ssh smb dcerpc dns modbus enip dnp3 nfs ntp
1422             tftp ike krb5 quic dhcp snmp sip rfb mqtt rdp
1423             telnet pgsql ldap websocket bittorrent-dht
1424             );
1425             my %m = map { $order[$_] => $_ } 0 .. $#order;
1426             $m{ssl} = $m{tls}; # Suricata's older spelling
1427             $m{ikev2} = $m{ike};
1428             %m;
1429             },
1430             },
1431             },
1432             tcp_state => {
1433             numeric => 0,
1434             map => {
1435             # The TCP state machine (flow.tcp.state), numbered along the
1436             # connection lifecycle so the ordinal is meaningful.
1437             do {
1438             my @order = qw(
1439             none syn_sent syn_recv established
1440             fin_wait1 fin_wait2 closing time_wait
1441             close_wait last_ack closed
1442             );
1443             map { $order[$_] => $_ } 0 .. $#order;
1444             },
1445             },
1446             },
1447             flow_state => {
1448             numeric => 0,
1449             map => {
1450             new => 0,
1451             established => 1,
1452             closed => 2,
1453             bypassed => 3,
1454             local_bypass => 4,
1455             },
1456             },
1457             flow_reason => {
1458             numeric => 0,
1459             map => {
1460             timeout => 0,
1461             forced => 1,
1462             shutdown => 2,
1463             unknown => 3,
1464             },
1465             },
1466             suricata_action => {
1467             numeric => 0,
1468             map => {
1469             allowed => 0,
1470             blocked => 1,
1471             pass => 2,
1472             drop => 3,
1473             reject => 4,
1474             alert => 5,
1475             },
1476             },
1477             postfix_status => {
1478             numeric => 0,
1479             map => {
1480             sent => 0,
1481             deferred => 1,
1482             bounced => 2,
1483             expired => 3,
1484             deliverable => 4,
1485             undeliverable => 5,
1486             hold => 6,
1487             discard => 7,
1488             filtered => 8,
1489             reject => 9,
1490             softbounce => 10,
1491             },
1492             },
1493             spf_result => {
1494             numeric => 0,
1495             map => {
1496             pass => 0,
1497             neutral => 1,
1498             none => 2,
1499             softfail => 3,
1500             fail => 4,
1501             temperror => 5,
1502             error => 5, # older spelling of temperror
1503             permerror => 6,
1504             unknown => 6, # older spelling of permerror
1505             },
1506             },
1507             dkim_result => {
1508             numeric => 0,
1509             map => {
1510             pass => 0,
1511             neutral => 1,
1512             none => 2,
1513             policy => 3,
1514             fail => 4,
1515             temperror => 5,
1516             error => 5, # older spelling of temperror
1517             permerror => 6,
1518             unknown => 6, # older spelling of permerror
1519             },
1520             },
1521             dmarc_result => {
1522             numeric => 0,
1523             map => {
1524             pass => 0,
1525             none => 1,
1526             fail => 2,
1527             temperror => 3,
1528             permerror => 4,
1529             bestguesspass => 5,
1530             },
1531             },
1532             sasl_mech => {
1533             numeric => 0,
1534             map => {
1535             do {
1536             my @o = @SASL_MECHS_BY_STRENGTH;
1537             map { $o[$_] => $_ } 0 .. $#o;
1538             },
1539             },
1540             },
1541             sasl_mech_iana => {
1542             numeric => 0,
1543             map => {
1544             do {
1545             my @o = sort @SASL_MECHS_BY_STRENGTH;
1546             map { $o[$_] => $_ } 0 .. $#o;
1547             },
1548             },
1549             },
1550             http_version => {
1551             numeric => 0, # a logged "2" is version 2.0, not the integer two
1552             map => {
1553             # Ordinal so "older than expected" is a monotone feature. Accepts
1554             # the access-log spelling (HTTP/1.1), the bare number (1.1), and
1555             # the ALPN/h2 shorthands.
1556             do {
1557             my %v = (
1558             'http/0.9' => 0,
1559             'http/1.0' => 1,
1560             'http/1.1' => 2,
1561             'http/2.0' => 3,
1562             'http/3.0' => 4,
1563             );
1564             $v{'0.9'} = 0;
1565             $v{'1.0'} = 1;
1566             $v{'1.1'} = 2;
1567             $v{'2.0'} = $v{'2'} = $v{'http/2'} = $v{'h2'} = $v{'h2c'} = 3;
1568             $v{'3.0'} = $v{'3'} = $v{'http/3'} = $v{'h3'} = 4;
1569             %v;
1570             },
1571             },
1572             },
1573             spamassassin_autolearn => {
1574             numeric => 0,
1575             map => {
1576             # SpamAssassin's autolearn= field. Nominal, but ordered so
1577             # "no learning happened" sorts below the ham/spam outcomes.
1578             no => 0,
1579             ham => 1,
1580             spam => 2,
1581             disabled => 3,
1582             failed => 4,
1583             unavailable => 5,
1584             unknown => 6,
1585             },
1586             },
1587             rspamd_action => {
1588             numeric => 0,
1589             map => {
1590             # rspamd's action, ordered by severity. Accept both the space
1591             # and underscore spellings rspamd emits across its outputs.
1592             do {
1593             my %a = (
1594             'no action' => 0,
1595             'greylist' => 1,
1596             'add header' => 2,
1597             'rewrite subject' => 3,
1598             'soft reject' => 4,
1599             'reject' => 5,
1600             );
1601             $a{'no_action'} = $a{'noaction'} = 0;
1602             $a{'add_header'} = 2;
1603             $a{'rewrite_subject'} = 3;
1604             $a{'soft_reject'} = $a{'soft-reject'} = 4;
1605             %a;
1606             },
1607             },
1608             },
1609             ssh_auth_method => {
1610             numeric => 0,
1611             map => {
1612             # OpenSSH authentication method, ordered by credential strength
1613             # (weakest first) so "weaker than expected" is monotone. The
1614             # ordering is a judgement call, not an IANA registry.
1615             do {
1616             my @o = qw(
1617             none password keyboard-interactive
1618             hostbased publickey
1619             gssapi-with-mic gssapi-keyex
1620             );
1621             my %m = map { $o[$_] => $_ } 0 .. $#o;
1622             $m{'gssapi'} = $m{'gssapi-with-mic'};
1623             %m;
1624             },
1625             },
1626             },
1627             amavis_category => {
1628             numeric => 0,
1629             map => {
1630             # amavisd-new content category, ordered clean -> worst.
1631             do {
1632             my @o = qw(
1633             clean oversized unchecked spammy spam
1634             badheader banned infected mtablocked
1635             );
1636             my %m = map { $o[$_] => $_ } 0 .. $#o;
1637             $m{'bad-header'} = $m{'badheader'};
1638             $m{'virus'} = $m{'infected'};
1639             $m{'mta-blocked'} = $m{'mtablocked'};
1640             %m;
1641             },
1642             },
1643             },
1644             systemd_result => {
1645             numeric => 0,
1646             map => {
1647             # systemd unit "result" (e.g. "Failed with result 'timeout'").
1648             do {
1649             my @o = qw(
1650             success protocol timeout exit-code signal
1651             core-dump watchdog start-limit-hit oom-kill resources
1652             );
1653             my %m = map { $o[$_] => $_ } 0 .. $#o;
1654             $m{'exit_code'} = $m{'exit-code'};
1655             $m{'core_dump'} = $m{'core-dump'};
1656             $m{'start_limit_hit'} = $m{'start-limit-hit'};
1657             $m{'oom_kill'} = $m{'oom-kill'};
1658             %m;
1659             },
1660             },
1661             },
1662             clamav_result => {
1663             numeric => 0,
1664             map => {
1665             # clamd / clamav-milter per-target verdict.
1666             ok => 0,
1667             found => 1,
1668             error => 2,
1669             },
1670             },
1671             kerberos_etype => {
1672             numeric => 1, # RFC 3961 etype numbers are the wire value; a logged 23 IS rc4
1673             map => {
1674             # Windows logs the ticket encryption type as hex ("0x17"); the
1675             # RFC/MIT names appear in other Kerberos logs. Everything resolves
1676             # to the decimal etype number, so a decimal input passes through.
1677             do {
1678             my %e = (
1679             'des-cbc-crc' => 1,
1680             'des-cbc-md5' => 3,
1681             'des3-cbc-sha1' => 16,
1682             'aes128-cts-hmac-sha1-96' => 17,
1683             'aes256-cts-hmac-sha1-96' => 18,
1684             'rc4-hmac' => 23,
1685             'rc4-hmac-exp' => 24,
1686             );
1687             $e{'des3'} = 16;
1688             $e{'aes128'} = 17;
1689             $e{'aes256'} = 18;
1690             $e{'arcfour-hmac'} = $e{'rc4'} = 23;
1691             $e{'0x1'} = 1;
1692             $e{'0x3'} = 3;
1693             $e{'0x10'} = 16;
1694             $e{'0x11'} = 17;
1695             $e{'0x12'} = 18;
1696             $e{'0x17'} = 23;
1697             $e{'0x18'} = 24;
1698             %e;
1699             },
1700             },
1701             },
1702             windows_integrity_level => {
1703             numeric => 0,
1704             map => {
1705             # Sysmon IntegrityLevel; ordinal so "higher privilege than
1706             # expected" is monotone. Text labels plus the S-1-16-* mandatory
1707             # label SIDs Windows sometimes logs in their place.
1708             do {
1709             my %m = (
1710             untrusted => 0,
1711             low => 1,
1712             medium => 2,
1713             high => 3,
1714             system => 4,
1715             );
1716             $m{'mediumplus'} = 2;
1717             $m{'s-1-16-0'} = 0;
1718             $m{'s-1-16-4096'} = 1;
1719             $m{'s-1-16-8192'} = 2;
1720             $m{'s-1-16-12288'} = 3;
1721             $m{'s-1-16-16384'} = 4;
1722             %m;
1723             },
1724             },
1725             },
1726             windows_logon_status => {
1727             numeric => 0,
1728             map => {
1729             # Common NTSTATUS sub-status codes on failed logons (4625/4776),
1730             # mapped to a compact reason category -- the raw 32-bit value is
1731             # not itself a useful feature. Keys are the hex codes as logged.
1732             '0xc0000064' => 0, # user name does not exist
1733             '0xc000006a' => 1, # bad password
1734             '0xc000006d' => 2, # bad user name or password (generic)
1735             '0xc000006f' => 3, # outside authorized hours
1736             '0xc0000070' => 4, # workstation restriction
1737             '0xc0000071' => 5, # password expired
1738             '0xc0000072' => 6, # account disabled
1739             '0xc0000193' => 7, # account expired
1740             '0xc0000133' => 8, # clock skew between client and server
1741             '0xc0000224' => 9, # must change password at next logon
1742             '0xc0000234' => 10, # account locked out
1743             '0xc000015b' => 11, # logon type not granted
1744             },
1745             },
1746             windows_impersonation_level => {
1747             numeric => 0,
1748             map => {
1749             # 4624 ImpersonationLevel; ordinal by reach. Text labels plus the
1750             # two "%%18xx" message tokens Windows most often emits in place.
1751             anonymous => 0,
1752             identification => 1,
1753             impersonation => 2,
1754             delegation => 3,
1755             '%%1832' => 1,
1756             '%%1833' => 2,
1757             },
1758             },
1759             aad_signin_error => {
1760             numeric => 0,
1761             map => {
1762             # Azure AD / Entra sign-in ResultType codes collapsed to a compact
1763             # reason category -- the raw code is a huge sparse space whose
1764             # magnitude carries no signal. Keys are the numeric codes as
1765             # logged; only the common subset is baked in, the rest take the
1766             # default.
1767             '0' => 0, # success
1768             '50126' => 1, # invalid username or password
1769             '50056' => 1, # invalid or null password
1770             '50034' => 2, # user does not exist in directory
1771             '50057' => 3, # account disabled
1772             '50053' => 4, # account locked / smart lockout
1773             '50055' => 5, # password expired
1774             '50144' => 5, # AD password expired
1775             '50074' => 6, # strong auth (MFA) required
1776             '50076' => 6, # MFA required by conditional access
1777             '50079' => 6, # user must enroll for MFA
1778             '500121' => 7, # MFA denied / authentication failed
1779             '50158' => 7, # external security challenge not satisfied
1780             '53003' => 8, # blocked by conditional access
1781             '53000' => 8, # device not compliant (CA)
1782             '53001' => 8, # device not domain joined (CA)
1783             '530032' => 8, # blocked by security policy (CA)
1784             '50173' => 9, # fresh auth token required (session expired)
1785             },
1786             },
1787             risk_level => {
1788             numeric => 0,
1789             map => {
1790             # Entra Identity Protection riskLevel, ordinal. hidden /
1791             # unknownFutureValue are left to the default.
1792             none => 0,
1793             low => 1,
1794             medium => 2,
1795             high => 3,
1796             },
1797             },
1798             aws_principal_type => {
1799             numeric => 0,
1800             map => {
1801             # CloudTrail userIdentity.type. Nominal (distinct stable numbers);
1802             # 'root' is the value you actually alert on.
1803             do {
1804             my @o = qw(
1805             root iamuser assumedrole federateduser samluser
1806             webidentityuser directory identitycenteruser
1807             awsaccount awsservice unknown
1808             );
1809             map { $o[$_] => $_ } 0 .. $#o;
1810             },
1811             },
1812             },
1813             aad_client_app => {
1814             numeric => 0,
1815             map => {
1816             # Azure AD ClientAppUsed. Numbered so the modern clients sort low
1817             # and the legacy-auth protocols (which cannot do MFA) sort high --
1818             # a ">= 2 means legacy auth" threshold is the feature you want.
1819             do {
1820             my %m = (
1821             'browser' => 0,
1822             'mobile apps and desktop clients' => 1,
1823             );
1824             my @legacy = (
1825             'exchange activesync',
1826             'imap4',
1827             'pop3',
1828             'authenticated smtp',
1829             'smtp',
1830             'mapi over http',
1831             'exchange web services',
1832             'exchange online powershell',
1833             'autodiscover',
1834             'offline address book',
1835             'other clients',
1836             );
1837             my $i = 2;
1838             $m{$_} = $i++ for @legacy;
1839             $m{'imap'} = $m{'imap4'};
1840             $m{'pop'} = $m{'pop3'};
1841             $m{'mapi'} = $m{'mapi over http'};
1842             %m;
1843             },
1844             },
1845             },
1846             risk_state => {
1847             numeric => 0,
1848             map => {
1849             # Entra Identity Protection riskState.
1850             none => 0,
1851             confirmedsafe => 1,
1852             remediated => 2,
1853             dismissed => 3,
1854             atrisk => 4,
1855             confirmedcompromised => 5,
1856             },
1857             },
1858             vpc_flow_log_status => {
1859             numeric => 0,
1860             map => {
1861             # VPC Flow Logs log-status.
1862             ok => 0,
1863             nodata => 1,
1864             skipdata => 2,
1865             },
1866             },
1867             aws_event_type => {
1868             numeric => 0,
1869             map => {
1870             # CloudTrail eventType. AwsConsoleSignIn is the one you flag.
1871             awsapicall => 0,
1872             awsserviceevent => 1,
1873             awsconsoleaction => 2,
1874             awsconsolesignin => 3,
1875             awscloudtrailinsight => 4,
1876             },
1877             },
1878             conditional_access_result => {
1879             numeric => 0,
1880             map => {
1881             # Azure AD sign-in conditionalAccessStatus.
1882             success => 0,
1883             notapplied => 1,
1884             notenabled => 2,
1885             reportonly => 3,
1886             failure => 4,
1887             },
1888             },
1889             );
1890             for my $name ( keys %NAMED_ENUM ) {
1891             my $e = $NAMED_ENUM{$name};
1892             $BUILDERS{"${name}_enum"} = sub { _named_enum_munger( $name, $e, @_ ) };
1893             }
1894              
1895             # Shared closure for the named-map enums registered from %NAMED_ENUM.
1896             sub _named_enum_munger {
1897 48     48   154 my ( $name, $e, $spec, $where ) = @_;
1898              
1899 48         117 my $has_default = exists $spec->{default};
1900 48         103 my $default = $spec->{default};
1901 48 100 100     362 croak "${name}_enum munger$where: 'default' must be numeric"
1902             if $has_default && !looks_like_number($default);
1903              
1904 47         89 my ( $map, $numeric ) = @{$e}{qw(map numeric)};
  47         169  
1905             return sub {
1906 332     332   24622 my ($v) = @_;
1907 332 100       1016 if ( defined $v ) {
1908 331 100 100     1287 return $v + 0 if $numeric && looks_like_number($v);
1909 325         742 my $k = lc $v;
1910 325 100       2330 return $map->{$k} if exists $map->{$k};
1911             }
1912 26 100       136 return $default if $has_default;
1913 9 50       1532 croak "${name}_enum munger$where: no mapping for '" . ( defined $v ? $v : 'undef' ) . "'";
1914 47         447 }; ## end sub
1915             } ## end sub _named_enum_munger
1916              
1917             =head2 bool
1918              
1919             { munger => 'bool' } # Perl truthiness -> 1/0
1920             { munger => 'bool', true => [ 'yes', 'Y', '1', 'true' ] }
1921              
1922             Coerce to C<1> or C<0>. With a C list, only those (string-compared) values
1923             are C<1>; otherwise ordinary Perl truthiness is used.
1924              
1925             =cut
1926              
1927             sub _build_bool {
1928 2     2   3 my ( $spec, $where ) = @_;
1929              
1930 2 100       6 if ( exists $spec->{true} ) {
1931             croak "bool munger$where: 'true' must be an arrayref"
1932 1 50       4 unless ref $spec->{true} eq 'ARRAY';
1933 1         2 my %true = map { $_ => 1 } @{ $spec->{true} };
  3         7  
  1         3  
1934             return sub {
1935 3     3   10 my ($v) = @_;
1936 3 100       15 return exists $true{ defined $v ? $v : '' } ? 1 : 0;
    100          
1937 1         7 };
1938             }
1939              
1940 1 100   2   4 return sub { $_[0] ? 1 : 0 };
  2         12  
1941             } ## end sub _build_bool
1942              
1943             =head2 length
1944              
1945             { munger => 'length' }
1946              
1947             The character length of the stringified input, C counting as C<0> (an
1948             absent value is a zero-length one -- e.g. an SNI-absent TLS record). This is the
1949             cheap shape feature behind every C<*_length> column (domain, URL, filename, SNI,
1950             hostname, ...): tunneling and generated names run long, so raw length is a
1951             surprisingly strong corroborator next to L. Length is counted in
1952             B, not bytes, so a multi-byte name is measured as a human would read
1953             it; use L (which is byte-oriented) when you want per-symbol randomness.
1954              
1955             =cut
1956              
1957             sub _build_length {
1958 7     7   22 my ( $spec, $where ) = @_;
1959             return sub {
1960 13     13   37 my ($v) = @_;
1961 13 100       74 return length( defined $v ? "$v" : '' );
1962 7         36 };
1963             }
1964              
1965             =head2 entropy
1966              
1967             { munger => 'entropy' }
1968              
1969             Shannon entropy of the input string, in B -- i.e.
1970             C<-sum(p*log2(p))> over the frequencies of its bytes. This is the single most
1971             common feature in the pipeline (DGA domains, randomized filenames, forged
1972             User-Agents, generated SNIs / hostnames / principal names), because
1973             machine-generated strings spread their characters far more evenly than
1974             human-chosen ones and so score high, while a real word scores low. An empty
1975             string is C<0>; the maximum is C<8> (every byte value equally likely).
1976              
1977             Entropy is computed over the string's B (matching L), so the
1978             value is well-defined regardless of the scalar's internal encoding flag. Like
1979             C, this munger is XS-accelerated -- a per-byte histogram plus a C per
1980             distinct byte -- with a pure-Perl fallback that produces identical values;
1981             C<$Algorithm::ToNumberMunger::HAVE_XS> says which
1982             is in use.
1983              
1984             =cut
1985              
1986             sub _build_entropy {
1987 1     1   3 my ( $spec, $where ) = @_;
1988 1 50       4 my $fn = $HAVE_XS ? \&_entropy_xs : \&_entropy_pp;
1989             return sub {
1990 12     12   1177 my ($v) = @_;
1991 12 50       103 return $fn->( defined $v ? "$v" : '' );
1992 1         6 };
1993             }
1994              
1995             # Pure-Perl Shannon entropy (bits), used only when the XS did not build. Byte
1996             # view via an explicit encode so it matches the XS's SvPVutf8, and so the same
1997             # string scores the same regardless of its internal flag.
1998             sub _entropy_pp {
1999 6     6   10 my ($str) = @_;
2000 6         14 utf8::encode($str);
2001 6         9 my $n = length $str;
2002 6 100       18 return 0 unless $n;
2003 5         6 my %count;
2004 5         43 $count{$_}++ for unpack 'C*', $str;
2005 5         9 my $ln2 = log(2);
2006 5         6 my $h = 0;
2007              
2008 5         10 for my $c ( values %count ) {
2009 28         29 my $p = $c / $n;
2010 28         39 $h -= $p * ( log($p) / $ln2 );
2011             }
2012 5         21 return $h;
2013             } ## end sub _entropy_pp
2014              
2015             =head2 ngram
2016              
2017             { munger => 'ngram', counts => { th => 152, he => 128, in => 94, ... } }
2018             # defaults: smoothing => 1, fold_case => 1; n is inferred from the keys
2019              
2020             Mean per-gram surprisal of the input string against a B
2021             n-gram count table: C, each gram's probability
2022             smoothed exactly as in L. This is C's sequential cousin
2023             and the strongest single gibberish detector: L misses
2024             I generated names and is unreliable on short strings, while an
2025             n-gram score against (say) hostname bigram statistics catches both -- real
2026             words ride the common bigrams and score low, generated names keep hitting rare
2027             ones and score high. Dividing by the gram count keeps scores comparable across
2028             lengths.
2029              
2030             C maps each n-gram to how often it was observed when the table was
2031             built; all keys must be the same length, and that length B C (bigrams
2032             are the usual choice -- a 26x26 table stays tiny in C; past
2033             C<$FROZEN_FREQ_MAP_WARN_KEYS> entries it warns like C). C defaults
2034             to the sum of counts and may be given larger to prune the tail, exactly as in
2035             C. A gram absent from the table gets the smoothed unseen-bucket
2036             probability -- an unseen gram is the interesting case -- so C must
2037             be > 0 (default C<1>). With C (default on) the input is lowercased
2038             before scoring, matching the usual lowercased table. A string with no grams
2039             (shorter than C) scores C<0>. Grams are taken over B, matching
2040             L rather than the byte-oriented C.
2041              
2042             =cut
2043              
2044             sub _build_ngram {
2045 7     7   12 my ( $spec, $where ) = @_;
2046              
2047 7         13 my $counts = $spec->{counts};
2048 7 100 66     154 croak "ngram munger$where requires a non-empty 'counts' hashref"
2049             unless ref $counts eq 'HASH' && %$counts;
2050              
2051 6         8 my $n;
2052 6         8 my $sum = 0;
2053 6         14 for my $g ( keys %$counts ) {
2054 9 100       16 $n = length $g unless defined $n;
2055 9 100       105 croak "ngram munger$where: all 'counts' keys must be the same length "
2056             . "(that length is n); got '$g' alongside a $n-gram"
2057             unless length($g) == $n;
2058 8         11 my $c = $counts->{$g};
2059 8 50 66     129 croak "ngram munger$where: count for '$g' ('"
    100          
2060             . ( defined $c ? $c : 'undef' )
2061             . "') is not a non-negative number"
2062             unless looks_like_number($c) && $c >= 0;
2063 7         25 $sum += $c;
2064             } ## end for my $g ( keys %$counts )
2065 4 50       10 croak "ngram munger$where: 'counts' keys must be at least 1 character"
2066             unless $n >= 1;
2067              
2068 4         6 my $V = keys %$counts;
2069 4 50       13 carp "ngram munger$where: 'counts' has $V keys; a table this large bloats info.json"
2070             if $V > $FROZEN_FREQ_MAP_WARN_KEYS;
2071              
2072 4 100       12 my $total = defined $spec->{total} ? $spec->{total} : $sum;
2073 4 50       9 croak "ngram munger$where: 'total' must be numeric"
2074             unless looks_like_number($total);
2075 4 100       115 croak "ngram munger$where: 'total' ($total) must be >= sum of counts ($sum)"
2076             if $total < $sum;
2077              
2078 3 100       9 my $s = defined $spec->{smoothing} ? $spec->{smoothing} : 1;
2079 3 100 66     134 croak "ngram munger$where: 'smoothing' must be a number > 0 "
2080             . '(an unseen gram would otherwise be infinitely surprising)'
2081             unless looks_like_number($s) && $s > 0;
2082              
2083 2 50       6 my $fold = exists $spec->{fold_case} ? ( $spec->{fold_case} ? 1 : 0 ) : 1;
    100          
2084              
2085             # Same smoothed-probability scheme as frozen_freq_map, "unseen" as one extra
2086             # bucket; surprisal precomputed per listed gram.
2087 2         3 my $denom = $total + $s * ( $V + 1 );
2088 2         5 my %si = map { $_ => -log( ( $counts->{$_} + $s ) / $denom ) } keys %$counts;
  4         50  
2089 2         4 my $unseen = -log( $s / $denom );
2090              
2091             return sub {
2092 12     12   39 my ($v) = @_;
2093 12 100       35 my $str = defined $v ? "$v" : '';
2094 12 100       28 $str = lc $str if $fold;
2095 12         20 my $grams = length($str) - $n + 1;
2096 12 100       30 return 0 if $grams < 1;
2097 9         13 my $tot = 0;
2098 9         20 for my $i ( 0 .. $grams - 1 ) {
2099 14         24 my $g = substr( $str, $i, $n );
2100 14 100       34 $tot += exists $si{$g} ? $si{$g} : $unseen;
2101             }
2102 9         38 return $tot / $grams;
2103 2         21 }; ## end sub
2104             } ## end sub _build_ngram
2105              
2106             =head2 char
2107              
2108             { munger => 'char', class => 'non_alnum', mode => 'ratio' }
2109             { munger => 'char', class => 'non_ascii' } # mode defaults to count
2110              
2111             Count the characters of the input that fall in a named C, either as a raw
2112             C (default) or, with C<< mode => 'ratio' >>, as a fraction of the string's
2113             length (C<0> for an empty string). This is the injection / obfuscation detector
2114             behind columns like C (a I, so it stays independent of
2115             length) and C (a I): payloads and homoglyph tricks
2116             are dense with punctuation, percent-encoding, or non-ASCII where normal input is
2117             not. Counting is over B, so C means codepoints above 127.
2118              
2119             Recognised classes: C / C, C / C, C,
2120             C, C, C, C, C, C, C,
2121             C. C and C are the ASCII letters (C counting as a
2122             consonant) -- a vowel/consonant I is a DGA corroborator that catches
2123             consonant-heavy random strings C alone underrates; C is
2124             C<0-9a-fA-F>, dense in encoded payloads.
2125              
2126             =cut
2127              
2128             # class name => a counting sub over an (already copied) string. The literal-
2129             # range classes count with tr///, which runs at C speed -- an order of
2130             # magnitude faster than tallying regex matches. tr/// needs its ranges spelled
2131             # at compile time, hence one sub per class rather than a data table. The 'run'
2132             # munger's %RUN_RE mirrors these class names; keep the two in sync.
2133             my %CHAR_COUNT = (
2134             alnum => sub { $_[0] =~ tr/A-Za-z0-9// },
2135             non_alnum => sub { $_[0] =~ tr/A-Za-z0-9//c },
2136             ascii => sub { $_[0] =~ tr/\x00-\x7f// },
2137             non_ascii => sub { $_[0] =~ tr/\x00-\x7f//c },
2138             digit => sub { $_[0] =~ tr/0-9// },
2139             alpha => sub { $_[0] =~ tr/A-Za-z// },
2140             upper => sub { $_[0] =~ tr/A-Z// },
2141             lower => sub { $_[0] =~ tr/a-z// },
2142             vowel => sub { $_[0] =~ tr/aeiouAEIOU// },
2143             consonant => sub { $_[0] =~ tr/b-df-hj-np-tv-zB-DF-HJ-NP-TV-Z// },
2144             xdigit => sub { $_[0] =~ tr/0-9A-Fa-f// },
2145             # space and punct match richer classes (\s, [[:punct:]], including their
2146             # Unicode behavior) that tr/// ranges cannot reproduce; they stay on the
2147             # regex so their semantics do not change.
2148             space => sub { my $n = () = $_[0] =~ /\s/g; $n },
2149             punct => sub { my $n = () = $_[0] =~ /[[:punct:]]/g; $n },
2150             );
2151              
2152             sub _build_char {
2153 10     10   15 my ( $spec, $where ) = @_;
2154              
2155 10         16 my $class = $spec->{class};
2156 10 50       19 croak "char munger$where requires a 'class'"
2157             unless defined $class;
2158 10 100       149 my $count = $CHAR_COUNT{$class}
2159             or croak "char munger$where: unknown class '$class' (known: " . join( ', ', sort keys %CHAR_COUNT ) . ')';
2160              
2161 9 100       17 my $mode = defined $spec->{mode} ? $spec->{mode} : 'count';
2162 9 100 100     127 croak "char munger$where: 'mode' must be 'count' or 'ratio'"
2163             unless $mode eq 'count' || $mode eq 'ratio';
2164 8 100       39 my $ratio = $mode eq 'ratio' ? 1 : 0;
2165              
2166             return sub {
2167 11     11   43 my ($v) = @_;
2168 11 50       27 my $s = defined $v ? "$v" : '';
2169 11         26 my $n = $count->($s);
2170 11 100       38 return $n unless $ratio;
2171 3         7 my $len = length $s;
2172 3 100       15 return $len ? $n / $len : 0;
2173 8         52 };
2174             } ## end sub _build_char
2175              
2176             =head2 run
2177              
2178             { munger => 'run', class => 'consonant' }
2179             { munger => 'run', class => 'digit' }
2180              
2181             The length of the longest unbroken run of characters in a named C --
2182             the same class names L recognises. Where C counts how many such
2183             characters occur in total, C measures how tightly they clump: the
2184             longest consonant run and longest digit run are staple generated-name (DGA)
2185             features that neither total counts nor L capture, because a real
2186             word breaks its consonants up with vowels while a random string will happily
2187             emit six in a row. An empty or undef input is C<0>.
2188              
2189             =cut
2190              
2191             # class name => a character-class pattern for the 'run' munger. Mirrors
2192             # %CHAR_COUNT's class names (keep in sync); runs need a regex quantifier, so
2193             # tr///'s speed trick does not apply here.
2194             my %RUN_RE = (
2195             alnum => '[A-Za-z0-9]',
2196             non_alnum => '[^A-Za-z0-9]',
2197             ascii => '[\x00-\x7f]',
2198             non_ascii => '[^\x00-\x7f]',
2199             digit => '[0-9]',
2200             alpha => '[A-Za-z]',
2201             upper => '[A-Z]',
2202             lower => '[a-z]',
2203             vowel => '[aeiouAEIOU]',
2204             consonant => '[b-df-hj-np-tv-zB-DF-HJ-NP-TV-Z]',
2205             xdigit => '[0-9A-Fa-f]',
2206             space => '\s',
2207             punct => '[[:punct:]]',
2208             );
2209              
2210             sub _build_run {
2211 4     4   7 my ( $spec, $where ) = @_;
2212              
2213 4         6 my $class = $spec->{class};
2214 4 100       126 croak "run munger$where requires a 'class'"
2215             unless defined $class;
2216 3 100       106 my $cc = $RUN_RE{$class}
2217             or croak "run munger$where: unknown class '$class' (known: " . join( ', ', sort keys %RUN_RE ) . ')';
2218 2         54 my $re = qr/((?:$cc)+)/;
2219              
2220             return sub {
2221 6     6   27 my ($v) = @_;
2222 6 100       16 my $s = defined $v ? "$v" : '';
2223 6         8 my $max = 0;
2224 6         37 while ( $s =~ /$re/g ) {
2225 6 100       25 $max = length $1 if length $1 > $max;
2226             }
2227 6         20 return $max;
2228 2         13 };
2229             } ## end sub _build_run
2230              
2231             =head2 count
2232              
2233             { munger => 'count', of => '/' } # url_path_depth, topic_depth
2234             { munger => 'count', of => '.', plus => 1 } # label_count (dots + 1)
2235              
2236             Count non-overlapping occurrences of a literal substring C in the input,
2237             optionally adding a constant C. This is the segment/depth feature behind
2238             C and C (count of C<`/`>) and C (dots
2239             plus one). C is matched literally, not as a pattern, so C<.> means a literal
2240             dot.
2241              
2242             =cut
2243              
2244             sub _build_count {
2245 4     4   8 my ( $spec, $where ) = @_;
2246              
2247 4         6 my $of = $spec->{of};
2248 4 100 66     106 croak "count munger$where requires a non-empty 'of' string"
2249             unless defined $of && length $of;
2250              
2251 3 100       7 my $plus = defined $spec->{plus} ? $spec->{plus} : 0;
2252 3 50       9 croak "count munger$where: 'plus' must be numeric"
2253             unless looks_like_number($plus);
2254              
2255             # index() beats a global regex match here: no pattern engine, and no
2256             # per-call list of matches just to count them. Advancing by length($of)
2257             # keeps the non-overlapping semantics m//g had.
2258 3         6 my $oflen = length $of;
2259             return sub {
2260 6     6   20 my ($v) = @_;
2261 6 50       15 my $s = defined $v ? "$v" : '';
2262 6         7 my $n = 0;
2263 6         9 my $p = 0;
2264 6         16 while ( ( $p = index( $s, $of, $p ) ) >= 0 ) {
2265 10         22 $n++;
2266 10         17 $p += $oflen;
2267             }
2268 6         22 return $n + $plus;
2269 3         16 }; ## end sub
2270             } ## end sub _build_count
2271              
2272             =head2 match
2273              
2274             { munger => 'match', pattern => '^xn--' } # punycode label
2275             { munger => 'match', pattern => '%[0-9A-Fa-f]{2}', mode => 'count' }
2276              
2277             Match the input against a Perl regular expression C: C<1>/C<0> under
2278             the default C<< mode => 'bool' >>, or the number of non-overlapping matches
2279             with C<< mode => 'count' >>. A true C makes the match
2280             case-insensitive. This is the catch-all shape test behind flags like "is this
2281             label punycode" or "is the Host an IP literal", and counters like
2282             percent-escapes in a URL -- anything L and L are not expressive
2283             enough for. The pattern is compiled at build time, so a broken one fails at
2284             C rather than per row.
2285              
2286             B a pattern cannot execute code (Perl requires C
2287             for that, which this module does not enable), but a pathological pattern can
2288             still backtrack catastrophically and stall a writer. Treat munger specs --
2289             like the rest of C -- as configuration from a trusted operator,
2290             not as untrusted input.
2291              
2292             =cut
2293              
2294             sub _build_match {
2295 6     6   13 my ( $spec, $where ) = @_;
2296              
2297 6         10 my $pat = $spec->{pattern};
2298 6 100 66     161 croak "match munger$where requires a non-empty 'pattern'"
2299             unless defined $pat && length $pat;
2300              
2301 5 100       12 my $mode = defined $spec->{mode} ? $spec->{mode} : 'bool';
2302 5 100 100     156 croak "match munger$where: 'mode' must be 'bool' or 'count'"
2303             unless $mode eq 'bool' || $mode eq 'count';
2304              
2305             # qr// on spec text cannot run code -- (?{...}) needs 'use re "eval"',
2306             # which is not enabled here -- but it can be syntactically invalid, so
2307             # compile eagerly and croak at build time.
2308 4 100       6 my $re = eval { $spec->{ignore_case} ? qr/$pat/i : qr/$pat/ };
  4         104  
2309 4 100       167 croak "match munger$where: cannot compile pattern '$pat': $@"
2310             unless defined $re;
2311              
2312 3 100       5 if ( $mode eq 'bool' ) {
2313             return sub {
2314 4 100   4   17 my $s = defined $_[0] ? "$_[0]" : '';
2315 4 100       26 return $s =~ $re ? 1 : 0;
2316 2         10 };
2317             }
2318             return sub {
2319 2 50   2   10 my $s = defined $_[0] ? "$_[0]" : '';
2320 2         13 my $n = () = $s =~ /$re/g;
2321 2         8 return $n;
2322 1         6 };
2323             } ## end sub _build_match
2324              
2325             =head2 bucket
2326              
2327             { munger => 'bucket', bounds => [ 1024, 49152 ] } # dest_port classes
2328              
2329             Map a number to a bucket index by ascending C: the result is how many
2330             bounds the value is greater than or equal to. With C<< bounds => [1024, 49152] >>
2331             a value under C<1024> is C<0> (well-known), C<1024>-C<49151> is C<1> (registered),
2332             and C<49152>+ is C<2> (ephemeral) -- the classic port classing, where the literal
2333             port number is meaningless to a threshold split but the I is a real
2334             signal. C must be strictly ascending; N bounds yield indices C<0>..C.
2335              
2336             This generalises the C<*_enum> status-class mungers, which are the special case
2337             of bucketing a reply code by its leading digit.
2338              
2339             =cut
2340              
2341             sub _build_bucket {
2342 3     3   8 my ( $spec, $where ) = @_;
2343              
2344 3         6 my $bounds = $spec->{bounds};
2345 3 100 66     190 croak "bucket munger$where requires a non-empty 'bounds' arrayref"
2346             unless ref $bounds eq 'ARRAY' && @$bounds;
2347              
2348 2         6 my @b = @$bounds;
2349 2         8 for my $i ( 0 .. $#b ) {
2350 4 0       16 croak "bucket munger$where: bound[$i] ('" . ( defined $b[$i] ? $b[$i] : 'undef' ) . "') is not numeric"
    50          
2351             unless looks_like_number( $b[$i] );
2352 4 100 100     154 croak "bucket munger$where: 'bounds' must be strictly ascending"
2353             if $i && $b[$i] <= $b[ $i - 1 ];
2354             }
2355              
2356             return sub {
2357 6     6   16 my ($v) = @_;
2358 6 0       21 croak "bucket munger$where: '" . ( defined $v ? $v : 'undef' ) . "' is not numeric"
    50          
2359             unless looks_like_number($v);
2360 6         10 my $idx = 0;
2361 6         11 for my $bound (@b) {
2362 10 100       24 last if $v < $bound;
2363 6         8 $idx++;
2364             }
2365 6         20 return $idx;
2366 1         7 }; ## end sub
2367             } ## end sub _build_bucket
2368              
2369             =head2 quantile
2370              
2371             { munger => 'quantile', bounds => [ 40, 180, 460, 2200, 64000 ] }
2372              
2373             Piecewise-linear ECDF: map a number onto C<[0, 1]> by where it falls among
2374             ascending C taken from the training data's quantiles (e.g. its
2375             min / p25 / p50 / p75 / max). Values at or below the first bound map to C<0>,
2376             at or above the last to C<1>, and anything between two adjacent bounds
2377             interpolates linearly between their positions. This is L's continuous
2378             sibling and the heavy-tail normaliser to reach for when L is not enough
2379             and L would let one outlier stretch the whole scale: after the
2380             transform the training distribution is roughly uniform, so a forest threshold
2381             split lands anywhere in it with equal ease. C must be strictly
2382             ascending with at least two values; like C, the parameters are
2383             supplied rather than learned, so munging stays stateless.
2384              
2385             =cut
2386              
2387             sub _build_quantile {
2388 3     3   10 my ( $spec, $where ) = @_;
2389              
2390 3         7 my $bounds = $spec->{bounds};
2391 3 100 66     156 croak "quantile munger$where requires a 'bounds' arrayref with at least 2 values"
2392             unless ref $bounds eq 'ARRAY' && @$bounds >= 2;
2393              
2394 2         7 my @b = @$bounds;
2395 2         8 for my $i ( 0 .. $#b ) {
2396 7 0       22 croak "quantile munger$where: bound[$i] ('" . ( defined $b[$i] ? $b[$i] : 'undef' ) . "') is not numeric"
    50          
2397             unless looks_like_number( $b[$i] );
2398 7 100 100     226 croak "quantile munger$where: 'bounds' must be strictly ascending"
2399             if $i && $b[$i] <= $b[ $i - 1 ];
2400             }
2401 1         3 my $segs = $#b;
2402              
2403             return sub {
2404 9     9   33 my ($v) = @_;
2405 9 50       172 croak "quantile munger$where: '" . ( defined $v ? $v : 'undef' ) . "' is not numeric"
    100          
2406             unless looks_like_number($v);
2407 8 100       31 return 0 if $v <= $b[0];
2408 6 100       23 return 1 if $v >= $b[-1];
2409 4         7 my $i = 0;
2410 4         20 $i++ while $v >= $b[ $i + 1 ];
2411 4         33 return ( $i + ( $v - $b[$i] ) / ( $b[ $i + 1 ] - $b[$i] ) ) / $segs;
2412 1         9 }; ## end sub
2413             } ## end sub _build_quantile
2414              
2415             =head2 scale
2416              
2417             { munger => 'scale', min => 0, max => 1000, clamp => 1 }
2418              
2419             Min-max normalisation: C<(v - min) / (max - min)>, mapping C<[min, max]> onto
2420             C<[0, 1]>. C and C must differ. With a true C, results are
2421             pinned into C<[0, 1]> so out-of-range inputs cannot escape the unit interval.
2422              
2423             =cut
2424              
2425             sub _build_scale {
2426 3     3   7 my ( $spec, $where ) = @_;
2427              
2428 3         4 my ( $min, $max ) = @{$spec}{qw(min max)};
  3         7  
2429 3 50 33     17 croak "scale munger$where requires numeric 'min' and 'max'"
2430             unless looks_like_number($min) && looks_like_number($max);
2431              
2432 3         5 my $range = $max - $min;
2433 3 100       100 croak "scale munger$where: 'min' and 'max' must differ"
2434             if $range == 0;
2435              
2436 2 100       4 my $clamp = $spec->{clamp} ? 1 : 0;
2437             return sub {
2438 4     4   13 my ($v) = @_;
2439 4 0       12 croak "scale munger$where: '" . ( defined $v ? $v : 'undef' ) . "' is not numeric"
    50          
2440             unless looks_like_number($v);
2441 4         23 my $s = ( $v - $min ) / $range;
2442 4 100       9 if ($clamp) { $s = 0 if $s < 0; $s = 1 if $s > 1; }
  2 100       7  
  2 100       5  
2443 4         12 return $s;
2444 2         12 };
2445             } ## end sub _build_scale
2446              
2447             =head2 zscore
2448              
2449             { munger => 'zscore', mean => 42.0, std => 7.5 }
2450              
2451             Standardise: C<(v - mean) / std>. C must be non-zero. The C/C
2452             are supplied (this module does not learn them) so munging stays stateless and a
2453             row can be munged in isolation.
2454              
2455             =cut
2456              
2457             sub _build_zscore {
2458 2     2   4 my ( $spec, $where ) = @_;
2459              
2460 2         3 my ( $mean, $std ) = @{$spec}{qw(mean std)};
  2         5  
2461 2 50 33     12 croak "zscore munger$where requires numeric 'mean' and 'std'"
2462             unless looks_like_number($mean) && looks_like_number($std);
2463 2 100       99 croak "zscore munger$where: 'std' must be non-zero"
2464             if $std == 0;
2465              
2466             return sub {
2467 2     2   7 my ($v) = @_;
2468 2 0       7 croak "zscore munger$where: '" . ( defined $v ? $v : 'undef' ) . "' is not numeric"
    50          
2469             unless looks_like_number($v);
2470 2         8 return ( $v - $mean ) / $std;
2471 1         6 };
2472             } ## end sub _build_zscore
2473              
2474             =head2 log
2475              
2476             { munger => 'log' } # natural log
2477             { munger => 'log', offset => 1 } # log1p-style, so 0 is allowed
2478             { munger => 'log', base => 10, offset => 1 }
2479              
2480             Logarithm of C. Heavy-tailed counts (bytes, durations) compress well
2481             under a log, which keeps a few huge values from dominating the forest. C
2482             (default C<0>) shifts the input so zeros/small values are representable; the
2483             shifted value must be strictly positive or the input croaks. C defaults to
2484             natural log.
2485              
2486             =cut
2487              
2488             sub _build_log {
2489 8     8   19 my ( $spec, $where ) = @_;
2490              
2491 8 100       39 my $offset = exists $spec->{offset} ? $spec->{offset} : 0;
2492 8 50       33 croak "log munger$where: 'offset' must be numeric"
2493             unless looks_like_number($offset);
2494              
2495 8         14 my $ln_base;
2496 8 100       20 if ( defined $spec->{base} ) {
2497             croak "log munger$where: 'base' must be numeric and > 0 and != 1"
2498             unless looks_like_number( $spec->{base} )
2499             && $spec->{base} > 0
2500 2 50 66     170 && $spec->{base} != 1;
      66        
2501 1         4 $ln_base = log( $spec->{base} );
2502             }
2503              
2504             return sub {
2505 9     9   39 my ($v) = @_;
2506 9 0       30 croak "log munger$where: '" . ( defined $v ? $v : 'undef' ) . "' is not numeric"
    50          
2507             unless looks_like_number($v);
2508 9         15 my $x = $v + $offset;
2509 9 100       101 croak "log munger$where: value+offset must be > 0 (got $x)"
2510             unless $x > 0;
2511 8         24 my $r = log($x);
2512 8 100       20 $r /= $ln_base if defined $ln_base;
2513 8         26 return $r;
2514 7         54 }; ## end sub
2515             } ## end sub _build_log
2516              
2517             =head2 clamp
2518              
2519             { munger => 'clamp', min => 0 }
2520             { munger => 'clamp', min => 0, max => 65535 }
2521              
2522             Pass the number through, pinned into C<[min, max]>. Either bound may be omitted
2523             to clamp on one side only. Unlike C this does not rescale; it only caps
2524             outliers before they reach the model.
2525              
2526             =cut
2527              
2528             sub _build_clamp {
2529 3     3   6 my ( $spec, $where ) = @_;
2530              
2531 3         5 my ( $min, $max ) = @{$spec}{qw(min max)};
  3         7  
2532 3         5 my $have_min = defined $min;
2533 3         5 my $have_max = defined $max;
2534 3 100 66     106 croak "clamp munger$where needs at least one of 'min' or 'max'"
2535             unless $have_min || $have_max;
2536 2 50 33     11 croak "clamp munger$where: 'min' must be numeric"
2537             if $have_min && !looks_like_number($min);
2538 2 50 66     8 croak "clamp munger$where: 'max' must be numeric"
2539             if $have_max && !looks_like_number($max);
2540 2 50 66     9 croak "clamp munger$where: 'min' must be <= 'max'"
      66        
2541             if $have_min && $have_max && $min > $max;
2542              
2543             return sub {
2544 5     5   15 my ($v) = @_;
2545 5 0       14 croak "clamp munger$where: '" . ( defined $v ? $v : 'undef' ) . "' is not numeric"
    50          
2546             unless looks_like_number($v);
2547 5 100 66     16 $v = $min if $have_min && $v < $min;
2548 5 100 100     12 $v = $max if $have_max && $v > $max;
2549 5         16 return $v;
2550 2         12 };
2551             } ## end sub _build_clamp
2552              
2553             =head2 num
2554              
2555             { munger => 'num', base => 16 } # '0x1a' or '1a' -> 26
2556             { munger => 'num' } # plain numeric coercion
2557              
2558             Parse a string as a number in C (2-36, default 10). Base 10 simply
2559             validates and numifies. Other bases accept the digits C<0-9a-z> below the
2560             base, case-insensitively, an optional leading C<->, and the conventional
2561             prefix for that base (C<0x> for 16, C<0b> for 2, C<0o> for 8). Plenty of
2562             tooling logs flag words and IDs in hex (C<0x2f>), which the Writer would
2563             reject as non-numeric; this munger is the bridge. Croaks on anything that is
2564             not a clean number in the chosen base.
2565              
2566             =cut
2567              
2568             sub _build_num {
2569 7     7   13 my ( $spec, $where ) = @_;
2570              
2571 7 100       24 my $base = defined $spec->{base} ? $spec->{base} : 10;
2572 7 100 66     243 croak "num munger$where: 'base' must be an integer from 2 to 36"
      100        
2573             unless $base =~ /\A[0-9]+\z/ && $base >= 2 && $base <= 36;
2574              
2575 5 100       14 if ( $base == 10 ) {
2576             return sub {
2577 3     3   9 my ($v) = @_;
2578 3 50       99 croak "num munger$where: '" . ( defined $v ? $v : 'undef' ) . "' is not numeric"
    100          
2579             unless looks_like_number($v);
2580 2         13 return $v + 0;
2581 1         6 };
2582             }
2583              
2584 4         7 my %digit;
2585 4         7 my $i = 0;
2586 4         119 $digit{$_} = $i++ for ( '0' .. '9', 'a' .. 'z' );
2587             # Strip only the base's own conventional prefix; for other bases a letter
2588             # like 'b' is just a digit, so there is nothing to disambiguate.
2589 4 50       19 my $prefix
    100          
    100          
2590             = $base == 16 ? qr/\A0x/
2591             : $base == 8 ? qr/\A0o/
2592             : $base == 2 ? qr/\A0b/
2593             : undef;
2594              
2595             return sub {
2596 11     11   504 my ($v) = @_;
2597 11 50       30 my $s = defined $v ? lc "$v" : '';
2598 11 50       38 my $err = "num munger$where: '" . ( defined $v ? $v : 'undef' ) . "' is not a base-$base number";
2599 11         24 my $neg = $s =~ s/\A-//;
2600 11 50       57 $s =~ s/$prefix// if defined $prefix;
2601 11 100       106 croak $err unless length $s;
2602 10         10 my $n = 0;
2603 10         28 for my $c ( split //, $s ) {
2604 25         29 my $d = $digit{$c};
2605 25 100 66     137 croak $err unless defined $d && $d < $base;
2606 24         32 $n = $n * $base + $d;
2607             }
2608 9 100       39 return $neg ? -$n : $n;
2609 4         39 }; ## end sub
2610             } ## end sub _build_num
2611              
2612             =head2 ratio
2613              
2614             # 'io_ratio' is a tag; bytes_out and bytes_in are input fields
2615             "io_ratio": { "munger": "ratio", "from": ["bytes_out", "bytes_in"] }
2616             { munger => 'ratio', from => [qw(bytes_out bytes_in)], zero => -1 }
2617              
2618             First source divided by the second: with C<< from => [a, b] >> the column gets
2619             C. Asymmetry between two counters is a classic feature the counters
2620             alone cannot express -- bytes out over bytes in flags exfiltration, requests
2621             over responses flags scanning -- and the division has to happen at munge time
2622             because a forest split only ever sees one column. A zero denominator yields
2623             C (default C<0>) instead of dying, since "nothing came back" is a
2624             legitimate row, not bad input; pick a C outside the ratio's normal range
2625             if you want those rows to stand out. Both inputs must be numeric.
2626              
2627             This is a B munger: it only makes sense with several sources, so
2628             it is only usable through L with C as an arrayref of exactly
2629             two field names (and thus C / C). The sources are
2630             raw input fields, not other columns.
2631              
2632             =head2 combine
2633              
2634             { munger => 'combine', op => 'sum', from => [qw(bytes_in bytes_out)] }
2635             { munger => 'combine', op => 'max', from => [qw(req_time resp_time)] }
2636              
2637             Fold two or more numeric source fields into one column with C: C,
2638             C (first minus second; exactly two sources), C, C, C,
2639             or C. The general-purpose sibling of L for when the interesting
2640             feature is a total, a gap, or an extreme across fields rather than any one
2641             field. Every input must be numeric.
2642              
2643             Like C, this is a B munger: only usable through
2644             L with C as an arrayref of source field names.
2645              
2646             =cut
2647              
2648             sub _build_ratio {
2649 3     3   8 my ( $spec, $where, $nsrc ) = @_;
2650              
2651 3 100       210 croak "ratio munger$where takes exactly 2 source fields (numerator, denominator), not $nsrc"
2652             unless $nsrc == 2;
2653              
2654 2 100       7 my $zero = defined $spec->{zero} ? $spec->{zero} : 0;
2655 2 50       7 croak "ratio munger$where: 'zero' must be numeric"
2656             unless looks_like_number($zero);
2657              
2658             return sub {
2659 5     5   9 for my $v (@_) {
2660 10 50       172 croak "ratio munger$where: '" . ( defined $v ? $v : 'undef' ) . "' is not numeric"
    100          
2661             unless looks_like_number($v);
2662             }
2663 4 100       13 return $zero if $_[1] == 0;
2664 2         10 return $_[0] / $_[1];
2665 2         11 };
2666             } ## end sub _build_ratio
2667              
2668             # op => fold over the already numeric-checked source values. A table so the
2669             # error message can enumerate them and a new op is one line.
2670             my %COMBINE_OPS = (
2671             sum => sub { my $t = 0; $t += $_ for @_; return $t },
2672             diff => sub { return $_[0] - $_[1] },
2673             product => sub { my $t = 1; $t *= $_ for @_; return $t },
2674             min => sub {
2675             my $t = shift;
2676             for (@_) { $t = $_ if $_ < $t }
2677             return $t;
2678             },
2679             max => sub {
2680             my $t = shift;
2681             for (@_) { $t = $_ if $_ > $t }
2682             return $t;
2683             },
2684             mean => sub { my $t = 0; $t += $_ for @_; return $t / @_ },
2685             );
2686              
2687             sub _build_combine_op {
2688 10     10   20 my ( $spec, $where, $nsrc ) = @_;
2689              
2690 10         15 my $op = $spec->{op};
2691 10 100 66     200 croak "combine munger$where requires an 'op' (one of: " . join( ', ', sort keys %COMBINE_OPS ) . ')'
2692             unless defined $op && length $op;
2693 9 100       215 my $fold = $COMBINE_OPS{$op}
2694             or croak "combine munger$where: unknown op '$op' (known: " . join( ', ', sort keys %COMBINE_OPS ) . ')';
2695 8 100 100     188 croak "combine munger$where: op 'diff' takes exactly 2 source fields, not $nsrc"
2696             if $op eq 'diff' && $nsrc != 2;
2697              
2698             return sub {
2699 8     8   9 for my $v (@_) {
2700 18 0       28 croak "combine munger$where: '" . ( defined $v ? $v : 'undef' ) . "' is not numeric"
    50          
2701             unless looks_like_number($v);
2702             }
2703 8         15 return $fold->(@_);
2704 7         60 };
2705             } ## end sub _build_combine_op
2706              
2707             =head2 bit
2708              
2709             { munger => 'bit', mask => '0x12' } # SYN or ACK set?
2710             { munger => 'bit', mask => '0x02', mode => 'all' } # the SYN bit itself
2711             { munger => 'bit', mode => 'popcount' } # how many flags at all
2712             { munger => 'bit', mask => '0x0f', mode => 'value' } # low nibble, 0-15
2713             { munger => 'bit', mask => '0x02', base => 16 } # Suricata tcp_flags "1b"
2714              
2715             Bit-level features from an integer flags word (TCP flags, DNS header flags,
2716             protocol option words): the raw word is meaningless to a threshold split, but
2717             individual bits and bit I are real signals. The input must be a
2718             non-negative integer, in decimal or C<0x> hex (so a logged C<0x12> works
2719             as-is); C may be written either way too.
2720              
2721             Set C<< base => 16 >> to read the B as bare hexadecimal with no C<0x>
2722             prefix -- Suricata logs C (and C/C)
2723             as e.g. C<"1b">, which is otherwise ambiguous with decimal. A C<0x> prefix on
2724             the input is still accepted under C<< base => 16 >>. C is always written
2725             in decimal or C<0x> hex regardless of C. Modes:
2726              
2727             =over 4
2728              
2729             =item * C (default) - C<1> if any bit of C is set in the value.
2730              
2731             =item * C - C<1> only if every bit of C is set.
2732              
2733             =item * C - the masked bits, shifted down to the mask's lowest set
2734             bit: C<< mask => '0x0f' >> extracts the low nibble as C<0>-C<15>.
2735              
2736             =item * C - the number of set bits in C; C is
2737             optional here and defaults to all bits. An abnormal flag I (a
2738             Christmas-tree packet) is anomalous even when each individual bit is common.
2739              
2740             =back
2741              
2742             C is required (and must be non-zero) for every mode except C.
2743              
2744             =cut
2745              
2746             my %BIT_MODE = map { $_ => 1 } qw(any all value popcount);
2747              
2748             # Accept an integer in decimal or 0x-hex form; returns the number, or undef
2749             # if it is neither. Shared by bit's mask (spec) and value (input) parsing.
2750             sub _bit_int {
2751 23     23   54 my ($v) = @_;
2752 23 50       43 return undef unless defined $v;
2753 23 100       75 return hex($v) if $v =~ /\A0x[0-9a-f]+\z/i;
2754 13 100       86 return $v + 0 if $v =~ /\A[0-9]+\z/;
2755 3         7 return undef;
2756             }
2757              
2758             # Parse an input value as bare hex (a '0x' prefix is tolerated), for bit's
2759             # 'base => 16' mode. Suricata logs tcp_flags as "1b" with no prefix, which
2760             # _bit_int would read as decimal (or reject), hence a separate parser opted
2761             # into per munger rather than a change to the ambiguous default.
2762             sub _bit_hex {
2763 5     5   14 my ($v) = @_;
2764 5 50       17 return undef unless defined $v;
2765 5 100       47 return hex($1) if $v =~ /\A(?:0x)?([0-9a-f]+)\z/i;
2766 1         3 return undef;
2767             }
2768              
2769             sub _build_bit {
2770 13     13   30 my ( $spec, $where ) = @_;
2771              
2772 13 100       36 my $mode = defined $spec->{mode} ? $spec->{mode} : 'any';
2773             croak "bit munger$where: unknown mode '$mode' (known: " . join( ', ', sort keys %BIT_MODE ) . ')'
2774 13 100       187 unless $BIT_MODE{$mode};
2775              
2776             # Input base: 10 (default, decimal or 0x hex) or 16 (bare hex, for feeds
2777             # like Suricata's tcp_flags). Only the per-row input parser changes; the
2778             # mask below is always read with _bit_int.
2779 12 100       29 my $base = defined $spec->{base} ? $spec->{base} : 10;
2780 12 100 100     217 croak "bit munger$where: 'base' must be 10 or 16"
2781             unless $base eq '10' || $base eq '16';
2782 11 100       31 my $parse_in = $base eq '16' ? \&_bit_hex : \&_bit_int;
2783 11 100       26 my $in_form = $base eq '16' ? 'hex' : 'decimal or 0x hex';
2784              
2785 11         14 my $mask;
2786 11 100       42 if ( defined $spec->{mask} ) {
    100          
2787 8         18 $mask = _bit_int( $spec->{mask} );
2788 8 100       166 croak "bit munger$where: 'mask' must be a non-negative integer " . '(decimal or 0x hex)'
2789             unless defined $mask;
2790 7 100 66     161 croak "bit munger$where: 'mask' must be non-zero"
2791             if $mask == 0 && $mode ne 'popcount';
2792             } elsif ( $mode ne 'popcount' ) {
2793 1         150 croak "bit munger$where: mode '$mode' requires a 'mask'";
2794             }
2795              
2796             # For 'value', bake in the shift down to the mask's lowest set bit.
2797 8         10 my $shift = 0;
2798 8 100       16 if ( $mode eq 'value' ) {
2799 1         2 my $m = $mask;
2800 1         3 until ( $m & 1 ) { $m >>= 1; $shift++; }
  4         3  
  4         8  
2801             }
2802              
2803             return sub {
2804 20     20   907 my ($v) = @_;
2805 20 50       68 my $n = $parse_in->( defined $v ? "$v" : undef );
2806 20 50       458 croak "bit munger$where: '" . ( defined $v ? $v : 'undef' ) . "' is not a non-negative integer ($in_form)"
    100          
2807             unless defined $n;
2808 17 100       36 $n &= $mask if defined $mask;
2809 17 100       57 return sprintf( '%b', $n ) =~ tr/1// if $mode eq 'popcount';
2810 12 100       41 return $n ? 1 : 0 if $mode eq 'any';
    100          
2811 6 100       21 return $n == $mask ? 1 : 0 if $mode eq 'all';
    100          
2812 2         8 return $n >> $shift; # value
2813 8         53 }; ## end sub
2814             } ## end sub _build_bit
2815              
2816             =head2 ip_class
2817              
2818             { munger => 'ip_class' }
2819             { munger => 'ip_class', default => -1 }
2820              
2821             Collapse an IPv4 or IPv6 address to its address-space class -- to addresses
2822             what the status-class enums are to reply codes: the literal address is
2823             high-cardinality noise, but "an internal host suddenly talking multicast" is
2824             a class-level signal. Classes and their emitted numbers:
2825              
2826             0 global anything not covered below
2827             1 private 10/8, 172.16/12, 192.168/16, 100.64/10 (CGNAT), fc00::/7 (ULA)
2828             2 loopback 127/8, ::1
2829             3 link_local 169.254/16, fe80::/10
2830             4 multicast 224/4, ff00::/8
2831             5 broadcast 255.255.255.255
2832             6 unspecified 0.0.0.0, ::
2833             7 reserved 0/8, 192.0.0/24, the documentation nets (192.0.2/24,
2834             198.51.100/24, 203.0.113/24, 2001:db8::/32), benchmarking
2835             (198.18/15), 240/4, and the 100::/64 discard prefix
2836              
2837             An IPv4-mapped IPv6 address (C<::ffff:a.b.c.d>) is classified as its embedded
2838             IPv4 address. An unparseable input croaks, or yields the numeric C
2839             when one is given. IPv6 parsing uses L's C, loaded lazily
2840             the way L loads Time::Piece. For B zones (DMZ,
2841             server VLAN, guest Wi-Fi) use L, which knows your networks instead of
2842             the RFCs'.
2843              
2844             =head2 cidr
2845              
2846             { munger => 'cidr',
2847             nets => [ '10.10.0.0/16', '10.20.0.0/16', '2001:db8:5::/48' ],
2848             default => -1 }
2849              
2850             Membership in a list of CIDR networks: the result is the (0-based) index of
2851             the B net in C containing the address -- L for address
2852             space, and the way a site encodes its own zones (DMZ vs. server VLAN vs.
2853             guest Wi-Fi) that L's generic RFC classes cannot know about.
2854             C may mix IPv4 and IPv6; an address is only tested against nets of its
2855             own family. Overlapping nets are fine -- list the most specific first, since
2856             the first match wins. An input that is unparseable or in none of the listed
2857             nets croaks, or yields the numeric C when one is given (a catch-all
2858             C is the usual configuration).
2859              
2860             =cut
2861              
2862             # Parse an IP address string: (4, $int) for IPv4, (6, $bytes16) for IPv6, or
2863             # an empty list for neither. v4 goes through a regex (also pinning the
2864             # dotted-quad form, so inet_pton's odd shorthands never sneak in); v6 leans
2865             # on Socket's inet_pton, loaded lazily so no munger that skips IPs pays for
2866             # it.
2867             sub _parse_ip {
2868 51     51   125 my ($s) = @_;
2869 51 100       343 if ( $s =~ /\A([0-9]{1,3})\.([0-9]{1,3})\.([0-9]{1,3})\.([0-9]{1,3})\z/ ) {
2870 31 100 33     425 return unless $1 <= 255 && $2 <= 255 && $3 <= 255 && $4 <= 255;
      33        
      66        
2871 30         186 return ( 4, ( $1 << 24 ) | ( $2 << 16 ) | ( $3 << 8 ) | $4 );
2872             }
2873 20 100       69 if ( index( $s, ':' ) >= 0 ) {
2874 14         812 require Socket;
2875 14         3321 my $b = eval { Socket::inet_pton( Socket::AF_INET6(), $s ) };
  14         79  
2876 14 50 33     126 return ( 6, $b ) if defined $b && length $b == 16;
2877             }
2878 6         19 return;
2879             } ## end sub _parse_ip
2880              
2881             # The ip_class class names, pinned to their emitted numbers.
2882             my %IP_CLASS = (
2883             global => 0,
2884             private => 1,
2885             loopback => 2,
2886             link_local => 3,
2887             multicast => 4,
2888             broadcast => 5,
2889             unspecified => 6,
2890             reserved => 7,
2891             );
2892              
2893             sub _ip4_class {
2894 21     21   51 my ($n) = @_;
2895 21 100       67 return 'unspecified' if $n == 0;
2896 20 100       77 return 'broadcast' if $n == 0xffffffff;
2897 19         38 my $a = $n >> 24;
2898 19         72 my $b = ( $n >> 16 ) & 0xff;
2899 19         35 my $c = ( $n >> 8 ) & 0xff;
2900 19 100       53 return 'reserved' if $a == 0; # 0/8 "this network"
2901 18 100       56 return 'private' if $a == 10;
2902 16 100 66     56 return 'private' if $a == 100 && $b >= 64 && $b <= 127; # CGNAT 100.64/10
      100        
2903 15 100       41 return 'loopback' if $a == 127;
2904 14 100 66     48 return 'link_local' if $a == 169 && $b == 254;
2905 13 100 66     47 return 'private' if $a == 172 && $b >= 16 && $b <= 31;
      100        
2906 12 50 100     51 return 'reserved' if $a == 192 && $b == 0 && ( $c == 0 || $c == 2 );
      33        
      66        
2907 11 100 66     42 return 'private' if $a == 192 && $b == 168;
2908 10 100 66     40 return 'reserved' if $a == 198 && ( $b == 18 || $b == 19 ); # benchmarking
      66        
2909 9 50 66     35 return 'reserved' if $a == 198 && $b == 51 && $c == 100; # TEST-NET-2
      66        
2910 8 50 66     63 return 'reserved' if $a == 203 && $b == 0 && $c == 113; # TEST-NET-3
      66        
2911 7 100 100     39 return 'multicast' if $a >= 224 && $a <= 239;
2912 5 100       20 return 'reserved' if $a >= 240; # 240/4 future use
2913 4         35 return 'global';
2914             } ## end sub _ip4_class
2915              
2916             sub _ip6_class {
2917 10     10   23 my ($bytes) = @_;
2918 10         49 my @o = unpack 'C16', $bytes;
2919 10         19 my $lead0 = 1;
2920 10   100     31 for my $i ( 0 .. 14 ) { $lead0 &&= $o[$i] == 0 }
  150         400  
2921 10 100       25 if ($lead0) {
2922 2 100       15 return 'unspecified' if $o[15] == 0;
2923 1 50       11 return 'loopback' if $o[15] == 1;
2924             }
2925             # v4-mapped ::ffff:a.b.c.d -- classify as the embedded v4 address.
2926 8         17 my $map = 1;
2927 8   100     16 for my $i ( 0 .. 9 ) { $map &&= $o[$i] == 0 }
  80         193  
2928 8 50 66     41 return _ip4_class( ( $o[12] << 24 ) | ( $o[13] << 16 ) | ( $o[14] << 8 ) | $o[15] )
      66        
2929             if $map && $o[10] == 0xff && $o[11] == 0xff;
2930 6 100       24 return 'multicast' if $o[0] == 0xff;
2931 5 100       20 return 'private' if ( $o[0] & 0xfe ) == 0xfc; # ULA fc00::/7
2932 4 100 66     24 return 'link_local' if $o[0] == 0xfe && ( $o[1] & 0xc0 ) == 0x80; # fe80::/10
2933 3 50 66     27 return 'reserved' if $o[0] == 0x20 && $o[1] == 0x01 && $o[2] == 0x0d && $o[3] == 0xb8; # 2001:db8::/32
      66        
      33        
2934 2         3 my $discard = $o[0] == 0x01; # 100::/64
2935 2   66     5 for my $i ( 1 .. 7 ) { $discard &&= $o[$i] == 0 }
  14         34  
2936 2 100       12 return 'reserved' if $discard;
2937 1         7 return 'global';
2938             } ## end sub _ip6_class
2939              
2940             sub _build_ip_class {
2941 3     3   10 my ( $spec, $where ) = @_;
2942              
2943 3         9 my $has_default = exists $spec->{default};
2944 3         12 my $default = $spec->{default};
2945 3 100 100     170 croak "ip_class munger$where: 'default' must be numeric"
2946             if $has_default && !looks_like_number($default);
2947              
2948             return sub {
2949 33     33   990 my ($v) = @_;
2950 33 100       183 my ( $fam, $p ) = _parse_ip( defined $v ? "$v" : '' );
2951 33 100       115 if ($fam) {
2952 29 100       106 return $IP_CLASS{ $fam == 4 ? _ip4_class($p) : _ip6_class($p) };
2953             }
2954 4 100       20 return $default if $has_default;
2955 2 50       327 croak "ip_class munger$where: '" . ( defined $v ? $v : 'undef' ) . "' is not a parseable IP address";
2956 2         20 };
2957             } ## end sub _build_ip_class
2958              
2959             # Build a 16-byte netmask string for an IPv6 prefix length.
2960             sub _v6_mask {
2961 2     2   7 my ($len) = @_;
2962 2         11 my $mask = "\xff" x int( $len / 8 );
2963 2 50       7 $mask .= chr( ( 0xff << ( 8 - $len % 8 ) ) & 0xff ) if $len % 8;
2964 2         9 return $mask . ( "\0" x ( 16 - length $mask ) );
2965             }
2966              
2967             sub _build_cidr {
2968 8     8   25 my ( $spec, $where ) = @_;
2969              
2970 8         19 my $nets = $spec->{nets};
2971 8 100 66     189 croak "cidr munger$where requires a non-empty 'nets' arrayref"
2972             unless ref $nets eq 'ARRAY' && @$nets;
2973              
2974             # [family, masked network, mask] per net; & on the 16-byte v6 strings is
2975             # Perl's bitwise string AND, so both families match the same way.
2976 7         13 my @match;
2977 7         27 for my $i ( 0 .. $#$nets ) {
2978 9         18 my $net = $nets->[$i];
2979 9 50 66     242 croak "cidr munger$where: nets[$i] ('"
    100          
2980             . ( defined $net ? $net : 'undef' )
2981             . "') is not in 'address/prefix' form"
2982             unless defined $net && $net =~ m{\A(.+)/([0-9]{1,3})\z};
2983 8         36 my ( $addr, $len ) = ( $1, $2 );
2984 8         22 my ( $fam, $p ) = _parse_ip($addr);
2985 8 100       198 croak "cidr munger$where: nets[$i] ('$net') has an unparseable address"
2986             unless $fam;
2987 7 100       22 my $max = $fam == 4 ? 32 : 128;
2988 7 100       167 croak "cidr munger$where: nets[$i] ('$net') prefix length must be 0-$max"
2989             if $len > $max;
2990 6 100       24 my $mask
    100          
2991             = $fam == 4
2992             ? ( $len == 0 ? 0 : ( 0xffffffff << ( 32 - $len ) ) & 0xffffffff )
2993             : _v6_mask($len);
2994 6         31 push @match, [ $fam, $p & $mask, $mask ];
2995             } ## end for my $i ( 0 .. $#$nets )
2996              
2997 4         12 my $has_default = exists $spec->{default};
2998 4         9 my $default = $spec->{default};
2999 4 50 66     29 croak "cidr munger$where: 'default' must be numeric"
3000             if $has_default && !looks_like_number($default);
3001              
3002             return sub {
3003 10     10   664 my ($v) = @_;
3004 10 50       66 my ( $fam, $p ) = _parse_ip( defined $v ? "$v" : '' );
3005 10 100       27 if ($fam) {
3006 8         27 for my $i ( 0 .. $#match ) {
3007 15         28 my ( $f, $network, $mask ) = @{ $match[$i] };
  15         37  
3008 15 100       42 next unless $f == $fam;
3009 9 100       52 return $i
    100          
3010             if $fam == 4
3011             ? ( ( $p & $mask ) == $network )
3012             : ( ( $p & $mask ) eq $network );
3013             }
3014 4 100       25 return $default if $has_default;
3015 1         134 croak "cidr munger$where: '$v' is in none of the listed networks (and no 'default')";
3016             } ## end if ($fam)
3017 2 100       12 return $default if $has_default;
3018 1 50       174 croak "cidr munger$where: '" . ( defined $v ? $v : 'undef' ) . "' is not a parseable IP address";
3019 4         41 }; ## end sub
3020             } ## end sub _build_cidr
3021              
3022             =head2 datetime
3023              
3024             { munger => 'datetime', format => '%Y-%m-%dT%H:%M:%S', part => 'epoch' }
3025             { munger => 'datetime', format => '%Y-%m-%d %H:%M:%S', part => 'hour' }
3026              
3027             Parse a formatted timestamp with L (C, so C is a
3028             standard strptime pattern) and extract one numeric C:
3029              
3030             =over 4
3031              
3032             =item * C (default) - seconds since the epoch.
3033              
3034             =item * C, C (1-12), C (1-31), C, C, C.
3035              
3036             =item * C - day of week, C<0>=Sunday .. C<6>=Saturday.
3037              
3038             =item * C - day of year, C<0>-based.
3039              
3040             =item * C - time of day as a fraction in C<[0, 1)>, i.e.
3041             C<(hour*3600 + min*60 + sec) / 86400>. Handy as a cyclic-ish time-of-day feature.
3042              
3043             =item * C - position within the week as a fraction in C<[0, 1)>, the
3044             week starting Sunday to match C: C<(wday*86400 + hour*3600 + min*60 + sec)
3045             / 604800>. Like C but cycling over a week, so a weekly rhythm (weekend
3046             vs. weekday, or a Monday-morning batch) shows up as a feature.
3047              
3048             =item * C / C, C / C - the C value
3049             mapped onto a circle, C and C. Prefer these over
3050             the raw C when feeding the forest: a plain fraction has a false seam at
3051             the wrap (23:59 and 00:00 sit at opposite ends, 1 vs 0, though they are a minute
3052             apart), whereas the sin/cos pair is continuous across midnight/Sunday. Store
3053             I of a pair in two columns so the position is unambiguous.
3054              
3055             =back
3056              
3057             Time features often carry the anomaly (a job that normally runs at 03:00
3058             suddenly firing at noon, or a weekday task firing on a Sunday), which is why this
3059             is a first-class munger.
3060              
3061             B A cyclic pair belongs together -- C alone collides
3062             (C is symmetric about its peak, so two different times map to one value) and
3063             the forest then treats distinct times as identical. To emit a pair atomically,
3064             give C (plural) and route them to two columns with C (see
3065             L):
3066              
3067             "time_of_week": {
3068             "munger": "datetime", "from": "timestamp",
3069             "format": "%Y-%m-%dT%H:%M:%S",
3070             "parts": [ "sin_week", "cos_week" ],
3071             "into": [ "time_sin", "time_cos" ]
3072             }
3073              
3074             The timestamp is parsed once and both columns are filled together, so they can
3075             never drift apart or be half-configured. C and C must be the same
3076             length. (Using C without C, or C with C, is an error.)
3077              
3078             B Two transparent accelerations, both value-identical to the plain
3079             path: a one-slot memo returns the previous result when the same stamp string
3080             repeats (the common case in bursty event streams); and when the format is built
3081             from only the six numeric codes C<%Y %m %d %H %M %S> (once each, e.g.
3082             C<%Y-%m-%dT%H:%M:%S>), parsing skips C for a compiled regex plus
3083             integer date math, falling back to C for any value the regex does not
3084             match B (a month C<13>, an hour C<24>, a
3085             C) -- so an invalid stamp croaks or normalizes exactly as C
3086             would, never silently feeding nonsense to the date math. Like C
3087             without a zone code, stamps are treated as UTC.
3088              
3089             =cut
3090              
3091             # Fraction (in [0,1)) of the way through the day / week, shared by the frac_*
3092             # parts and their sin/cos cyclic encodings.
3093             sub _frac_day {
3094 1     1   4 my $t = shift;
3095 1         4 return ( $t->hour * 3600 + $t->min * 60 + $t->sec ) / 86400;
3096             }
3097              
3098             sub _frac_week {
3099 2     2   3 my $t = shift;
3100 2         5 return ( $t->day_of_week * 86400 + $t->hour * 3600 + $t->min * 60 + $t->sec ) / 604800;
3101             }
3102              
3103             my $TWO_PI = 2 * atan2( 0, -1 ); # atan2(0,-1) == pi, core-only, no POSIX
3104              
3105             # part name => how to pull it off a Time::Piece object.
3106             my %DATETIME_PART = (
3107             epoch => sub { $_[0]->epoch },
3108             year => sub { $_[0]->year },
3109             mon => sub { $_[0]->mon },
3110             mday => sub { $_[0]->mday },
3111             hour => sub { $_[0]->hour },
3112             min => sub { $_[0]->min },
3113             sec => sub { $_[0]->sec },
3114             wday => sub { $_[0]->day_of_week },
3115             yday => sub { $_[0]->yday },
3116             frac_day => \&_frac_day,
3117             frac_week => \&_frac_week,
3118             sin_day => sub { sin( $TWO_PI * _frac_day( $_[0] ) ) },
3119             cos_day => sub { cos( $TWO_PI * _frac_day( $_[0] ) ) },
3120             sin_week => sub { sin( $TWO_PI * _frac_week( $_[0] ) ) },
3121             cos_week => sub { cos( $TWO_PI * _frac_week( $_[0] ) ) },
3122             );
3123              
3124             # ---- fast fixed-format engine ----------------------------------------------
3125             #
3126             # Time::Piece->strptime costs microseconds per call. When the format is built
3127             # from only the six all-numeric codes below (once each, e.g. the ubiquitous
3128             # '%Y-%m-%dT%H:%M:%S'), we can compile it to a capture regex and derive every
3129             # part with integer math instead -- several times faster, and bit-identical:
3130             # both paths treat the stamp as UTC (strptime with no zone does the same).
3131             # Anything fancier (%b, %z, %j, ...) stays on strptime.
3132              
3133             # strptime code => [ field name, capture pattern ].
3134             my %FAST_CODE = (
3135             Y => [ 'year', '[0-9]{4}' ],
3136             m => [ 'mon', '[0-9]{2}' ],
3137             d => [ 'mday', '[0-9]{2}' ],
3138             H => [ 'hour', '[0-9]{2}' ],
3139             M => [ 'min', '[0-9]{2}' ],
3140             S => [ 'sec', '[0-9]{2}' ],
3141             );
3142              
3143             # Compile a strptime format into { re, idx } for the arithmetic fast path --
3144             # idx maps field name (year/mon/...) to its capture position -- or return undef
3145             # when the format is not fast-eligible. All six codes must appear exactly once
3146             # so every part can be derived.
3147             sub _compile_fast_format {
3148 104     104   148414 my ($format) = @_;
3149 104         169 my $re = '';
3150 104         199 my %idx = ();
3151 104         169 my $n = 0;
3152 104         184 my $rest = $format;
3153 104         252 while ( length $rest ) {
3154 624 100       2038 if ( $rest =~ s/\A%(.)//s ) {
    50          
3155 369 100       1110 my $f = $FAST_CODE{$1} or return undef;
3156 314 50       631 return undef if exists $idx{ $f->[0] };
3157 314         581 $idx{ $f->[0] } = $n++;
3158 314         683 $re .= '(' . $f->[1] . ')';
3159             } elsif ( $rest =~ s/\A([^%]+)//s ) {
3160 255         590 $re .= quotemeta($1);
3161             } else {
3162 0         0 return undef; # lone trailing '%' -- not fast-eligible
3163             }
3164             } ## end while ( length $rest )
3165 49 100       167 return undef unless keys %idx == 6;
3166 36         476 return { re => qr/\A$re\z/, idx => \%idx };
3167             } ## end sub _compile_fast_format
3168              
3169             # A regex match only proves each fast-path field is digits of the right width,
3170             # not that the six of them form a real timestamp: '2026-13-01T25:00:00' matches
3171             # the shape. Fields out of range (month 13, hour 24, Feb 30) must not reach the
3172             # blind integer date math -- they are routed to strptime instead, which stays
3173             # the judge of whether such a stamp croaks or normalizes (Time::Piece rolls
3174             # Feb 30 over into March), keeping the two paths value-identical. Seconds stop
3175             # at 59: a :60 leap second is not representable in epoch math, so strptime
3176             # arbitrates it too.
3177             my @DAYS_IN_MONTH = ( 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31 );
3178              
3179             sub _fast_fields_in_range {
3180 156     156   236 my ( $c, $idx ) = @_;
3181 156         201 my ( $y, $m, $d, $H, $M, $S ) = @{$c}[ @{$idx}{qw(year mon mday hour min sec)} ];
  156         338  
  156         283  
3182 156 100 100     498 return 0 if $m < 1 || $m > 12;
3183 145         227 my $dim = $DAYS_IN_MONTH[ $m - 1 ];
3184 145 100 100     411 $dim = 29 if $m == 2 && ( ( !( $y % 4 ) && $y % 100 ) || !( $y % 400 ) );
      100        
3185 145 100 100     381 return 0 if $d < 1 || $d > $dim;
3186 125 100 100     438 return 0 if $H > 23 || $M > 59 || $S > 59;
      66        
3187 115         364 return 1;
3188             } ## end sub _fast_fields_in_range
3189              
3190             # Days since 1970-01-01 for a proleptic-Gregorian date (Howard Hinnant's
3191             # days-from-civil). Pure integer math; Perl's % already yields a non-negative
3192             # result for the wday derivation even on pre-1970 dates.
3193             sub _days_from_civil {
3194 62     62   118 my ( $y, $m, $d ) = @_;
3195 62         91 $y -= $m <= 2;
3196 62 50       152 my $era = int( ( $y >= 0 ? $y : $y - 399 ) / 400 );
3197 62         82 my $yoe = $y - $era * 400;
3198 62 100       133 my $doy = int( ( 153 * ( $m + ( $m > 2 ? -3 : 9 ) ) + 2 ) / 5 ) + $d - 1;
3199 62         116 my $doe = $yoe * 365 + int( $yoe / 4 ) - int( $yoe / 100 ) + $doy;
3200 62         216 return $era * 146097 + $doe - 719468;
3201             }
3202              
3203             # part name => factory(\%idx) => getter(\@captures). Mirrors %DATETIME_PART;
3204             # t/mungers-datetime-fast.t asserts the two stay value-identical. The factories
3205             # bake the capture positions in at build time so a per-row getter indexes the
3206             # raw capture array directly -- no intermediate hash per row, which is where
3207             # the fast path's time would otherwise go. Slot 6 of the capture array caches
3208             # days-from-civil so a multi-part (sin/cos) extraction computes it once.
3209             my %DATETIME_PART_FAST;
3210             {
3211             my $days_of = sub {
3212             my ( $iy, $im, $id ) = @{ $_[0] }{qw(year mon mday)};
3213             return sub {
3214             my $c = shift;
3215             return defined $c->[6]
3216             ? $c->[6]
3217             : ( $c->[6] = _days_from_civil( $c->[$iy], $c->[$im], $c->[$id] ) );
3218             };
3219             };
3220             my $sod_of = sub {
3221             my ( $ih, $in, $is ) = @{ $_[0] }{qw(hour min sec)};
3222             return sub { $_[0][$ih] * 3600 + $_[0][$in] * 60 + $_[0][$is] };
3223             };
3224             my $frac_day_of = sub {
3225             my $sod = $sod_of->( $_[0] );
3226             return sub { $sod->( $_[0] ) / 86400 };
3227             };
3228             my $frac_week_of = sub {
3229             my ( $days, $sod ) = ( $days_of->( $_[0] ), $sod_of->( $_[0] ) );
3230             return sub {
3231             my $c = shift;
3232             return ( ( ( $days->($c) + 4 ) % 7 ) * 86400 + $sod->($c) ) / 604800;
3233             };
3234             };
3235             my $field_of = sub {
3236             my ($name) = @_;
3237             return sub {
3238             my $i = $_[0]{$name};
3239             return sub { $_[0][$i] + 0 }
3240             };
3241             };
3242              
3243             %DATETIME_PART_FAST = (
3244             year => $field_of->('year'),
3245             mon => $field_of->('mon'),
3246             mday => $field_of->('mday'),
3247             hour => $field_of->('hour'),
3248             min => $field_of->('min'),
3249             sec => $field_of->('sec'),
3250             epoch => sub {
3251             my ( $days, $sod ) = ( $days_of->( $_[0] ), $sod_of->( $_[0] ) );
3252             return sub { $days->( $_[0] ) * 86400 + $sod->( $_[0] ) };
3253             },
3254             wday => sub { # epoch day 0 = Thursday = 4
3255             my $days = $days_of->( $_[0] );
3256             return sub { ( $days->( $_[0] ) + 4 ) % 7 };
3257             },
3258             yday => sub {
3259             my ($idx) = @_;
3260             my $days = $days_of->($idx);
3261             my $iy = $idx->{year};
3262             return sub {
3263             my $c = shift;
3264             return $days->($c) - _days_from_civil( $c->[$iy], 1, 1 );
3265             };
3266             },
3267             frac_day => $frac_day_of,
3268             frac_week => $frac_week_of,
3269             sin_day => sub {
3270             my $f = $frac_day_of->( $_[0] );
3271             return sub { sin( $TWO_PI * $f->( $_[0] ) ) };
3272             },
3273             cos_day => sub {
3274             my $f = $frac_day_of->( $_[0] );
3275             return sub { cos( $TWO_PI * $f->( $_[0] ) ) };
3276             },
3277             sin_week => sub {
3278             my $f = $frac_week_of->( $_[0] );
3279             return sub { sin( $TWO_PI * $f->( $_[0] ) ) };
3280             },
3281             cos_week => sub {
3282             my $f = $frac_week_of->( $_[0] );
3283             return sub { cos( $TWO_PI * $f->( $_[0] ) ) };
3284             },
3285             );
3286             }
3287              
3288             # Build the parse/getter machinery for a datetime spec: ($parse, $getter_for),
3289             # where $parse->($v) yields whatever the getters consume (a capture array on
3290             # the fast path, a Time::Piece object otherwise) and $getter_for->($part)
3291             # resolves a part name to a getter closure, croaking on an unknown part.
3292             # Shared by the scalar and multi-output builders so the choice is made in
3293             # exactly one place.
3294             sub _datetime_engine {
3295 91     91   177 my ( $format, $where ) = @_;
3296 91 50 33     298 croak "datetime munger$where requires a strptime 'format'"
3297             unless defined $format && length $format;
3298              
3299             # Time::Piece is not core on the ancient perls Makefile.PL still nominally
3300             # supports, so only pull it in for the one munger that needs it. The fast
3301             # path keeps it loaded too: a regex mismatch falls back to strptime so the
3302             # fast path can never reject a value the slow path would have accepted.
3303 91         1095 require Time::Piece;
3304              
3305             my $strptime = sub {
3306 98     98   160 my ($v) = @_;
3307 98         143 my $t = eval { Time::Piece->strptime( $v, $format ) };
  98         301  
3308 98 100       5541 croak "datetime munger$where: cannot parse '$v' with '$format'"
3309             unless $t;
3310 75         4862 return $t;
3311 91         9912 };
3312              
3313 91 100       247 if ( my $fast = _compile_fast_format($format) ) {
3314 36         57 my ( $re, $idx ) = @{$fast}{qw(re idx)};
  36         83  
3315             my $parse = sub {
3316 158     158   204 my ($v) = @_;
3317 158 50       243 croak "datetime munger$where: undefined value" unless defined $v;
3318 158 100       1539 if ( my @c = $v =~ $re ) {
3319 156 100       346 return \@c if _fast_fields_in_range( \@c, $idx );
3320             }
3321             # Regex mismatch or out-of-range fields: let strptime be the judge,
3322             # rebuilding the capture array (normalized, when strptime chooses
3323             # to normalize rather than reject) in this format's capture order.
3324 43         75 my $t = $strptime->($v);
3325 21         65 my @c;
3326 21         41 @c[ @{$idx}{qw(year mon mday hour min sec)} ]
  21         294  
3327             = ( $t->year, $t->mon, $t->mday, $t->hour, $t->min, $t->sec );
3328 21         65 return \@c;
3329 36         171 }; ## end $parse = sub
3330             my $getter_for = sub {
3331 40     40   58 my ($part) = @_;
3332 40 50       142 my $factory = $DATETIME_PART_FAST{$part}
3333             or croak "datetime munger$where: unknown part '$part' (known: "
3334             . join( ', ', sort keys %DATETIME_PART ) . ')';
3335 40         85 return $factory->($idx);
3336 36         89 };
3337 36         127 return ( $parse, $getter_for );
3338             } ## end if ( my $fast = _compile_fast_format($format...))
3339              
3340             my $parse = sub {
3341 56     56   95 my ($v) = @_;
3342 56 100       236 croak "datetime munger$where: undefined value" unless defined $v;
3343 55         113 return $strptime->($v);
3344 55         229 };
3345             my $getter_for = sub {
3346 56     56   113 my ($part) = @_;
3347 56 50       152 my $get = $DATETIME_PART{$part}
3348             or croak "datetime munger$where: unknown part '$part' (known: "
3349             . join( ', ', sort keys %DATETIME_PART ) . ')';
3350 56         104 return $get;
3351 55         173 };
3352 55         179 return ( $parse, $getter_for );
3353             } ## end sub _datetime_engine
3354              
3355             sub _build_datetime {
3356 85     85   220 my ( $spec, $where ) = @_;
3357              
3358             croak "datetime munger$where: 'parts' is for the multi-output form (needs "
3359             . "'into'); use 'part' for a single column"
3360 85 100       396 if defined $spec->{parts};
3361              
3362 84         190 my ( $parse, $getter_for ) = _datetime_engine( $spec->{format}, $where );
3363 84 50       274 my $get = $getter_for->( defined $spec->{part} ? $spec->{part} : 'epoch' );
3364              
3365             # One-slot memo: event streams repeat the same stamp within a second
3366             # constantly, so the previous input usually answers the next call with a
3367             # string compare. A parse failure leaves the memo untouched.
3368 84         138 my ( $memo_in, $memo_out );
3369             return sub {
3370 251     251   77911 my ($v) = @_;
3371 251 100 100     1329 return $memo_out
      100        
3372             if defined $v && defined $memo_in && $v eq $memo_in;
3373 209         375 my $out = $get->( $parse->($v) );
3374 185         613 ( $memo_in, $memo_out ) = ( $v, $out );
3375 185         459 return $out;
3376 84         671 };
3377             } ## end sub _build_datetime
3378              
3379             # Multi-output datetime: parse once, emit one number per part, in 'parts' order
3380             # (which lines up with the caller's 'into'). Returns ($list_returning_code,
3381             # $arity) so compile() can check the arity against 'into'. Memoized like the
3382             # scalar form, caching the whole output list per input stamp.
3383             sub _build_datetime_multi {
3384 7     7   18 my ( $spec, $where ) = @_;
3385              
3386 7         41 my $parts = $spec->{parts};
3387 7 50 33     33 croak "datetime munger$where: 'parts' must be a non-empty arrayref"
3388             unless ref $parts eq 'ARRAY' && @$parts;
3389              
3390 7         24 my ( $parse, $getter_for ) = _datetime_engine( $spec->{format}, $where );
3391 7         15 my @get = map { $getter_for->($_) } @$parts;
  12         22  
3392              
3393 7         26 my ( $memo_in, @memo_out );
3394             my $code = sub {
3395 7     7   10 my ($v) = @_;
3396             return @memo_out
3397 7 100 66     43 if defined $v && defined $memo_in && $v eq $memo_in;
      100        
3398 5         8 my $t = $parse->($v);
3399 5         11 my @out = map { $_->($t) } @get;
  10         36  
3400 5         19 ( $memo_in, @memo_out ) = ( $v, @out );
3401 5         24 return @out;
3402 7         34 };
3403 7         50 return ( $code, scalar @$parts );
3404             } ## end sub _build_datetime_multi
3405              
3406             =head2 hash
3407              
3408             { munger => 'hash', buckets => 1024 }
3409             { munger => 'hash', buckets => 1024, seed => 7 }
3410             { munger => 'hash' } # raw 32-bit FNV-1a value
3411              
3412             Feature hashing for high-cardinality categoricals you do not want to (or cannot)
3413             enumerate with C. The input is stringified and run through 32-bit FNV-1a;
3414             with C the result is reduced modulo that many buckets (C<[0, buckets)>),
3415             otherwise the full 32-bit hash is returned. An optional C lets you decorrelate
3416             two hashed columns.
3417              
3418             This is the one munger that is XS-accelerated: FNV-1a is a per-byte loop with a
3419             32-bit modular multiply, which is slow in pure Perl and (on a 32-bit perl) fussy
3420             to get exactly right. C<$Algorithm::ToNumberMunger::HAVE_XS>
3421             reports whether the compiled path is in use; a pure-Perl fallback (exact on a
3422             64-bit perl) is used otherwise, and both produce identical values.
3423              
3424             =cut
3425              
3426             sub _build_hash {
3427 5     5   13 my ( $spec, $where ) = @_;
3428              
3429 5         13 my $buckets = $spec->{buckets};
3430 5 100 100     283 croak "hash munger$where: 'buckets' must be a positive integer"
3431             if defined $buckets && $buckets !~ /\A[1-9][0-9]*\z/;
3432              
3433 4 100       12 my $seed = defined $spec->{seed} ? $spec->{seed} : 0;
3434 4 50       23 croak "hash munger$where: 'seed' must be a non-negative integer"
3435             if $seed !~ /\A[0-9]+\z/;
3436              
3437 4 50       14 my $fn = $HAVE_XS ? \&_fnv1a_xs : \&_fnv1a_pp;
3438             return sub {
3439 7     7   31 my ($v) = @_;
3440 7 50       78 my $h = $fn->( defined $v ? "$v" : '', $seed );
3441 7 100       46 return defined $buckets ? $h % $buckets : $h;
3442 4         30 };
3443             } ## end sub _build_hash
3444              
3445             # Pure-Perl 32-bit FNV-1a, used only when the XS did not build. On a 64-bit
3446             # perl the intermediate h*16777619 (< 2**57) stays an exact integer, so the
3447             # masked result matches the C version bit for bit. The string is always
3448             # utf8-encoded first so a value hashes as its UTF-8 bytes no matter the internal
3449             # flag -- the same well-defined bytes SvPVutf8 hands the XS.
3450             sub _fnv1a_pp {
3451 0     0   0 my ( $str, $seed ) = @_;
3452 0         0 utf8::encode($str);
3453 0         0 my $h = ( 2166136261 ^ ( $seed & 0xFFFFFFFF ) ) & 0xFFFFFFFF;
3454 0         0 for my $c ( unpack 'C*', $str ) {
3455 0         0 $h ^= $c;
3456 0         0 $h = ( $h * 16777619 ) & 0xFFFFFFFF;
3457             }
3458 0         0 return $h;
3459             } ## end sub _fnv1a_pp
3460              
3461             =head2 chain
3462              
3463             # Shannon entropy of just the TLD: lowercase, keep the last dot-label
3464             { munger => 'chain',
3465             steps => [ { op => 'lc' }, { op => 'split', on => '.', index => -1 } ],
3466             then => { munger => 'entropy' } }
3467              
3468             # a hex request id buried in a token like 'req-0x2F'
3469             { munger => 'chain',
3470             steps => [ { op => 'capture', pattern => 'req-(0x[0-9a-fA-F]+)' } ],
3471             then => { munger => 'num', base => 16 } }
3472              
3473             Run the input through a list of string pre-transforms (C, applied in
3474             order), then hand the result to a terminal munger (C) for the actual
3475             number. Every string munger above scores the I value; C is how a
3476             feature targets a I of it -- the entropy of the TLD alone, the length
3477             of the first path segment, an enum over a normalized token -- without asking
3478             the writer's caller to pre-slice its input. Each step is a hashref with an
3479             C:
3480              
3481             =over 4
3482              
3483             =item * C / C - case-fold the value.
3484              
3485             =item * C - strip leading and trailing whitespace.
3486              
3487             =item * C - split on the literal separator C and keep piece
3488             C (0-based; negative counts from the end, so C<-1> is a hostname's last
3489             label). An index past either end yields the empty string.
3490              
3491             =item * C - match the regex C and keep capture group
3492             C (default C<1>). No match, or a group that did not participate, yields
3493             the empty string. A true C matches case-insensitively; the
3494             L trust note applies here too.
3495              
3496             =item * C - replace every match of the regex C with the
3497             literal string C (default: delete the matches). C as above.
3498              
3499             =back
3500              
3501             C is a full munger spec and may be any built-in that takes one value --
3502             including another C. All step parameters and the terminal spec are
3503             validated at build time. An undef input enters the chain as the empty string;
3504             whether an empty result is acceptable is the terminal's call (C and
3505             C score it C<0>, C croaks).
3506              
3507             The multi-output form works too: put C on the B and the C
3508             on the terminal, e.g. C a sloppy timestamp before a L
3509             C/C expansion.
3510              
3511             =cut
3512              
3513             # op => step builder; each validates its slice of the step spec at build time
3514             # and returns a string-to-string closure. Steps only ever see a defined string
3515             # (the chain entry point turns undef into '').
3516             my %CHAIN_OPS = (
3517             lc => sub {
3518             return sub { return lc $_[0] }
3519             },
3520             uc => sub {
3521             return sub { return uc $_[0] }
3522             },
3523             trim => sub {
3524             return sub { my ($s) = @_; $s =~ s/\A\s+//; $s =~ s/\s+\z//; return $s };
3525             },
3526             split => sub {
3527             my ( $step, $where ) = @_;
3528             my $on = $step->{on};
3529             croak "chain munger$where: split step requires a non-empty 'on' string"
3530             unless defined $on && length $on;
3531             my $idx = defined $step->{index} ? $step->{index} : 0;
3532             croak "chain munger$where: split 'index' must be an integer"
3533             unless $idx =~ /\A-?[0-9]+\z/;
3534             # limit -1 keeps trailing empty pieces, so 'a.' really has two labels
3535             # and index -1 is the empty last one, not 'a'.
3536             return sub {
3537             my @p = split /\Q$on\E/, $_[0], -1;
3538             return ( $idx > $#p || $idx < -@p ) ? '' : $p[$idx];
3539             };
3540             },
3541             capture => sub {
3542             my ( $step, $where ) = @_;
3543             my $pat = $step->{pattern};
3544             croak "chain munger$where: capture step requires a non-empty 'pattern'"
3545             unless defined $pat && length $pat;
3546             my $re = eval { $step->{ignore_case} ? qr/$pat/i : qr/$pat/ };
3547             croak "chain munger$where: cannot compile pattern '$pat': $@"
3548             unless defined $re;
3549             my $group = defined $step->{group} ? $step->{group} : 1;
3550             croak "chain munger$where: capture 'group' must be a positive integer"
3551             unless $group =~ /\A[1-9][0-9]*\z/;
3552             # @-/@+ rather than a list-context match: a pattern with no capture
3553             # groups returns (1) in list context, which would masquerade as a
3554             # captured '1'; $#+ says how many groups the pattern really has.
3555             return sub {
3556             my ($s) = @_;
3557             return '' unless $s =~ $re;
3558             return '' unless $group <= $#+ && defined $-[$group];
3559             return substr( $s, $-[$group], $+[$group] - $-[$group] );
3560             };
3561             },
3562             replace => sub {
3563             my ( $step, $where ) = @_;
3564             my $pat = $step->{pattern};
3565             croak "chain munger$where: replace step requires a non-empty 'pattern'"
3566             unless defined $pat && length $pat;
3567             my $re = eval { $step->{ignore_case} ? qr/$pat/i : qr/$pat/ };
3568             croak "chain munger$where: cannot compile pattern '$pat': $@"
3569             unless defined $re;
3570             my $with = defined $step->{with} ? $step->{with} : '';
3571             return sub { my ($s) = @_; $s =~ s/$re/$with/g; return $s };
3572             },
3573             );
3574              
3575             # Compile the 'steps' list into string-to-string closures; shared by the
3576             # scalar and multi-output chain builders.
3577             sub _chain_steps {
3578 18     18   38 my ( $spec, $where ) = @_;
3579              
3580 18         39 my $steps = $spec->{steps};
3581 18 100 66     308 croak "chain munger$where requires a non-empty 'steps' arrayref"
3582             unless ref $steps eq 'ARRAY' && @$steps;
3583              
3584 17         60 my @ops;
3585 17         62 for my $i ( 0 .. $#$steps ) {
3586 20         43 my $step = $steps->[$i];
3587 20 50       57 croak "chain munger$where: step[$i] must be a hashref"
3588             unless ref $step eq 'HASH';
3589 20         41 my $op = $step->{op};
3590 20 50 33     86 croak "chain munger$where: step[$i] has no 'op'"
3591             unless defined $op && length $op;
3592 20 100       230 my $mk = $CHAIN_OPS{$op}
3593             or croak "chain munger$where: step[$i] has unknown op '$op' (known: "
3594             . join( ', ', sort keys %CHAIN_OPS ) . ')';
3595 19         48 push @ops, $mk->( $step, $where );
3596             } ## end for my $i ( 0 .. $#$steps )
3597 14         40 return \@ops;
3598             } ## end sub _chain_steps
3599              
3600             # Validate and unpack the terminal spec; shared like _chain_steps.
3601             sub _chain_terminal_spec {
3602 14     14   31 my ( $spec, $where ) = @_;
3603 14         31 my $then = $spec->{then};
3604 14 100       200 croak "chain munger$where requires a 'then' hashref -- the terminal munger that produces the number"
3605             unless ref $then eq 'HASH';
3606 13         28 my $name = $then->{munger};
3607 13 50 33     76 croak "chain munger$where: 'then' has no 'munger' name"
3608             unless defined $name && length $name;
3609 13         41 return ( $then, $name );
3610             } ## end sub _chain_terminal_spec
3611              
3612             sub _build_chain {
3613 16     16   42 my ( $spec, $where ) = @_;
3614              
3615 16         43 my $ops = _chain_steps( $spec, $where );
3616 12         35 my ( $then, $name ) = _chain_terminal_spec( $spec, $where );
3617 11 100       288 my $builder = $BUILDERS{$name}
3618             or croak "chain munger$where: unknown terminal munger '$name' (known: "
3619             . join( ', ', sort keys %BUILDERS ) . ')';
3620 10         46 my $term = $builder->( $then, "$where (chain terminal)" );
3621              
3622             return sub {
3623 11 100   11   85 my $s = defined $_[0] ? "$_[0]" : '';
3624 11         37 $s = $_->($s) for @$ops;
3625 11         24 return $term->($s);
3626 9         57 };
3627             } ## end sub _build_chain
3628              
3629             # Multi-output chain: the same pre-transforms, but the terminal is one of the
3630             # multi-output ('into') mungers. Returns ($list_returning_code, $arity) like
3631             # every multi builder; the arity is the terminal's.
3632             sub _build_chain_multi {
3633 2     2   6 my ( $spec, $where ) = @_;
3634              
3635 2         8 my $ops = _chain_steps( $spec, $where );
3636 2         8 my ( $then, $name ) = _chain_terminal_spec( $spec, $where );
3637 2 100       204 my $builder = $MULTI_BUILDERS{$name}
3638             or croak "chain munger$where: terminal munger '$name' does not support "
3639             . "multiple outputs ('into'); only these do: "
3640             . join( ', ', sort keys %MULTI_BUILDERS );
3641 1         5 my ( $term, $arity ) = $builder->( $then, "$where (chain terminal)" );
3642              
3643             my $code = sub {
3644 1 50   1   17 my $s = defined $_[0] ? "$_[0]" : '';
3645 1         3 $s = $_->($s) for @$ops;
3646 1         3 return $term->($s);
3647 1         4 };
3648 1         4 return ( $code, $arity );
3649             } ## end sub _build_chain_multi
3650              
3651             =head2 eps
3652              
3653             { munger => 'eps', prefix => 'http-req:', from => 'src_ip' }
3654             { munger => 'eps', prefix => 'dns-nxd:', from => 'src_ip',
3655             read => 'rate', mark => 0 }
3656             # multi-output: one daemon round trip fills several columns
3657             { munger => 'eps', prefix => 'http-req:', from => 'src_ip',
3658             parts => [ 'rate', 'count' ], into => [ 'req_rate', 'req_count' ] }
3659              
3660             Per-entity sliding-window event rates via the C daemon shipped with
3661             L (see
3662             L). The input value becomes a meter B
3663             (after C is prepended); by default the munger B one event against
3664             that key and returns the key's current events-per-second, using the daemon's
3665             C command -- mark and query in a single command with a single reply.
3666             This is the munger behind rate columns like a per-source request rate: every
3667             event marks its source's meter and stores the rate the meter now reads.
3668              
3669             Unlike every other munger this one consults external state -- but the state
3670             lives in the daemon, not here, so the munger itself remains a stateless client
3671             and rows stay reproducible I the daemon. Because the daemon is shared,
3672             multiple writer processes marking the same keys see one B rate, which an
3673             in-process meter could never give.
3674              
3675             Spec keys:
3676              
3677             =over 4
3678              
3679             =item * C - unix socket path of the daemon. Defaults to
3680             C<$Algorithm::ToNumberMunger::EPS_SOCKET>
3681             (C).
3682              
3683             =item * C - string prepended to the input to form the key, namespacing
3684             this column's meters (two columns keyed on the same field need different
3685             prefixes or they share meters). No whitespace/control characters. Default C<''>.
3686              
3687             =item * C - whether to mark the key (default C<1>). Marking rides
3688             C: with C<< read => 'rate' >> that one command is the whole exchange;
3689             with C/C the read is pipelined after it (the C rate
3690             reply is discarded), so a marking failure still comes back as an ordinary
3691             first reply. With C<< mark => 0 >> the munger only reads, for columns whose
3692             marking is done elsewhere -- e.g. an NXDOMAIN rate is I by the pipeline
3693             only on NXDOMAIN responses but I on every row.
3694              
3695             =item * C - what to read: C (events/sec over the daemon's window,
3696             default), C (events inside the window), or C (lifetime).
3697              
3698             =item * C + C - multi-output form (see L): read several
3699             of C/C/C for the one key in a single round trip, filling one
3700             column each. When marking, the C reply itself serves the first C
3701             part, so C<< parts => ['rate', 'count'] >> costs exactly two commands.
3702              
3703             =item * C - C<'die'> (default) croaks the write when the daemon is
3704             unreachable or replies C; a number is returned instead as a quiet fallback.
3705             Note C<0> is indistinguishable from a genuinely idle key, so quiet fallback
3706             biases the column -- loud is the default on purpose.
3707              
3708             =item * C - per-operation socket timeout in seconds (default 5,
3709             best-effort via C/C), so a wedged daemon cannot hang a
3710             writer forever.
3711              
3712             =back
3713              
3714             Semantics worth knowing: a marked read B; keys
3715             have whitespace/control bytes replaced with C<_> to satisfy the daemon's key
3716             rules; connections are made lazily on first use and kept open (reconnecting
3717             transparently after a fork or an error), so compiling a plan -- including the
3718             eager validation in C -- needs no running daemon. Each eps column
3719             costs one unix-socket round trip per row; the multi-output form exists so
3720             rate+count of the same key costs one round trip, not two.
3721              
3722             =cut
3723              
3724             # Default socket path of the iqbi-damiq daemon.
3725             our $EPS_SOCKET = '/var/run/iqbi-damiq.sock';
3726              
3727             # Persistent daemon connections, keyed by socket path, shared by every eps
3728             # munger in the process. Entries record the pid that opened them so a forked
3729             # writer transparently reopens instead of sharing a socket with its parent.
3730             # Connections are made lazily on first use -- never at munger build time, so a
3731             # plan can compile (eager validation) with no daemon running.
3732             my %EPS_CONN;
3733              
3734             sub _eps_conn {
3735 0     0   0 my ( $path, $timeout ) = @_;
3736 0         0 my $c = $EPS_CONN{$path};
3737 0 0 0     0 return $c->{fh} if $c && $c->{pid} == $$;
3738              
3739 0         0 require Socket;
3740 0         0 require IO::Socket::UNIX;
3741 0 0       0 my $fh = IO::Socket::UNIX->new(
3742             Type => Socket::SOCK_STREAM(),
3743             Peer => $path,
3744             ) or die "cannot connect to iqbi-damiq at $path: $!\n";
3745              
3746             # Best-effort read/write timeouts so a wedged daemon cannot hang a writer.
3747 0         0 eval {
3748 0         0 my $tv = pack( 'l!l!', $timeout, 0 );
3749 0         0 setsockopt( $fh, Socket::SOL_SOCKET(), Socket::SO_RCVTIMEO(), $tv );
3750 0         0 setsockopt( $fh, Socket::SOL_SOCKET(), Socket::SO_SNDTIMEO(), $tv );
3751             };
3752              
3753 0         0 $EPS_CONN{$path} = { fh => $fh, pid => $$ };
3754 0         0 return $fh;
3755             } ## end sub _eps_conn
3756              
3757             # One pipelined transaction: send $cmd (possibly several lines) and read
3758             # $nreplies "OK n" lines, one per command sent. The munger only ever sends
3759             # commands that reply exactly once -- MARKRATE (which marks AND returns the
3760             # rate in one go), RATE, COUNT, TOTAL; never a bare MARK, whose reply-only-on-
3761             # error behavior would let a failure desynchronize the reply stream. Dies on
3762             # ERR, EOF, or timeout; the caller still drops the cached connection on error
3763             # as belt and braces.
3764             sub _eps_txn {
3765 0     0   0 my ( $path, $timeout, $cmd, $nreplies ) = @_;
3766 0         0 my $fh = _eps_conn( $path, $timeout );
3767 0 0       0 print {$fh} $cmd or die "write to iqbi-damiq failed: $!\n";
  0         0  
3768 0         0 my @out;
3769 0         0 for ( 1 .. $nreplies ) {
3770 0         0 my $reply = <$fh>;
3771 0 0       0 die "iqbi-damiq closed the connection (or timed out)\n"
3772             unless defined $reply;
3773 0 0       0 $reply =~ /\AOK (\S+)/
3774             or die "iqbi-damiq replied: $reply";
3775 0         0 push @out, $1 + 0;
3776             }
3777 0         0 return @out;
3778             } ## end sub _eps_txn
3779              
3780             # Validate the spec keys shared by the scalar and multi-output eps builders.
3781             sub _eps_spec {
3782 0     0   0 my ( $spec, $where ) = @_;
3783              
3784 0 0       0 my $socket = defined $spec->{socket} ? $spec->{socket} : $EPS_SOCKET;
3785 0 0       0 croak "eps munger$where: 'socket' must be a non-empty path"
3786             unless length $socket;
3787              
3788 0 0       0 my $prefix = defined $spec->{prefix} ? $spec->{prefix} : '';
3789 0 0       0 croak "eps munger$where: 'prefix' may not contain whitespace or control " . 'characters'
3790             if $prefix =~ /[\s[:cntrl:]]/;
3791              
3792 0 0       0 my $mark = exists $spec->{mark} ? ( $spec->{mark} ? 1 : 0 ) : 1;
    0          
3793              
3794 0 0       0 my $timeout = defined $spec->{timeout} ? $spec->{timeout} : 5;
3795 0 0 0     0 croak "eps munger$where: 'timeout' must be a positive number"
3796             unless looks_like_number($timeout) && $timeout > 0;
3797              
3798 0 0       0 my $on_error = defined $spec->{on_error} ? $spec->{on_error} : 'die';
3799 0 0 0     0 croak "eps munger$where: 'on_error' must be 'die' or a number"
3800             unless $on_error eq 'die' || looks_like_number($on_error);
3801              
3802 0         0 return ( $socket, $prefix, $mark, $timeout, $on_error );
3803             } ## end sub _eps_spec
3804              
3805             my %EPS_READ = map { $_ => 1 } qw(rate count total);
3806              
3807             sub _build_eps {
3808 0     0   0 my ( $spec, $where ) = @_;
3809              
3810             croak "eps munger$where: 'parts' is for the multi-output form (needs " . "'into'); use 'read' for a single column"
3811 0 0       0 if defined $spec->{parts};
3812              
3813 0         0 my ( $socket, $prefix, $mark, $timeout, $on_error ) = _eps_spec( $spec, $where );
3814              
3815 0 0       0 my $read = defined $spec->{read} ? $spec->{read} : 'rate';
3816             croak "eps munger$where: unknown read '$read' (known: " . join( ', ', sort keys %EPS_READ ) . ')'
3817 0 0       0 unless $EPS_READ{$read};
3818              
3819             # Command plan, fixed at build time. The common case -- mark and read the
3820             # rate -- is the daemon's single MARKRATE command. mark+count/total rides
3821             # MARKRATE too (its rate reply is discarded) so marking failures come back
3822             # as an ordinary first reply instead of a bare MARK's error-only surprise.
3823             my @cmds
3824 0 0       0 = !$mark ? ( uc $read )
    0          
3825             : $read eq 'rate' ? ('MARKRATE')
3826             : ( 'MARKRATE', uc $read );
3827              
3828             return sub {
3829 0     0   0 my ($v) = @_;
3830 0 0       0 my $key = $prefix . ( defined $v ? "$v" : '' );
3831 0         0 $key =~ s/[\s[:cntrl:]]/_/g;
3832 0         0 my @replies = eval {
3833 0 0       0 die "empty key\n" unless length $key;
3834 0         0 _eps_txn( $socket, $timeout, join( '', map { "$_ $key\n" } @cmds ), scalar @cmds );
  0         0  
3835             };
3836 0 0       0 if ($@) {
3837 0         0 my $err = $@;
3838 0         0 delete $EPS_CONN{$socket}; # reconnect fresh next call
3839 0 0       0 croak "eps munger$where: $err" if $on_error eq 'die';
3840 0         0 return $on_error + 0;
3841             }
3842 0         0 return $replies[-1]; # the requested read is always the last reply
3843 0         0 }; ## end sub
3844             } ## end sub _build_eps
3845              
3846             # Multi-output eps: one key, several reads (rate/count/total), one round trip.
3847             # Returns ($list_returning_code, $arity) for compile()'s 'into' check.
3848             sub _build_eps_multi {
3849 0     0   0 my ( $spec, $where ) = @_;
3850              
3851 0         0 my $parts = $spec->{parts};
3852 0 0 0     0 croak "eps munger$where: 'parts' must be a non-empty arrayref"
3853             unless ref $parts eq 'ARRAY' && @$parts;
3854 0         0 for my $p (@$parts) {
3855             croak "eps munger$where: unknown part '"
3856             . ( defined $p ? $p : 'undef' )
3857             . "' (known: "
3858             . join( ', ', sort keys %EPS_READ ) . ')'
3859 0 0 0     0 unless defined $p && $EPS_READ{$p};
    0          
3860             }
3861              
3862 0         0 my ( $socket, $prefix, $mark, $timeout, $on_error ) = _eps_spec( $spec, $where );
3863              
3864             # Command plan, fixed at build time. When marking, the mark is a MARKRATE
3865             # whose own reply serves the first 'rate' part for free; the remaining
3866             # parts become one read command each. @take maps each part to the reply
3867             # index that answers it, so the output stays in 'parts' order.
3868 0         0 my ( @cmds, @take );
3869 0         0 my $rate_served = 0;
3870 0 0       0 push @cmds, 'MARKRATE' if $mark;
3871 0         0 for my $i ( 0 .. $#$parts ) {
3872 0 0 0     0 if ( $mark && !$rate_served && $parts->[$i] eq 'rate' ) {
      0        
3873 0         0 $take[$i] = 0; # MARKRATE's reply is the rate
3874 0         0 $rate_served = 1;
3875 0         0 next;
3876             }
3877 0         0 push @cmds, uc $parts->[$i];
3878 0         0 $take[$i] = $#cmds;
3879             }
3880 0         0 my $n = @$parts;
3881 0         0 my $nreplies = @cmds;
3882              
3883             my $code = sub {
3884 0     0   0 my ($v) = @_;
3885 0 0       0 my $key = $prefix . ( defined $v ? "$v" : '' );
3886 0         0 $key =~ s/[\s[:cntrl:]]/_/g;
3887 0         0 my @replies = eval {
3888 0 0       0 die "empty key\n" unless length $key;
3889 0         0 _eps_txn( $socket, $timeout, join( '', map { "$_ $key\n" } @cmds ), $nreplies );
  0         0  
3890             };
3891 0 0       0 if ($@) {
3892 0         0 my $err = $@;
3893 0         0 delete $EPS_CONN{$socket};
3894 0 0       0 croak "eps munger$where: $err" if $on_error eq 'die';
3895 0         0 return ( $on_error + 0 ) x $n;
3896             }
3897 0         0 return @replies[@take];
3898 0         0 }; ## end $code = sub
3899 0         0 return ( $code, $n );
3900             } ## end sub _build_eps_multi
3901              
3902             # A compiled munging plan for one set, produced by Mungers->compile. It turns an
3903             # input record into a fully-numeric row in tags order; the Writer then only has
3904             # to validate and append. Kept in its own package so the assembly logic is
3905             # testable without a Writer or the filesystem.
3906             package Algorithm::ToNumberMunger::Plan;
3907              
3908 5     5   56 use strict;
  5         9  
  5         108  
3909 5     5   17 use warnings;
  5         16  
  5         303  
3910 5     5   21 use Carp qw(croak);
  5         15  
  5         7982  
3911              
3912 0     0   0 sub tags { return $_[0]->{tags} }
3913              
3914             # Assemble a row from a name-keyed record. Scalar/raw columns read their own tag
3915             # (or the munger's 'from'); expanding mungers read one source and fill several
3916             # columns; combining mungers read several sources and fill one. This is the only
3917             # form that supports expanders and combiners.
3918             sub apply_named {
3919 17     17   2954 my ( $self, $hash ) = @_;
3920 17 50       46 croak 'apply_named requires a hashref' unless ref $hash eq 'HASH';
3921              
3922 17         30 my @row;
3923 17         22 for my $s ( @{ $self->{scalar} } ) {
  17         45  
3924             croak "missing value for '$s->{from}'"
3925 8 100       107 unless exists $hash->{ $s->{from} };
3926 7         13 my $v = $hash->{ $s->{from} };
3927 7 100       27 $row[ $self->{pos}{ $s->{tag} } ] = $s->{code} ? $s->{code}->($v) : $v;
3928             }
3929              
3930 16         21 for my $e ( @{ $self->{expand} } ) {
  16         28  
3931             croak "missing value for '$e->{from}'"
3932 8 100       186 unless exists $hash->{ $e->{from} };
3933 7         17 my @vals = $e->{code}->( $hash->{ $e->{from} } );
3934 0         0 croak "expanding munger for [@{ $e->{into} }] returned "
3935             . scalar(@vals)
3936             . ' value(s), expected '
3937 0         0 . scalar( @{ $e->{into} } )
3938 7 50       11 unless @vals == @{ $e->{into} };
  7         23  
3939 7         21 for my $i ( 0 .. $#{ $e->{into} } ) {
  7         15  
3940 14         40 $row[ $self->{pos}{ $e->{into}[$i] } ] = $vals[$i];
3941             }
3942             } ## end for my $e ( @{ $self->{expand} } )
3943              
3944 15         41 for my $c ( @{ $self->{combine} } ) {
  15         28  
3945 14         16 my @vals;
3946 14         17 for my $f ( @{ $c->{from} } ) {
  14         20  
3947             croak "missing value for '$f'"
3948 31 100       182 unless exists $hash->{$f};
3949 30         45 push @vals, $hash->{$f};
3950             }
3951 13         38 $row[ $self->{pos}{ $c->{tag} } ] = $c->{code}->(@vals);
3952             }
3953              
3954 13         62 return \@row;
3955             } ## end sub apply_named
3956              
3957             # Assemble a row from an already-ordered positional row, applying scalar mungers
3958             # in place. Expanding and combining mungers cannot be expressed positionally
3959             # (there is no named source), so a set that has any is a hard error here -- use
3960             # apply_named.
3961             sub apply_positional {
3962 5     5   2365 my ( $self, $row ) = @_;
3963 5 50       19 croak 'apply_positional requires an arrayref row' unless ref $row eq 'ARRAY';
3964             croak 'positional write is unsupported for a set with expanding mungers; ' . 'use write_named'
3965 5 100       7 if @{ $self->{expand} };
  5         150  
3966             croak 'positional write is unsupported for a set with multi-input mungers; ' . 'use write_named'
3967 4 100       6 if @{ $self->{combine} };
  4         139  
3968 1         167 croak 'row has ' . scalar(@$row) . ' fields but info.json declares ' . scalar( @{ $self->{tags} } )
3969 3 100       6 unless @$row == @{ $self->{tags} };
  3         9  
3970              
3971 2         6 my @out = @$row;
3972 2         4 for my $s ( @{ $self->{scalar} } ) {
  2         7  
3973 4 100       12 next unless $s->{code};
3974 1         3 my $i = $self->{pos}{ $s->{tag} };
3975 1         3 $out[$i] = $s->{code}->( $out[$i] );
3976             }
3977 2         10 return \@out;
3978             } ## end sub apply_positional
3979              
3980             =head1 AUTHOR
3981              
3982             Zane C. Bowers-Hadley, C<< >>
3983              
3984             =head1 LICENSE AND COPYRIGHT
3985              
3986             This software is Copyright (c) 2026 by Zane C. Bowers-Hadley.
3987              
3988             This is free software, licensed under:
3989              
3990             The GNU Lesser General Public License, Version 2.1, February 1999
3991              
3992             =cut
3993              
3994             1; # End of Algorithm::ToNumberMunger