Algorithm-ToNumberMunger
view release on metacpan or search on metacpan
t/mungers.t view on Meta::CPAN
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' );
}
# ---- count ----------------------------------------------------------------
{
my $slashes = $M->build( { munger => 'count', of => '/' } );
is( $slashes->('/a/b/c'), 3, 'count slashes (path depth)' );
is( $slashes->('nopath'), 0, 'count with no matches' );
my $labels = $M->build( { munger => 'count', of => '.', plus => 1 } );
is( $labels->('a.b.evil.com'), 4, 'count dots + 1 (label_count)' );
is( $labels->('localhost'), 1, 'count label_count of a single label' );
# multi-char needles count non-overlapping occurrences (m//g semantics)
my $aa = $M->build( { munger => 'count', of => 'aa' } );
is( $aa->('aaaa'), 2, 'count is non-overlapping' );
is( $aa->('aaaaa'), 2, 'count leftover tail does not match' );
eval { $M->build( { munger => 'count' } ) };
like( $@, qr/non-empty 'of'/, 'count requires of' );
}
# ---- match ------------------------------------------------------------------
{
my $puny = $M->build( { munger => 'match', pattern => '^xn--' } );
is( $puny->('xn--e1afmkfd.ru'), 1, 'match bool: punycode label matches' );
is( $puny->('example.com'), 0, 'match bool: plain label does not' );
is( $puny->(undef), 0, 'match bool: undef is 0' );
my $esc = $M->build( { munger => 'match', pattern => '%[0-9A-Fa-f]{2}', mode => 'count' } );
is( $esc->('/a%20b%2e%2Ec'), 3, 'match count: percent-escapes' );
is( $esc->('/plain/path'), 0, 'match count: none' );
my $ci = $M->build( { munger => 'match', pattern => 'select', ignore_case => 1 } );
is( $ci->('SELECT * FROM'), 1, 'match ignore_case matches across case' );
eval { $M->build( { munger => 'match' } ) };
like( $@, qr/non-empty 'pattern'/, 'match requires a pattern' );
eval { $M->build( { munger => 'match', pattern => '(unclosed' } ) };
like( $@, qr/cannot compile pattern/, 'match croaks on a broken pattern at build time' );
eval { $M->build( { munger => 'match', pattern => 'x', mode => 'nope' } ) };
like( $@, qr/'mode' must be/, 'match rejects bad mode' );
}
# ---- bucket ---------------------------------------------------------------
{
my $port = $M->build( { munger => 'bucket', bounds => [ 1024, 49152 ] } );
is( $port->(80), 0, 'bucket well-known port' );
is( $port->(1023), 0, 'bucket just below first bound' );
is( $port->(1024), 1, 'bucket at first bound is registered' );
is( $port->(8080), 1, 'bucket registered port' );
is( $port->(49152), 2, 'bucket at second bound is ephemeral' );
is( $port->(60000), 2, 'bucket ephemeral port' );
eval { $M->build( { munger => 'bucket', bounds => [] } ) };
like( $@, qr/non-empty 'bounds'/, 'bucket rejects empty bounds' );
eval { $M->build( { munger => 'bucket', bounds => [ 5, 5 ] } ) };
like( $@, qr/strictly ascending/, 'bucket rejects non-ascending bounds' );
}
# ---- quantile ---------------------------------------------------------------
{
# bounds at min/p25/p50/p75/max of an imaginary training column.
my $q = $M->build( { munger => 'quantile', bounds => [ 0, 10, 100, 1000, 10000 ] } );
is( $q->(0), 0, 'quantile at the first bound is 0' );
is( $q->(-5), 0, 'quantile clamps below' );
is( $q->(10000), 1, 'quantile at the last bound is 1' );
is( $q->(999999), 1, 'quantile clamps above' );
is( $q->(10), 0.25, 'quantile at an interior bound' );
is( $q->(100), 0.5, 'quantile at the median bound' );
is( $q->(5), 0.125, 'quantile interpolates within a segment' );
is( $q->(550), 0.625, 'quantile interpolates mid-segment' );
eval { $q->('nope') };
like( $@, qr/not numeric/, 'quantile croaks on non-numeric input' );
eval { $M->build( { munger => 'quantile', bounds => [5] } ) };
like( $@, qr/at least 2/, 'quantile needs two bounds' );
eval { $M->build( { munger => 'quantile', bounds => [ 5, 5 ] } ) };
like( $@, qr/strictly ascending/, 'quantile rejects non-ascending bounds' );
}
# ---- ftp_enum -------------------------------------------------------------
{
my $c = $M->build( { munger => 'ftp_enum' } );
is( $c->(220), 2, 'ftp_enum 2yz -> 2' );
is( $c->(530), 5, 'ftp_enum 5yz -> 5' );
my $s = $M->build( { munger => 'ftp_enum', strict => 1 } );
eval { $s->(700) };
like( $@, qr/out of range \(100-599\)/, 'ftp_enum strict rejects >= 700' );
}
# ---- rtsp_enum / nntp_enum / dict_enum (more %STATUS_PROTO rows) -----------
{
for my $proto (qw(rtsp nntp dict)) {
my $c = $M->build( { munger => "${proto}_enum" } );
is( $c->(150), 1, "${proto}_enum 1xx -> 1" );
is( $c->(200), 2, "${proto}_enum 2xx -> 2" );
is( $c->(554), 5, "${proto}_enum 5xx -> 5" );
my $s = $M->build( { munger => "${proto}_enum", strict => 1 } );
is( $s->(100), 1, "${proto}_enum strict passes the low boundary" );
is( $s->(599), 5, "${proto}_enum strict passes the high boundary" );
eval { $s->(700) };
like( $@, qr/${proto}_enum munger.*out of range \(100-599\)/, "${proto}_enum strict rejects >= 700" );
} ## end for my $proto (qw(rtsp nntp dict))
}
# ---- gemini_enum (two-digit codes, divisor 10) ------------------------------
{
my $c = $M->build( { munger => 'gemini_enum' } );
is( $c->(20), 2, 'gemini_enum 20 -> 2 (success)' );
is( $c->(31), 3, 'gemini_enum 31 -> 3 (redirect)' );
is( $c->(51), 5, 'gemini_enum 51 -> 5 (not found)' );
t/mungers.t view on Meta::CPAN
# ---- mgcp_enum (custom: 8xx is valid, 6xx/7xx are the hole) -----------------
{
my $c = $M->build( { munger => 'mgcp_enum' } );
is( $c->(100), 1, 'mgcp_enum 1xx -> 1 (provisional)' );
is( $c->(200), 2, 'mgcp_enum 2xx -> 2 (success)' );
is( $c->(401), 4, 'mgcp_enum 4xx -> 4 (transient error)' );
is( $c->(510), 5, 'mgcp_enum 5xx -> 5 (permanent error)' );
is( $c->(805), 8, 'mgcp_enum 8xx -> 8 (package-specific)' );
is( $c->(700), 7, 'mgcp_enum lax lets 7xx through' );
eval { $c->('nope') };
like( $@, qr/mgcp_enum munger.*not a numeric status code/, 'mgcp_enum croaks on non-numeric' );
my $s = $M->build( { munger => 'mgcp_enum', strict => 1 } );
is( $s->(100), 1, 'mgcp_enum strict passes the low boundary' );
is( $s->(599), 5, 'mgcp_enum strict passes 599' );
is( $s->(800), 8, 'mgcp_enum strict passes 800 (8xx is real)' );
is( $s->(899), 8, 'mgcp_enum strict passes 899' );
eval { $s->(650) };
like( $@, qr/out of range \(100-599 or 800-899\)/, 'mgcp_enum strict rejects 6xx (the hole)' );
eval { $s->(700) };
like( $@, qr/out of range \(100-599 or 800-899\)/, 'mgcp_enum strict rejects 7xx (the hole)' );
eval { $s->(900) };
like( $@, qr/out of range/, 'mgcp_enum strict rejects >= 900' );
eval { $s->(99) };
like( $@, qr/out of range/, 'mgcp_enum strict rejects < 100' );
}
# ---- named-map enums --------------------------------------------------------
{
my $rcode = $M->build( { munger => 'dns_rcode_enum' } );
is( $rcode->('NXDOMAIN'), 3, 'dns_rcode_enum maps NXDOMAIN' );
is( $rcode->('noerror'), 0, 'dns_rcode_enum is case-insensitive' );
is( $rcode->('BADCOOKIE'), 23, 'dns_rcode_enum knows extended rcodes' );
is( $rcode->(3), 3, 'dns_rcode_enum passes numeric input through' );
eval { $rcode->('WAT') };
like( $@, qr/dns_rcode_enum munger.*no mapping for 'WAT'/, 'dns_rcode_enum croaks on unmapped without default' );
my $rd = $M->build( { munger => 'dns_rcode_enum', default => -1 } );
is( $rd->('WAT'), -1, 'dns_rcode_enum default for unmapped' );
is( $rd->(undef), -1, 'dns_rcode_enum default for undef' );
my $qtype = $M->build( { munger => 'dns_qtype_enum' } );
is( $qtype->('A'), 1, 'dns_qtype_enum maps A' );
is( $qtype->('aaaa'), 28, 'dns_qtype_enum maps aaaa (case-insensitive)' );
is( $qtype->('TXT'), 16, 'dns_qtype_enum maps TXT' );
is( $qtype->('NULL'), 10, 'dns_qtype_enum maps NULL' );
is( $qtype->('ANY'), 255, 'dns_qtype_enum maps ANY' );
is( $qtype->('*'), 255, 'dns_qtype_enum maps * as ANY' );
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 } ) };
t/mungers.t view on Meta::CPAN
is( $ap->('wat'), -1, 'app_proto default for unlisted' );
eval { $M->build( { munger => 'app_proto_enum' } )->(6) };
like( $@, qr/no mapping for '6'/, 'app_proto does not pass a number through' );
my $ts = $M->build( { munger => 'tcp_state_enum' } );
is( $ts->('none'), 0, 'tcp_state none' );
is( $ts->('ESTABLISHED'), 3, 'tcp_state established (case-insensitive)' );
is( $ts->('closed'), 10, 'tcp_state closed' );
ok( $ts->('syn_sent') < $ts->('established'), 'tcp_state is ordinal along the lifecycle' );
my $fs = $M->build( { munger => 'flow_state_enum' } );
is( $fs->('new'), 0, 'flow_state new' );
is( $fs->('local_bypass'), 4, 'flow_state local_bypass' );
my $fr = $M->build( { munger => 'flow_reason_enum' } );
is( $fr->('timeout'), 0, 'flow_reason timeout' );
is( $fr->('shutdown'), 2, 'flow_reason shutdown' );
my $ac = $M->build( { munger => 'suricata_action_enum' } );
is( $ac->('allowed'), 0, 'suricata_action allowed' );
is( $ac->('blocked'), 1, 'suricata_action blocked' );
is( $ac->('drop'), 3, 'suricata_action drop (IPS)' );
}
# ---- Postfix / mail named enums ---------------------------------------------
{
my $ps = $M->build( { munger => 'postfix_status_enum', default => -1 } );
is( $ps->('sent'), 0, 'postfix_status sent' );
is( $ps->('DEFERRED'), 1, 'postfix_status is case-insensitive' );
is( $ps->('bounced'), 2, 'postfix_status bounced' );
is( $ps->('undeliverable'), 5, 'postfix_status undeliverable (verify)' );
is( $ps->('whatever'), -1, 'postfix_status default for unlisted' );
ok( $ps->('sent') < $ps->('bounced'), 'postfix_status ordered sent-before-bounced' );
my $spf = $M->build( { munger => 'spf_result_enum' } );
is( $spf->('pass'), 0, 'spf pass' );
is( $spf->('softfail'), 3, 'spf softfail' );
is( $spf->('permerror'), 6, 'spf permerror' );
is( $spf->('error'), $spf->('temperror'), 'spf error aliases temperror' );
is( $spf->('unknown'), $spf->('permerror'), 'spf unknown aliases permerror' );
my $dkim = $M->build( { munger => 'dkim_result_enum' } );
is( $dkim->('pass'), 0, 'dkim pass' );
is( $dkim->('policy'), 3, 'dkim policy' );
is( $dkim->('fail'), 4, 'dkim fail' );
my $dmarc = $M->build( { munger => 'dmarc_result_enum', default => -1 } );
is( $dmarc->('pass'), 0, 'dmarc pass' );
is( $dmarc->('fail'), 2, 'dmarc fail' );
is( $dmarc->('bestguesspass'), 5, 'dmarc opendmarc bestguesspass' );
is( $dmarc->('quarantine'), -1, 'dmarc result != disposition (quarantine unlisted)' );
eval { $M->build( { munger => 'spf_result_enum' } )->(4) };
like( $@, qr/no mapping for '4'/, 'mail result enums do not pass a number through' );
}
# ---- Apache / Dovecot named enums -------------------------------------------
{
# The full mechanism set the two SASL mungers share.
my @mechs = qw(
anonymous plain login apop cram-md5 digest-md5 ntlm skey otp securid
rpa kerberos_v4 srp scram-sha-1 scram-sha-1-plus scram-sha-256
scram-sha-256-plus xoauth2 oauthbearer openid20 saml20 gssapi gs2-krb5
gss-spnego external
);
is( scalar(@mechs), 25, 'fuller SASL registry has 25 mechanisms' );
my $s = $M->build( { munger => 'sasl_mech_enum', default => -1 } );
my $i = $M->build( { munger => 'sasl_mech_iana_enum', default => -1 } );
# Both mungers cover exactly the same set, distinctly numbered.
my ( %seen_s, %seen_i, $dup_s, $dup_i );
for my $m (@mechs) {
$dup_s++ if $seen_s{ $s->($m) }++;
$dup_i++ if $seen_i{ $i->($m) }++;
isnt( $s->($m), -1, "sasl_mech knows '$m'" );
isnt( $i->($m), -1, "sasl_mech_iana knows '$m'" );
}
ok( !$dup_s, 'sasl_mech numbers are distinct' );
ok( !$dup_i, 'sasl_mech_iana numbers are distinct' );
# strength order: anonymous/cleartext low, external highest.
is( $s->('anonymous'), 0, 'sasl_mech anonymous is weakest' );
ok( $s->('plain') < $s->('scram-sha-256'), 'sasl_mech: plain weaker than scram' );
ok( $s->('scram-sha-256') < $s->('external'), 'sasl_mech: external strongest tier' );
# iana order: alphabetical, so anonymous first, xoauth2 last.
is( $i->('anonymous'), 0, 'sasl_mech_iana anonymous sorts first' );
is( $i->('xoauth2'), 24, 'sasl_mech_iana xoauth2 sorts last' );
is( $s->('CRAM-MD5'), $s->('cram-md5'), 'sasl_mech is case-insensitive' );
is( $s->('wat'), -1, 'sasl_mech default for unlisted' );
eval { $M->build( { munger => 'sasl_mech_enum' } )->(2) };
like( $@, qr/no mapping for '2'/, 'sasl_mech does not pass a number through' );
# http_version: access-log, bare, and ALPN shorthands all land together.
my $hv = $M->build( { munger => 'http_version_enum', default => -1 } );
is( $hv->('HTTP/0.9'), 0, 'http_version HTTP/0.9' );
is( $hv->('HTTP/1.1'), 2, 'http_version HTTP/1.1' );
is( $hv->('1.1'), 2, 'http_version bare 1.1' );
is( $hv->('h2'), 3, 'http_version ALPN h2' );
is( $hv->('h2c'), 3, 'http_version cleartext h2c' );
is( $hv->('2'), 3, 'http_version "2" is version 2.0, not the integer' );
is( $hv->('HTTP/3'), 4, 'http_version HTTP/3 without .0' );
is( $hv->('h3'), 4, 'http_version ALPN h3' );
ok( $hv->('HTTP/1.0') < $hv->('HTTP/2.0'), 'http_version is ordinal' );
is( $hv->('SPDY'), -1, 'http_version default for unknown' );
}
# ---- SpamAssassin / rspamd / sshd / amavis / systemd / clamav enums ---------
{
my $al = $M->build( { munger => 'spamassassin_autolearn_enum', default => -1 } );
is( $al->('no'), 0, 'sa autolearn no' );
is( $al->('HAM'), 1, 'sa autolearn is case-insensitive' );
is( $al->('spam'), 2, 'sa autolearn spam' );
is( $al->('unavailable'), 5, 'sa autolearn unavailable' );
is( $al->('bogus'), -1, 'sa autolearn default for unlisted' );
my $ra = $M->build( { munger => 'rspamd_action_enum', default => -1 } );
is( $ra->('no action'), 0, 'rspamd no action' );
is( $ra->('no_action'), 0, 'rspamd no_action underscore alias' );
is( $ra->('greylist'), 1, 'rspamd greylist' );
( run in 0.989 second using v1.01-cache-2.11-cpan-0b5f733616e )