Algorithm-ToNumberMunger
view release on metacpan or search on metacpan
t/mungers.t view on Meta::CPAN
is( $qtype->('HTTPS'), 65, 'dns_qtype_enum maps HTTPS' );
is( $qtype->(28), 28, 'dns_qtype_enum passes numeric input through' );
my $sev = $M->build( { munger => 'syslog_severity_enum' } );
is( $sev->('emerg'), 0, 'syslog_severity_enum emerg' );
is( $sev->('panic'), 0, 'syslog_severity_enum panic alias' );
is( $sev->('ERROR'), 3, 'syslog_severity_enum error alias, case-insensitive' );
is( $sev->('warn'), 4, 'syslog_severity_enum warn alias' );
is( $sev->('debug'), 7, 'syslog_severity_enum debug' );
is( $sev->(6), 6, 'syslog_severity_enum passes numeric input through' );
my $fac = $M->build( { munger => 'syslog_facility_enum' } );
is( $fac->('kern'), 0, 'syslog_facility_enum kern' );
is( $fac->('security'), 4, 'syslog_facility_enum security alias for auth' );
is( $fac->('authpriv'), 10, 'syslog_facility_enum authpriv' );
is( $fac->('local0'), 16, 'syslog_facility_enum local0' );
is( $fac->('LOCAL7'), 23, 'syslog_facility_enum local7, case-insensitive' );
my $proto = $M->build( { munger => 'ip_proto_enum' } );
is( $proto->('tcp'), 6, 'ip_proto_enum tcp' );
is( $proto->('UDP'), 17, 'ip_proto_enum UDP, case-insensitive' );
is( $proto->('icmp'), 1, 'ip_proto_enum icmp' );
is( $proto->('ipv6-icmp'), 58, 'ip_proto_enum ipv6-icmp alias' );
is( $proto->('sctp'), 132, 'ip_proto_enum sctp' );
is( $proto->(47), 47, 'ip_proto_enum passes numeric input through' );
my $tls = $M->build( { munger => 'tls_version_enum' } );
is( $tls->('SSLv3'), 1, 'tls_version_enum SSLv3' );
is( $tls->('TLSv1'), 2, 'tls_version_enum TLSv1' );
is( $tls->('TLSv1.2'), 4, 'tls_version_enum TLSv1.2' );
is( $tls->('tls1.3'), 5, 'tls_version_enum tls1.3 spelling variant' );
ok( $tls->('TLSv1.2') < $tls->('TLSv1.3'), 'tls_version_enum ordinals are monotone' );
eval { $tls->('1.2') };
like(
$@,
qr/no mapping for '1\.2'/,
'tls_version_enum does NOT pass numbers through (ordinals are not a wire encoding)'
);
my $meth = $M->build( { munger => 'http_method_enum' } );
is( $meth->('GET'), 0, 'http_method_enum GET' );
is( $meth->('post'), 2, 'http_method_enum post, case-insensitive' );
is( $meth->('PATCH'), 8, 'http_method_enum PATCH' );
eval { $meth->('PROPFIND') };
like( $@, qr/no mapping for 'PROPFIND'/, 'http_method_enum croaks on an unlisted method' );
my $methd = $M->build( { munger => 'http_method_enum', default => -1 } );
is( $methd->('PROPFIND'), -1, 'http_method_enum default catches an unlisted method' );
my $sipm = $M->build( { munger => 'sip_method_enum' } );
is( $sipm->('INVITE'), 0, 'sip_method_enum INVITE' );
is( $sipm->('REGISTER'), 4, 'sip_method_enum REGISTER' );
is( $sipm->('update'), 13, 'sip_method_enum update, case-insensitive' );
my $dhcp = $M->build( { munger => 'dhcp_msgtype_enum' } );
is( $dhcp->('DISCOVER'), 1, 'dhcp_msgtype_enum DISCOVER' );
is( $dhcp->('DHCPDISCOVER'), 1, 'dhcp_msgtype_enum DHCP-prefixed form' );
is( $dhcp->('nak'), 6, 'dhcp_msgtype_enum nak, case-insensitive' );
is( $dhcp->(8), 8, 'dhcp_msgtype_enum passes numeric input through' );
eval { $M->build( { munger => 'dns_rcode_enum', default => 'nope' } ) };
like( $@, qr/'default' must be numeric/, 'named-map enum validates default at build time' );
}
# ---- scale ----------------------------------------------------------------
{
my $c = $M->build( { munger => 'scale', min => 0, max => 10 } );
is( $c->(5), 0.5, 'scale midpoint' );
is( $c->(15), 1.5, 'scale unclamped overshoot' );
my $cl = $M->build( { munger => 'scale', min => 0, max => 10, clamp => 1 } );
is( $cl->(15), 1, 'scale clamps high' );
is( $cl->(-5), 0, 'scale clamps low' );
eval { $M->build( { munger => 'scale', min => 3, max => 3 } ) };
like( $@, qr/must differ/, 'scale rejects zero range' );
}
# ---- zscore ---------------------------------------------------------------
{
my $c = $M->build( { munger => 'zscore', mean => 10, std => 2 } );
is( $c->(12), 1, 'zscore +1 sd' );
is( $c->(6), -2, 'zscore -2 sd' );
eval { $M->build( { munger => 'zscore', mean => 0, std => 0 } ) };
like( $@, qr/non-zero/, 'zscore rejects zero std' );
}
# ---- log ------------------------------------------------------------------
{
my $ln = $M->build( { munger => 'log' } );
is( $ln->(1), 0, 'ln(1) == 0' );
my $l1p = $M->build( { munger => 'log', offset => 1 } );
is( $l1p->(0), 0, 'log offset lets 0 through' );
my $l10 = $M->build( { munger => 'log', base => 10, offset => 0 } );
ok( abs( $l10->(1000) - 3 ) < 1e-9, 'log base 10 of 1000 == 3' );
eval { $ln->(0) };
like( $@, qr/must be > 0/, 'log croaks on non-positive' );
}
# ---- clamp ----------------------------------------------------------------
{
my $c = $M->build( { munger => 'clamp', min => 0, max => 100 } );
is( $c->(-5), 0, 'clamp low' );
is( $c->(250), 100, 'clamp high' );
is( $c->(50), 50, 'clamp passthrough' );
my $lo = $M->build( { munger => 'clamp', min => 0 } );
is( $lo->(-1), 0, 'clamp one-sided min' );
is( $lo->(999), 999, 'clamp one-sided leaves high alone' );
eval { $M->build( { munger => 'clamp' } ) };
like( $@, qr/at least one/, 'clamp needs a bound' );
}
# ---- num --------------------------------------------------------------------
{
my $hex = $M->build( { munger => 'num', base => 16 } );
is( $hex->('0x1a'), 26, 'num base 16 with 0x prefix' );
is( $hex->('1A'), 26, 'num base 16 bare, case-insensitive' );
t/mungers.t view on Meta::CPAN
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' );
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.
( run in 0.570 second using v1.01-cache-2.11-cpan-0b5f733616e )