view release on metacpan or  search on metacpan

t/mungers.t  view on Meta::CPAN

	like( $@, qr/requires a 'mask'/, 'bit requires a mask outside popcount' );
	eval { $M->build( { munger => 'bit', mask => 0 } ) };
	like( $@, qr/must be non-zero/, 'bit rejects a zero mask' );
	eval { $M->build( { munger => 'bit', mask => 'zz' } ) };
	like( $@, qr/'mask' must be/, 'bit rejects a garbage mask' );
	eval { $M->build( { munger => 'bit', mask => 1, mode => 'nope' } ) };
	like( $@, qr/unknown mode 'nope'/, 'bit rejects bad mode' );

	# base => 16: read a bare-hex input, e.g. Suricata's tcp_flags "1b".
	my $hsyn = $M->build( { munger => 'bit', mask => '0x02', base => 16 } );
	is( $hsyn->('1b'),   1, 'bit base16: SYN set in bare-hex 1b' );
	is( $hsyn->('0x1b'), 1, 'bit base16 still accepts a 0x prefix' );
	is( $hsyn->('11'),   0, 'bit base16: "11" is hex 0x11 (no SYN), not decimal' );
	my $hpop = $M->build( { munger => 'bit', mode => 'popcount', base => 16 } );
	is( $hpop->('1b'), 4, 'bit base16 popcount of 0x1b' );
	eval { $hsyn->('zz') };
	like( $@, qr/not a non-negative integer \(hex\)/, 'bit base16 rejects non-hex, names the form' );
	eval { $M->build( { munger => 'bit', mask => 1, base => 2 } ) };
	like( $@, qr/'base' must be 10 or 16/, 'bit rejects an unsupported base' );
}

# ---- Suricata named enums ---------------------------------------------------
{
	my $ap = $M->build( { munger => 'app_proto_enum', default => -1 } );
	is( $ap->('http'),    2,  'app_proto http' );
	is( $ap->('TLS'),     $ap->('tls'), 'app_proto is case-insensitive' );
	is( $ap->('ssl'),     $ap->('tls'), 'app_proto ssl aliases tls' );
	is( $ap->('ikev2'),   $ap->('ike'), 'app_proto ikev2 aliases ike' );
	is( $ap->('unknown'), 0,  'app_proto keeps unknown as a class' );
	is( $ap->('failed'),  1,  'app_proto keeps failed as a class' );
	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' );