view release on metacpan or  search on metacpan

t/mungers.t  view on Meta::CPAN

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

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