Algorithm-ToNumberMunger
view release on metacpan or search on metacpan
t/mungers.t view on Meta::CPAN
is( $c->('POST'), 1, 'enum maps POST' );
eval { $c->('HEAD') };
like( $@, qr/no mapping for 'HEAD'/, 'enum croaks on unmapped without default' );
my $d = $M->build( { munger => 'enum', map => { GET => 0 }, default => -1 } );
is( $d->('WAT'), -1, 'enum default for unmapped' );
is( $d->(undef), -1, 'enum default for undef' );
}
# ---- http_enum ------------------------------------------------------------
{
my $c = $M->build( { munger => 'http_enum' } );
is( $c->(100), 1, 'http_enum 1xx -> 1' );
is( $c->(200), 2, 'http_enum 2xx -> 2' );
is( $c->(301), 3, 'http_enum 3xx -> 3' );
is( $c->(404), 4, 'http_enum 4xx -> 4' );
is( $c->(503), 5, 'http_enum 5xx -> 5' );
is( $c->('200'), 2, 'http_enum accepts a numeric string' );
is( $c->(700), 7, 'http_enum lax lets out-of-range through' );
eval { $c->('nope') };
like( $@, qr/not a numeric status code/, 'http_enum croaks on non-numeric' );
my $s = $M->build( { munger => 'http_enum', strict => 1 } );
is( $s->(404), 4, 'http_enum strict passes an in-range code' );
is( $s->(100), 1, 'http_enum strict passes the low boundary' );
is( $s->(599), 5, 'http_enum strict passes the high boundary' );
eval { $s->(700) };
like( $@, qr/out of range/, 'http_enum strict rejects a high code' );
eval { $s->(99) };
like( $@, qr/out of range/, 'http_enum strict rejects a low code' );
}
# ---- smtp_enum ------------------------------------------------------------
{
my $c = $M->build( { munger => 'smtp_enum' } );
is( $c->(220), 2, 'smtp_enum 2yz -> 2' );
is( $c->(354), 3, 'smtp_enum 3yz -> 3' );
is( $c->(450), 4, 'smtp_enum 4yz -> 4' );
is( $c->(550), 5, 'smtp_enum 5yz -> 5' );
is( $c->(700), 7, 'smtp_enum lax lets out-of-range through' );
eval { $c->('nope') };
like( $@, qr/smtp_enum munger.*not a numeric status code/, 'smtp_enum croaks on non-numeric' );
my $s = $M->build( { munger => 'smtp_enum', strict => 1 } );
is( $s->(200), 2, 'smtp_enum strict passes the low boundary' );
is( $s->(599), 5, 'smtp_enum strict passes the high boundary' );
eval { $s->(150) };
like( $@, qr/out of range \(200-599\)/, 'smtp_enum strict rejects 1xx (unused in SMTP)' );
eval { $s->(700) };
like( $@, qr/out of range \(200-599\)/, 'smtp_enum strict rejects a high code' );
}
# ---- sip_enum -------------------------------------------------------------
{
my $c = $M->build( { munger => 'sip_enum' } );
is( $c->(100), 1, 'sip_enum 1xx -> 1' );
is( $c->(200), 2, 'sip_enum 2xx -> 2' );
is( $c->(302), 3, 'sip_enum 3xx -> 3' );
is( $c->(404), 4, 'sip_enum 4xx -> 4' );
is( $c->(503), 5, 'sip_enum 5xx -> 5' );
is( $c->(603), 6, 'sip_enum 6xx -> 6 (global failure)' );
my $s = $M->build( { munger => 'sip_enum', strict => 1 } );
is( $s->(699), 6, 'sip_enum strict passes the 6xx high boundary' );
eval { $s->(700) };
like( $@, qr/out of range \(100-699\)/, 'sip_enum strict rejects >= 700' );
eval { $s->(99) };
like( $@, qr/out of range \(100-699\)/, 'sip_enum strict rejects < 100' );
}
# ---- frozen_freq_map -------------------------------------------------------------
{
# defaults: neg_log_prob, smoothing 1, unseen 'rare'. counts a:3 b:1,
# total 4, V 2 => denom = 4 + 1*(2+1) = 7.
my $r = $M->build( { munger => 'frozen_freq_map', counts => { a => 3, b => 1 } } );
ok( $r->('b') > $r->('a'), 'frozen_freq_map: rarer value is more surprising' );
ok( $r->('zzz') > $r->('b'), 'frozen_freq_map: unseen is the most surprising' );
ok( abs( $r->('zzz') - log(7) ) < 1e-9, 'frozen_freq_map unseen surprisal = -ln(1/7)' );
ok( abs( $r->('a') - -log( 4 / 7 ) ) < 1e-9, 'frozen_freq_map seen surprisal value' );
my $cnt = $M->build( { munger => 'frozen_freq_map', counts => { a => 3, b => 1 }, mode => 'count' } );
is( $cnt->('a'), 3, 'frozen_freq_map count mode' );
is( $cnt->('zzz'), 0, 'frozen_freq_map count mode: unseen -> 0' );
# raw probability (no smoothing): a:3 b:1 total 4 => p(a)=0.75.
my $freq = $M->build(
{
munger => 'frozen_freq_map',
counts => { a => 3, b => 1 },
mode => 'freq',
smoothing => 0,
}
);
ok( abs( $freq->('a') - 0.75 ) < 1e-9, 'frozen_freq_map raw freq, no smoothing' );
is( $freq->('zzz'), 0, 'frozen_freq_map freq: unseen with no smoothing -> 0' );
my $num = $M->build(
{
munger => 'frozen_freq_map',
counts => { a => 3 },
unseen => -1,
mode => 'count',
}
);
is( $num->('zzz'), -1, 'frozen_freq_map numeric unseen default' );
# explicit total (pruned tail) larger than the sum is honored.
my $pruned = $M->build( { munger => 'frozen_freq_map', counts => { a => 3 }, total => 100 } );
ok( $pruned->('zzz') > $pruned->('a'), 'frozen_freq_map with pruned tail still ranks unseen rarest' );
# validation
eval { $M->build( { munger => 'frozen_freq_map', counts => {} } ) };
like( $@, qr/non-empty 'counts'/, 'frozen_freq_map rejects empty counts' );
eval { $M->build( { munger => 'frozen_freq_map', counts => { a => 3 }, total => 1 } ) };
like( $@, qr/must be >= sum/, 'frozen_freq_map rejects total < sum' );
eval { $M->build( { munger => 'frozen_freq_map', counts => { a => 3 }, mode => 'bogus' } ) };
like( $@, qr/unknown mode 'bogus'/, 'frozen_freq_map rejects bad mode' );
eval { $M->build( { munger => 'frozen_freq_map', counts => { a => 3 }, smoothing => 0 } ); };
like( $@, qr/needs smoothing > 0/, 'frozen_freq_map neg_log_prob + rare + no smoothing croaks' );
# size guard warns
t/mungers.t view on Meta::CPAN
# aad_signin_error: the sparse ResultType code space collapsed to reasons.
my $se = $M->build( { munger => 'aad_signin_error_enum', default => -1 } );
is( $se->('0'), 0, 'aad_signin_error 0 is success' );
is( $se->('50126'), 1, 'aad_signin_error 50126 bad-password' );
is( $se->('50056'), $se->('50126'), 'aad_signin_error 50056 shares bad-password bucket' );
is( $se->('50144'), $se->('50055'), 'aad_signin_error 50144 shares password-expired bucket' );
is( $se->('53000'), 8, 'aad_signin_error 53000 blocked-by-CA bucket' );
is( $se->(50053), 4, 'aad_signin_error accepts an integer code' );
is( $se->('99999'), -1, 'aad_signin_error default for an unlisted code' );
my $rl = $M->build( { munger => 'risk_level_enum', default => -1 } );
is( $rl->('none'), 0, 'risk_level none' );
is( $rl->('High'), 3, 'risk_level high (case-insensitive)' );
is( $rl->('hidden'), -1, 'risk_level hidden is off-scale (default)' );
ok( $rl->('low') < $rl->('high'), 'risk_level is ordinal' );
my $pt = $M->build( { munger => 'aws_principal_type_enum', default => -1 } );
is( $pt->('Root'), 0, 'aws_principal_type root (the alert signal)' );
is( $pt->('AssumedRole'), 2, 'aws_principal_type assumedrole' );
is( $pt->('IAMUser'), 1, 'aws_principal_type iamuser (case-insensitive)' );
is( $pt->('nope'), -1, 'aws_principal_type default for unlisted' );
# aad_client_app: modern < 2, legacy >= 2 (the legacy-auth threshold).
my $ca = $M->build( { munger => 'aad_client_app_enum', default => -1 } );
is( $ca->('Browser'), 0, 'aad_client_app browser is modern' );
is( $ca->('Mobile Apps and Desktop clients'), 1, 'aad_client_app modern desktop' );
ok( $ca->('IMAP4') >= 2, 'aad_client_app IMAP4 is legacy (>= 2)' );
ok( $ca->('POP3') >= 2, 'aad_client_app POP3 is legacy (>= 2)' );
is( $ca->('imap'), $ca->('IMAP4'), 'aad_client_app imap short alias' );
ok( $ca->('Browser') < 2 && $ca->('Other clients') >= 2,
'aad_client_app: modern sorts below the legacy-auth threshold' );
my $rs = $M->build( { munger => 'risk_state_enum', default => -1 } );
is( $rs->('none'), 0, 'risk_state none' );
is( $rs->('atRisk'), 4, 'risk_state atRisk (case-insensitive)' );
is( $rs->('confirmedCompromised'), 5, 'risk_state confirmedCompromised' );
my $ls = $M->build( { munger => 'vpc_flow_log_status_enum', default => -1 } );
is( $ls->('OK'), 0, 'vpc_flow_log_status OK' );
is( $ls->('NODATA'), 1, 'vpc_flow_log_status NODATA' );
is( $ls->('SKIPDATA'), 2, 'vpc_flow_log_status SKIPDATA' );
my $et = $M->build( { munger => 'aws_event_type_enum', default => -1 } );
is( $et->('AwsApiCall'), 0, 'aws_event_type AwsApiCall' );
is( $et->('AwsConsoleSignIn'), 3, 'aws_event_type AwsConsoleSignIn (the signal)' );
my $cs = $M->build( { munger => 'conditional_access_result_enum', default => -1 } );
is( $cs->('success'), 0, 'conditional_access success' );
is( $cs->('notApplied'), 1, 'conditional_access notApplied (case-insensitive)' );
is( $cs->('failure'), 4, 'conditional_access failure' );
eval { $M->build( { munger => 'aws_principal_type_enum' } )->(0) };
like( $@, qr/no mapping for '0'/, 'cloud category enums do not pass a number through' );
}
# ---- ip_class ---------------------------------------------------------------
{
my $c = $M->build( { munger => 'ip_class' } );
# v4: one probe per class
is( $c->('8.8.8.8'), 0, 'ip_class v4 global' );
is( $c->('10.1.2.3'), 1, 'ip_class 10/8 private' );
is( $c->('172.16.0.1'), 1, 'ip_class 172.16/12 private' );
is( $c->('172.32.0.1'), 0, 'ip_class 172.32 is NOT private' );
is( $c->('192.168.99.1'), 1, 'ip_class 192.168/16 private' );
is( $c->('100.64.0.1'), 1, 'ip_class CGNAT counts as private' );
is( $c->('100.128.0.1'), 0, 'ip_class just past CGNAT is global' );
is( $c->('127.0.0.53'), 2, 'ip_class loopback' );
is( $c->('169.254.1.1'), 3, 'ip_class v4 link-local' );
is( $c->('224.0.0.251'), 4, 'ip_class v4 multicast' );
is( $c->('239.255.255.250'), 4, 'ip_class multicast high edge' );
is( $c->('255.255.255.255'), 5, 'ip_class broadcast' );
is( $c->('0.0.0.0'), 6, 'ip_class v4 unspecified' );
is( $c->('0.1.2.3'), 7, 'ip_class rest of 0/8 reserved' );
is( $c->('192.0.2.55'), 7, 'ip_class TEST-NET-1 reserved' );
is( $c->('198.51.100.7'), 7, 'ip_class TEST-NET-2 reserved' );
is( $c->('203.0.113.9'), 7, 'ip_class TEST-NET-3 reserved' );
is( $c->('198.18.0.1'), 7, 'ip_class benchmarking reserved' );
is( $c->('240.0.0.1'), 7, 'ip_class 240/4 reserved' );
# v6
is( $c->('2600:1700::1'), 0, 'ip_class v6 global' );
is( $c->('fd12:3456:789a::1'), 1, 'ip_class ULA private' );
is( $c->('::1'), 2, 'ip_class v6 loopback' );
is( $c->('fe80::1'), 3, 'ip_class v6 link-local' );
is( $c->('ff02::fb'), 4, 'ip_class v6 multicast' );
is( $c->('::'), 6, 'ip_class v6 unspecified' );
is( $c->('2001:db8::1'), 7, 'ip_class v6 documentation reserved' );
is( $c->('100::1'), 7, 'ip_class discard prefix reserved' );
is( $c->('::ffff:10.0.0.1'), 1, 'ip_class v4-mapped classifies the embedded v4' );
is( $c->('::ffff:8.8.8.8'), 0, 'ip_class v4-mapped global' );
eval { $c->('not-an-ip') };
like( $@, qr/not a parseable IP address/, 'ip_class croaks on garbage without default' );
eval { $c->('10.0.0.256') };
like( $@, qr/not a parseable IP address/, 'ip_class rejects out-of-range octets' );
my $d = $M->build( { munger => 'ip_class', default => -1 } );
is( $d->('not-an-ip'), -1, 'ip_class default for garbage' );
is( $d->(undef), -1, 'ip_class default for undef' );
eval { $M->build( { munger => 'ip_class', default => 'x' } ) };
like( $@, qr/'default' must be numeric/, 'ip_class validates default at build time' );
}
# ---- cidr -------------------------------------------------------------------
{
my $c = $M->build(
{
munger => 'cidr',
nets => [ '10.10.0.0/16', '10.0.0.0/8', '2001:db8:5::/48' ],
default => -1,
}
);
is( $c->('10.10.3.4'), 0, 'cidr: most-specific first match wins' );
is( $c->('10.99.0.1'), 1, 'cidr: falls through to the wider net' );
is( $c->('2001:db8:5::7'), 2, 'cidr: v6 net matches' );
is( $c->('2001:db8:6::7'), -1, 'cidr: v6 outside the /48 takes default' );
is( $c->('192.168.1.1'), -1, 'cidr: unmatched v4 takes default' );
is( $c->('not-an-ip'), -1, 'cidr: garbage takes default' );
# a v4 address is never tested against v6 nets (and vice versa)
my $v6only = $M->build( { munger => 'cidr', nets => ['::/0'], default => -1 } );
is( $v6only->('8.8.8.8'), -1, 'cidr: ::/0 does not swallow v4' );
my $v4any = $M->build( { munger => 'cidr', nets => ['0.0.0.0/0'], default => -1 } );
is( $v4any->('8.8.8.8'), 0, 'cidr: 0.0.0.0/0 matches any v4' );
my $strict = $M->build( { munger => 'cidr', nets => ['10.0.0.0/8'] } );
eval { $strict->('192.168.1.1') };
like( $@, qr/none of the listed networks/, 'cidr croaks on no match without default' );
eval { $strict->('nope') };
like( $@, qr/not a parseable IP address/, 'cidr croaks on garbage without default' );
eval { $M->build( { munger => 'cidr', nets => [] } ) };
like( $@, qr/non-empty 'nets'/, 'cidr rejects empty nets' );
eval { $M->build( { munger => 'cidr', nets => ['10.0.0.0'] } ) };
like( $@, qr/'address\/prefix' form/, 'cidr rejects a bare address' );
eval { $M->build( { munger => 'cidr', nets => ['10.0.0.0/33'] } ) };
like( $@, qr/prefix length must be 0-32/, 'cidr rejects an oversized v4 prefix' );
eval { $M->build( { munger => 'cidr', nets => ['wat/8'] } ) };
like( $@, qr/unparseable address/, 'cidr rejects an unparseable net address' );
}
# ---- datetime -------------------------------------------------------------
SKIP: {
eval { require Time::Piece; 1 }
or skip 'Time::Piece not available', 3;
my $ep = $M->build( { munger => 'datetime', format => '%Y-%m-%dT%H:%M:%S', part => 'epoch' } );
# 2026-07-06T12:00:00 UTC via strptime (Time::Piece strptime is UTC)
my $t = Time::Piece->strptime( '2026-07-06T12:00:00', '%Y-%m-%dT%H:%M:%S' );
is( $ep->('2026-07-06T12:00:00'), $t->epoch, 'datetime epoch part' );
( run in 0.659 second using v1.01-cache-2.11-cpan-0fb53d1c279 )