Algorithm-ToNumberMunger
view release on metacpan or search on metacpan
t/mungers.t view on Meta::CPAN
#!perl
use 5.006;
use strict;
use warnings;
use Test::More;
use Algorithm::ToNumberMunger;
my $M = 'Algorithm::ToNumberMunger';
# ---- registry -------------------------------------------------------------
ok( $M->has_munger('enum'), 'enum is a known munger' );
ok( !$M->has_munger('nope'), 'unknown munger is not known' );
is_deeply(
[ $M->known_mungers ],
[
qw(aad_client_app_enum aad_signin_error_enum amavis_category_enum
app_proto_enum aws_event_type_enum aws_principal_type_enum bit bool
bucket chain char cidr clamav_result_enum clamp combine
conditional_access_result_enum count datetime dhcp_msgtype_enum
dict_enum dkim_result_enum dmarc_result_enum dns_qtype_enum
dns_rcode_enum entropy enum eps flow_reason_enum flow_state_enum
frozen_freq_map ftp_enum gemini_enum hash http_enum http_method_enum
http_version_enum ip_class ip_proto_enum kerberos_etype_enum length
log match mgcp_enum ngram nntp_enum num postfix_status_enum quantile
ratio risk_level_enum risk_state_enum rspamd_action_enum rtsp_enum
run sasl_mech_enum sasl_mech_iana_enum scale sip_enum sip_method_enum
smtp_enum spamassassin_autolearn_enum spf_result_enum
ssh_auth_method_enum suricata_action_enum syslog_facility_enum
syslog_severity_enum systemd_result_enum tcp_state_enum
tls_version_enum vpc_flow_log_status_enum
windows_impersonation_level_enum windows_integrity_level_enum
windows_logon_status_enum zscore)
],
'known_mungers is the full sorted set',
);
# ---- enum -----------------------------------------------------------------
{
my $c = $M->build( { munger => 'enum', map => { GET => 0, POST => 1 } } );
is( $c->('GET'), 0, 'enum maps GET' );
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' );
t/mungers.t view on Meta::CPAN
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
my @warn;
local $SIG{__WARN__} = sub { push @warn, "@_" };
local $Algorithm::ToNumberMunger::FROZEN_FREQ_MAP_WARN_KEYS = 1;
$M->build( { munger => 'frozen_freq_map', counts => { a => 1, b => 2 }, mode => 'count' } );
ok( ( grep { /bloats info\.json/ } @warn ), 'frozen_freq_map warns on oversized table' );
}
# ---- bool -----------------------------------------------------------------
{
my $c = $M->build( { munger => 'bool' } );
is( $c->('anything'), 1, 'bool truthy' );
is( $c->(0), 0, 'bool falsey' );
my $t = $M->build( { munger => 'bool', true => [qw(yes Y 1)] } );
is( $t->('yes'), 1, 'bool true-list hit' );
is( $t->('no'), 0, 'bool true-list miss' );
is( $t->(undef), 0, 'bool true-list undef' );
}
# ---- length ---------------------------------------------------------------
{
my $c = $M->build( { munger => 'length' } );
is( $c->('abcd'), 4, 'length counts characters' );
is( $c->(''), 0, 'length of empty string' );
is( $c->(undef), 0, 'length of undef is 0' );
is( $c->(12345), 5, 'length stringifies numbers' );
# character length, not byte length: "cafe" with a combined e-acute is 4.
is( $c->("caf\x{e9}"), 4, 'length is characters, not UTF-8 bytes' );
}
# ---- entropy --------------------------------------------------------------
{
my $c = $M->build( { munger => 'entropy' } );
is( $c->(''), 0, 'entropy of empty string is 0' );
is( $c->('aaaa'), 0, 'entropy of a single repeated symbol is 0' );
ok( abs( $c->('ab') - 1 ) < 1e-9, 'entropy of two equiprobable symbols is 1 bit' );
ok( abs( $c->('abcd') - 2 ) < 1e-9, 'entropy of four equiprobable symbols is 2 bits' );
# high-entropy DGA-ish name scores well above a real word.
ok( $c->('x7f3q9zk2v') > $c->('google'), 'random string out-scores a word' );
# XS and PP must agree (whichever built). can() grabs the coderef by name
# without needing symbolic references.
my $ns = 'Algorithm::ToNumberMunger';
my $pp = $ns->can('_entropy_pp');
for my $s ( '', 'a', 'ab', 'hello world', 'x7f3q9zk2v', "sn\x{f8}wman" ) {
ok( abs( $c->($s) - $pp->($s) ) < 1e-12, "entropy XS==PP for '$s'" );
}
}
# ---- ngram ------------------------------------------------------------------
{
# tiny bigram table: 'ab' common, 'ba' rare. sum 11, V 2, smoothing 1
# => denom = 11 + 1*3 = 14. si(ab) = -ln(11/14), si(ba) = -ln(2/14),
# unseen = -ln(1/14).
my $c = $M->build( { munger => 'ngram', counts => { ab => 10, ba => 1 } } );
ok( abs( $c->('ab') - -log( 11 / 14 ) ) < 1e-9, 'ngram: single common gram scores its surprisal' );
ok( abs( $c->('zz') - -log( 1 / 14 ) ) < 1e-9, 'ngram: unseen gram gets the unseen-bucket surprisal' );
ok( $c->('zzzz') > $c->('abab'), 'ngram: gibberish out-scores common grams' );
# 'aba' = grams ab, ba -> mean of the two surprisals.
ok( abs( $c->('aba') - ( -log( 11 / 14 ) + -log( 2 / 14 ) ) / 2 ) < 1e-9, 'ngram: mean over the string\'s grams' );
is( $c->('a'), 0, 'ngram: string shorter than n scores 0' );
is( $c->(''), 0, 'ngram: empty string scores 0' );
is( $c->(undef), 0, 'ngram: undef scores 0' );
is( $c->('AB'), $c->('ab'), 'ngram: fold_case lowercases by default' );
my $nofold = $M->build( { munger => 'ngram', counts => { ab => 10, ba => 1 }, fold_case => 0 } );
ok( $nofold->('AB') > $nofold->('ab'), 'ngram: fold_case => 0 keeps case distinct' );
# validation
eval { $M->build( { munger => 'ngram', counts => {} } ) };
like( $@, qr/non-empty 'counts'/, 'ngram rejects empty counts' );
eval { $M->build( { munger => 'ngram', counts => { ab => 1, xyz => 2 } } ) };
like( $@, qr/same length/, 'ngram rejects mixed-length grams' );
eval { $M->build( { munger => 'ngram', counts => { ab => 'x' } } ) };
like( $@, qr/not a non-negative number/, 'ngram rejects non-numeric counts' );
eval { $M->build( { munger => 'ngram', counts => { ab => 1 }, smoothing => 0 } ) };
like( $@, qr/'smoothing' must be a number > 0/, 'ngram rejects zero smoothing' );
eval { $M->build( { munger => 'ngram', counts => { ab => 5 }, total => 1 } ) };
like( $@, qr/must be >= sum/, 'ngram rejects total < sum' );
}
# ---- char -----------------------------------------------------------------
{
my $cnt = $M->build( { munger => 'char', class => 'non_ascii' } );
is( $cnt->('abc'), 0, 'char non_ascii count on ASCII' );
is( $cnt->("a\x{e9}b\x{ff}"), 2, 'char non_ascii counts codepoints > 127' );
my $ratio = $M->build( { munger => 'char', class => 'non_alnum', mode => 'ratio' } );
is( $ratio->('abcd'), 0, 'char non_alnum ratio, all alnum' );
is( $ratio->('ab..'), 0.5, 'char non_alnum ratio, half punct' );
is( $ratio->(''), 0, 'char ratio of empty string is 0' );
my $dig = $M->build( { munger => 'char', class => 'digit' } );
is( $dig->('a1b2c3'), 3, 'char digit count' );
# space and punct ride the regex (not tr///) so their \s / [[:punct:]]
# semantics are preserved -- cover that path.
my $sp = $M->build( { munger => 'char', class => 'space' } );
is( $sp->("a b\tc\nd"), 3, 'char space counts blank, tab, newline' );
my $pu = $M->build( { munger => 'char', class => 'punct' } );
is( $pu->('a,b.c!'), 3, 'char punct count' );
my $vo = $M->build( { munger => 'char', class => 'vowel' } );
is( $vo->('Aeixy'), 3, 'char vowel count' );
my $co = $M->build( { munger => 'char', class => 'consonant' } );
is( $co->('Aeixy'), 2, 'char consonant count (y is a consonant)' );
my $xd = $M->build( { munger => 'char', class => 'xdigit' } );
is( $xd->('deadBEEFxyz9'), 9, 'char xdigit count' );
eval { $M->build( { munger => 'char', class => 'bogus' } ) };
like( $@, qr/unknown class 'bogus'/, 'char rejects unknown class' );
eval { $M->build( { munger => 'char', class => 'digit', mode => 'nope' } ) };
like( $@, qr/'mode' must be/, 'char rejects bad mode' );
}
# ---- run --------------------------------------------------------------------
{
my $c = $M->build( { munger => 'run', class => 'consonant' } );
is( $c->('kitchen'), 3, 'run: longest consonant run in a real word' );
is( $c->('xkqvbrtn'), 8, 'run: a DGA-ish string is one long run' );
is( $c->('aeiou'), 0, 'run: no consonants at all' );
is( $c->(''), 0, 'run: empty string' );
is( $c->(undef), 0, 'run: undef is 0' );
my $d = $M->build( { munger => 'run', class => 'digit' } );
is( $d->('ab1234cd56'), 4, 'run: longest digit run' );
eval { $M->build( { munger => 'run' } ) };
like( $@, qr/requires a 'class'/, 'run requires a class' );
eval { $M->build( { munger => 'run', class => 'bogus' } ) };
like( $@, qr/unknown class 'bogus'/, 'run rejects unknown class' );
}
t/mungers.t view on Meta::CPAN
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' );
my $hr = $M->build( { munger => 'datetime', format => '%Y-%m-%dT%H:%M:%S', part => 'hour' } );
is( $hr->('2026-07-06T12:00:00'), 12, 'datetime hour part' );
my $fd = $M->build( { munger => 'datetime', format => '%Y-%m-%dT%H:%M:%S', part => 'frac_day' } );
is( $fd->('2026-07-06T12:00:00'), 0.5, 'datetime frac_day at noon' );
my $fw = $M->build( { munger => 'datetime', format => '%Y-%m-%dT%H:%M:%S', part => 'frac_week' } );
# 2026-07-05 is a Sunday (wday 0): midnight Sunday is the week origin.
is( $fw->('2026-07-05T00:00:00'), 0, 'datetime frac_week at Sunday midnight' );
# 2026-07-06 is Monday (wday 1) noon: (1*86400 + 43200)/604800.
is( $fw->('2026-07-06T12:00:00'), ( 86400 + 43200 ) / 604800, 'datetime frac_week at Monday noon' );
# cyclic parts: noon is frac_day 0.5 -> sin(pi)=0, cos(pi)=-1.
my $sd = $M->build( { munger => 'datetime', format => '%Y-%m-%dT%H:%M:%S', part => 'sin_day' } );
my $cd = $M->build( { munger => 'datetime', format => '%Y-%m-%dT%H:%M:%S', part => 'cos_day' } );
ok( abs( $sd->('2026-07-06T12:00:00') - 0 ) < 1e-9, 'sin_day at noon ~ 0' );
ok( abs( $cd->('2026-07-06T12:00:00') + 1 ) < 1e-9, 'cos_day at noon ~ -1' );
# continuity across midnight: sin/cos barely move over a one-minute wrap.
# a 60s wrap moves sin by ~2*pi*(60/86400) ~ 0.0044, vs the ~1.0 jump
# frac_day would show at the same seam.
my $near_mid_a = $sd->('2026-07-06T23:59:30');
my $near_mid_b = $sd->('2026-07-07T00:00:30');
ok( abs( $near_mid_a - $near_mid_b ) < 1e-2, 'sin_day is continuous across midnight' );
my $cw = $M->build( { munger => 'datetime', format => '%Y-%m-%dT%H:%M:%S', part => 'cos_week' } );
# Sunday midnight is frac_week 0 -> cos(0) = 1.
ok( abs( $cw->('2026-07-05T00:00:00') - 1 ) < 1e-9, 'cos_week at week origin ~ 1' );
} ## end SKIP:
# ---- hash (XS or PP; both must agree with these fixed FNV-1a values) -------
{
diag( 'hash munger path: HAVE_XS = ' . $Algorithm::ToNumberMunger::HAVE_XS );
my $raw = $M->build( { munger => 'hash' } );
# Known FNV-1a 32-bit vectors.
is( $raw->(''), 2166136261, 'fnv1a empty string' );
is( $raw->('a'), 3826002220, 'fnv1a "a"' );
is( $raw->('foobar'), 3214735720, 'fnv1a "foobar"' );
my $b = $M->build( { munger => 'hash', buckets => 100 } );
ok( $b->('anything') >= 0 && $b->('anything') < 100, 'hash respects buckets' );
# Same key + same bucket count is stable; seed decorrelates.
my $s0 = $M->build( { munger => 'hash', buckets => 1_000_000, seed => 0 } );
my $s7 = $M->build( { munger => 'hash', buckets => 1_000_000, seed => 7 } );
isnt( $s0->('shared'), $s7->('shared'), 'seed changes the hash' );
eval { $M->build( { munger => 'hash', buckets => 0 } ) };
like( $@, qr/positive integer/, 'hash rejects zero buckets' );
}
# ---- chain ------------------------------------------------------------------
{
my $tld = $M->build(
{
munger => 'chain',
steps => [ { op => 'lc' }, { op => 'split', on => '.', index => -1 } ],
then => { munger => 'length' },
}
);
is( $tld->('WWW.Example.COM'), 3, 'chain: lc + split[-1] + length takes the last label' );
is( $tld->('nodots'), 6, 'chain: split with no separator keeps the whole string' );
is( $tld->(undef), 0, 'chain: undef enters as the empty string' );
my $oob = $M->build(
{
munger => 'chain',
steps => [ { op => 'split', on => '.', index => 5 } ],
then => { munger => 'length' },
}
);
is( $oob->('a.b'), 0, 'chain: out-of-range split index yields empty' );
my $cap = $M->build(
{
munger => 'chain',
steps => [ { op => 'capture', pattern => 'req-(0x[0-9a-f]+)', ignore_case => 1 } ],
then => { munger => 'num', base => 16 },
}
);
is( $cap->('REQ-0x2F done'), 47, 'chain: capture feeds num base 16' );
my $nogroup = $M->build(
{
munger => 'chain',
steps => [ { op => 'capture', pattern => 'xyz' } ],
then => { munger => 'length' },
}
);
is( $nogroup->('xyz'), 0, 'chain: capture with no group in the pattern yields empty' );
my $norm = $M->build(
{
munger => 'chain',
steps => [ { op => 'trim' }, { op => 'uc' } ],
then => { munger => 'enum', map => { GET => 0, POST => 1 } },
}
);
is( $norm->(' post '), 1, 'chain: trim + uc normalizes into an enum' );
my $strip = $M->build(
{
munger => 'chain',
steps => [ { op => 'replace', pattern => '[0-9]' } ],
then => { munger => 'length' },
}
);
is( $strip->('a1b2c3'), 3, 'chain: replace deletes matches by default' );
my $swap = $M->build(
{
munger => 'chain',
steps =>
[ { op => 'replace', pattern => '-+', with => '.' }, { op => 'split', on => '.', index => 1 } ],
then => { munger => 'length' },
}
);
is( $swap->('ab--cdef'), 4, 'chain: replace with a literal string feeds later steps' );
# nested chain as the terminal
my $nested = $M->build(
{
munger => 'chain',
steps => [ { op => 'lc' } ],
then => {
munger => 'chain',
steps => [ { op => 'split', on => '.', index => 0 } ],
then => { munger => 'length' },
},
}
);
is( $nested->('AB.cd'), 2, 'chain: a chain can terminate in another chain' );
# build-time error surface
eval { $M->build( { munger => 'chain', then => { munger => 'length' } } ) };
like( $@, qr/non-empty 'steps'/, 'chain requires steps' );
eval { $M->build( { munger => 'chain', steps => [ { op => 'nope' } ], then => { munger => 'length' } } ) };
like( $@, qr/unknown op 'nope'/, 'chain rejects an unknown op' );
eval { $M->build( { munger => 'chain', steps => [ { op => 'lc' } ] }, 'x' ) };
like( $@, qr/requires a 'then' hashref/, 'chain requires a terminal' );
eval { $M->build( { munger => 'chain', steps => [ { op => 'lc' } ], then => { munger => 'wat' } } ) };
like( $@, qr/unknown terminal munger 'wat'/, 'chain rejects an unknown terminal' );
eval { $M->build( { munger => 'chain', steps => [ { op => 'split' } ], then => { munger => 'length' } } ) };
like( $@, qr/split step requires a non-empty 'on'/, 'chain split requires on' );
eval {
$M->build(
{ munger => 'chain', steps => [ { op => 'capture', pattern => '(' } ], then => { munger => 'length' } }
);
};
like( $@, qr/cannot compile pattern/, 'chain capture rejects a broken pattern at build time' );
eval {
$M->build( { munger => 'chain', steps => [ { op => 'lc' } ], then => { munger => 'log', base => 'x' } },
'sometag' );
};
like( $@, qr/chain terminal/, 'a bad terminal parameter names the chain terminal' );
}
# ---- ratio / combine (compile-only; the scalar path croaks with guidance) ---
{
for my $name (qw(ratio combine)) {
ok( $M->has_munger($name), "$name is a known munger" );
eval { $M->build( { munger => $name }, 'x' ) };
like( $@, qr/only usable\s+via compile\(\)/, "$name croaks with guidance on the scalar path" );
}
}
# ---- build_all + error surface -------------------------------------------
{
my $by_tag = $M->build_all(
{
method => { munger => 'enum', map => { GET => 0, POST => 1 } },
bytes => { munger => 'log', offset => 1 },
}
);
is( $by_tag->{method}->('POST'), 1, 'build_all wires method' );
is( $by_tag->{bytes}->(0), 0, 'build_all wires bytes' );
is_deeply( $M->build_all(undef), {}, 'build_all(undef) is empty' );
eval { $M->build( { munger => 'bogus' }, 'sometag' ) };
like( $@, qr/unknown munger 'bogus' for tag 'sometag'/, 'unknown munger names the tag' );
}
done_testing;
( run in 0.539 second using v1.01-cache-2.11-cpan-6aa56a78535 )