view release on metacpan or  search on metacpan

lib/Algorithm/ToNumberMunger.pm  view on Meta::CPAN

			. "(that length is n); got '$g' alongside a $n-gram"
			unless length($g) == $n;
		my $c = $counts->{$g};
		croak "ngram munger$where: count for '$g' ('"
			. ( defined $c ? $c : 'undef' )
			. "') is not a non-negative number"
			unless looks_like_number($c) && $c >= 0;
		$sum += $c;
	} ## end for my $g ( keys %$counts )
	croak "ngram munger$where: 'counts' keys must be at least 1 character"
		unless $n >= 1;

	my $V = keys %$counts;
	carp "ngram munger$where: 'counts' has $V keys; a table this large bloats info.json"
		if $V > $FROZEN_FREQ_MAP_WARN_KEYS;

	my $total = defined $spec->{total} ? $spec->{total} : $sum;
	croak "ngram munger$where: 'total' must be numeric"
		unless looks_like_number($total);
	croak "ngram munger$where: 'total' ($total) must be >= sum of counts ($sum)"
		if $total < $sum;

	my $s = defined $spec->{smoothing} ? $spec->{smoothing} : 1;
	croak "ngram munger$where: 'smoothing' must be a number > 0 "
		. '(an unseen gram would otherwise be infinitely surprising)'
		unless looks_like_number($s) && $s > 0;

	my $fold = exists $spec->{fold_case} ? ( $spec->{fold_case} ? 1 : 0 ) : 1;

	# Same smoothed-probability scheme as frozen_freq_map, "unseen" as one extra
	# bucket; surprisal precomputed per listed gram.
	my $denom  = $total + $s * ( $V + 1 );
	my %si     = map { $_ => -log( ( $counts->{$_} + $s ) / $denom ) } keys %$counts;
	my $unseen = -log( $s / $denom );

	return sub {
		my ($v) = @_;
		my $str = defined $v ? "$v" : '';
		$str = lc $str if $fold;
		my $grams = length($str) - $n + 1;
		return 0 if $grams < 1;
		my $tot = 0;
		for my $i ( 0 .. $grams - 1 ) {
			my $g = substr( $str, $i, $n );
			$tot += exists $si{$g} ? $si{$g} : $unseen;
		}
		return $tot / $grams;
	}; ## end sub
} ## end sub _build_ngram

=head2 char

    { munger => 'char', class => 'non_alnum', mode => 'ratio' }
    { munger => 'char', class => 'non_ascii' }               # mode defaults to count

Count the characters of the input that fall in a named C<class>, either as a raw
C<count> (default) or, with C<< mode => 'ratio' >>, as a fraction of the string's
length (C<0> for an empty string). This is the injection / obfuscation detector
behind columns like C<url_non_alnum> (a I<ratio>, so it stays independent of
length) and C<filename_non_ascii> (a I<count>): payloads and homoglyph tricks
are dense with punctuation, percent-encoding, or non-ASCII where normal input is
not. Counting is over B<characters>, so C<non_ascii> means codepoints above 127.

Recognised classes: C<alnum> / C<non_alnum>, C<ascii> / C<non_ascii>, C<digit>,
C<alpha>, C<upper>, C<lower>, C<vowel>, C<consonant>, C<xdigit>, C<space>,
C<punct>. C<vowel> and C<consonant> are the ASCII letters (C<y> counting as a
consonant) -- a vowel/consonant I<ratio> is a DGA corroborator that catches
consonant-heavy random strings C<entropy> alone underrates; C<xdigit> is
C<0-9a-fA-F>, dense in encoded payloads.

=cut

# class name => a counting sub over an (already copied) string. The literal-
# range classes count with tr///, which runs at C speed -- an order of
# magnitude faster than tallying regex matches. tr/// needs its ranges spelled
# at compile time, hence one sub per class rather than a data table. The 'run'
# munger's %RUN_RE mirrors these class names; keep the two in sync.
my %CHAR_COUNT = (
	alnum     => sub { $_[0] =~ tr/A-Za-z0-9// },
	non_alnum => sub { $_[0] =~ tr/A-Za-z0-9//c },
	ascii     => sub { $_[0] =~ tr/\x00-\x7f// },
	non_ascii => sub { $_[0] =~ tr/\x00-\x7f//c },
	digit     => sub { $_[0] =~ tr/0-9// },
	alpha     => sub { $_[0] =~ tr/A-Za-z// },
	upper     => sub { $_[0] =~ tr/A-Z// },
	lower     => sub { $_[0] =~ tr/a-z// },
	vowel     => sub { $_[0] =~ tr/aeiouAEIOU// },
	consonant => sub { $_[0] =~ tr/b-df-hj-np-tv-zB-DF-HJ-NP-TV-Z// },
	xdigit    => sub { $_[0] =~ tr/0-9A-Fa-f// },
	# space and punct match richer classes (\s, [[:punct:]], including their
	# Unicode behavior) that tr/// ranges cannot reproduce; they stay on the
	# regex so their semantics do not change.
	space => sub { my $n = () = $_[0] =~ /\s/g;          $n },
	punct => sub { my $n = () = $_[0] =~ /[[:punct:]]/g; $n },
);

sub _build_char {
	my ( $spec, $where ) = @_;

	my $class = $spec->{class};
	croak "char munger$where requires a 'class'"
		unless defined $class;
	my $count = $CHAR_COUNT{$class}
		or croak "char munger$where: unknown class '$class' (known: " . join( ', ', sort keys %CHAR_COUNT ) . ')';

	my $mode = defined $spec->{mode} ? $spec->{mode} : 'count';
	croak "char munger$where: 'mode' must be 'count' or 'ratio'"
		unless $mode eq 'count' || $mode eq 'ratio';
	my $ratio = $mode eq 'ratio' ? 1 : 0;

	return sub {
		my ($v) = @_;
		my $s   = defined $v ? "$v" : '';
		my $n   = $count->($s);
		return $n unless $ratio;
		my $len = length $s;
		return $len ? $n / $len : 0;
	};
} ## end sub _build_char

=head2 run

lib/Algorithm/ToNumberMunger.pm  view on Meta::CPAN

		my $s   = defined $v ? "$v" : '';
		my $max = 0;
		while ( $s =~ /$re/g ) {
			$max = length $1 if length $1 > $max;
		}
		return $max;
	};
} ## end sub _build_run

=head2 count

    { munger => 'count', of => '/' }             # url_path_depth, topic_depth
    { munger => 'count', of => '.', plus => 1 }  # label_count (dots + 1)

Count non-overlapping occurrences of a literal substring C<of> in the input,
optionally adding a constant C<plus>. This is the segment/depth feature behind
C<url_path_depth> and C<topic_depth> (count of C<`/`>) and C<label_count> (dots
plus one). C<of> is matched literally, not as a pattern, so C<.> means a literal
dot.

=cut

sub _build_count {
	my ( $spec, $where ) = @_;

	my $of = $spec->{of};
	croak "count munger$where requires a non-empty 'of' string"
		unless defined $of && length $of;

	my $plus = defined $spec->{plus} ? $spec->{plus} : 0;
	croak "count munger$where: 'plus' must be numeric"
		unless looks_like_number($plus);

	# index() beats a global regex match here: no pattern engine, and no
	# per-call list of matches just to count them. Advancing by length($of)
	# keeps the non-overlapping semantics m//g had.
	my $oflen = length $of;
	return sub {
		my ($v) = @_;
		my $s   = defined $v ? "$v" : '';
		my $n   = 0;
		my $p   = 0;
		while ( ( $p = index( $s, $of, $p ) ) >= 0 ) {
			$n++;
			$p += $oflen;
		}
		return $n + $plus;
	}; ## end sub
} ## end sub _build_count

=head2 match

    { munger => 'match', pattern => '^xn--' }                       # punycode label
    { munger => 'match', pattern => '%[0-9A-Fa-f]{2}', mode => 'count' }

Match the input against a Perl regular expression C<pattern>: C<1>/C<0> under
the default C<< mode => 'bool' >>, or the number of non-overlapping matches
with C<< mode => 'count' >>. A true C<ignore_case> makes the match
case-insensitive. This is the catch-all shape test behind flags like "is this
label punycode" or "is the Host an IP literal", and counters like
percent-escapes in a URL -- anything L</char> and L</count> are not expressive
enough for. The pattern is compiled at build time, so a broken one fails at
C<write_info> rather than per row.

B<Trust note:> a pattern cannot execute code (Perl requires C<use re 'eval'>
for that, which this module does not enable), but a pathological pattern can
still backtrack catastrophically and stall a writer. Treat munger specs --
like the rest of C<info.json> -- as configuration from a trusted operator,
not as untrusted input.

=cut

sub _build_match {
	my ( $spec, $where ) = @_;

	my $pat = $spec->{pattern};
	croak "match munger$where requires a non-empty 'pattern'"
		unless defined $pat && length $pat;

	my $mode = defined $spec->{mode} ? $spec->{mode} : 'bool';
	croak "match munger$where: 'mode' must be 'bool' or 'count'"
		unless $mode eq 'bool' || $mode eq 'count';

	# qr// on spec text cannot run code -- (?{...}) needs 'use re "eval"',
	# which is not enabled here -- but it can be syntactically invalid, so
	# compile eagerly and croak at build time.
	my $re = eval { $spec->{ignore_case} ? qr/$pat/i : qr/$pat/ };
	croak "match munger$where: cannot compile pattern '$pat': $@"
		unless defined $re;

	if ( $mode eq 'bool' ) {
		return sub {
			my $s = defined $_[0] ? "$_[0]" : '';
			return $s =~ $re ? 1 : 0;
		};
	}
	return sub {
		my $s = defined $_[0] ? "$_[0]" : '';
		my $n = () = $s =~ /$re/g;
		return $n;
	};
} ## end sub _build_match

=head2 bucket

    { munger => 'bucket', bounds => [ 1024, 49152 ] }   # dest_port classes

Map a number to a bucket index by ascending C<bounds>: the result is how many
bounds the value is greater than or equal to. With C<< bounds => [1024, 49152] >>
a value under C<1024> is C<0> (well-known), C<1024>-C<49151> is C<1> (registered),
and C<49152>+ is C<2> (ephemeral) -- the classic port classing, where the literal
port number is meaningless to a threshold split but the I<class> is a real
signal. C<bounds> must be strictly ascending; N bounds yield indices C<0>..C<N>.

This generalises the C<*_enum> status-class mungers, which are the special case
of bucketing a reply code by its leading digit.

=cut

sub _build_bucket {
	my ( $spec, $where ) = @_;