view release on metacpan or  search on metacpan

t/mungers.t  view on Meta::CPAN

	like( $@, qr/out of range \(10-69\)/, 'gemini_enum strict rejects an HTTP-sized code' );
	eval { $s->(9) };
	like( $@, qr/out of range \(10-69\)/, 'gemini_enum strict rejects < 10' );
}

# ---- 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' );