Algorithm-ToNumberMunger
view release on metacpan or search on metacpan
When a "work that uses the Library" uses material from a header file
that is part of the Library, the object code for the work may be a
derivative work of the Library even though the source code is not.
Whether this is true is especially significant if the work can be
linked without the Library, or if the work is itself a library. The
threshold for this to be true is not precisely defined by law.
If such an object file uses only numerical parameters, data
structure layouts and accessors, and small macros and small inline
functions (ten lines or less in length), then the use of the object
file is unrestricted, regardless of whether it is legally a derivative
work. (Executables containing this object code plus portions of the
Library will still fall under Section 6.)
Otherwise, if the work is a derivative of the Library, you may
distribute the object code for the work under the terms of Section 6.
Any executables containing that work also fall under Section 6,
whether or not they are linked directly with the Library itself.
6. As an exception to the Sections above, you may also combine or
lib/Algorithm/ToNumberMunger.pm view on Meta::CPAN
=cut
# name => builder. Each builder validates its slice of the spec up front and
# returns the per-value closure. Keeping them in a table (rather than a big
# if/elsif) is what makes known_mungers() and has_munger() cheap and honest.
my %BUILDERS = (
enum => \&_build_enum,
frozen_freq_map => \&_build_frozen_freq_map,
bool => \&_build_bool,
length => \&_build_length,
entropy => \&_build_entropy,
ngram => \&_build_ngram,
char => \&_build_char,
run => \&_build_run,
count => \&_build_count,
match => \&_build_match,
bucket => \&_build_bucket,
quantile => \&_build_quantile,
scale => \&_build_scale,
zscore => \&_build_zscore,
lib/Algorithm/ToNumberMunger.pm view on Meta::CPAN
sub build {
my ( $class, $spec, $tag ) = @_;
my $where = defined $tag ? " for tag '$tag'" : '';
croak "munger spec$where must be a hashref"
unless ref $spec eq 'HASH';
my $name = $spec->{munger};
croak "munger spec$where has no 'munger' name"
unless defined $name && length $name;
my $builder = $BUILDERS{$name}
or croak "unknown munger '$name'$where (known: " . join( ', ', $class->known_mungers ) . ')';
return $builder->( $spec, $where );
} ## end sub build
=head2 build_all
my $by_tag = ...->build_all( $info->{mungers} );
lib/Algorithm/ToNumberMunger.pm view on Meta::CPAN
my %MULTI_BUILDERS = (
datetime => \&_build_datetime_multi,
eps => \&_build_eps_multi,
chain => \&_build_chain_multi,
);
sub _build_multi {
my ( $class, $spec, $where ) = @_;
my $name = $spec->{munger};
croak "munger spec$where has no 'munger' name"
unless defined $name && length $name;
my $builder = $MULTI_BUILDERS{$name}
or croak "munger '$name'$where does not support multiple outputs "
. "('into'); only these do: "
. join( ', ', sort keys %MULTI_BUILDERS );
return $builder->( $spec, $where );
} ## end sub _build_multi
# name => builder returning the N-input closure, for the mungers that combine
# several source fields ('from' as an arrayref) into one column. The builder is
# handed the source count so arity errors surface at compile time.
my %COMBINE_BUILDERS = (
ratio => \&_build_ratio,
combine => \&_build_combine_op,
);
sub _build_combine {
my ( $class, $spec, $where, $nsrc ) = @_;
my $name = $spec->{munger};
croak "munger spec$where has no 'munger' name"
unless defined $name && length $name;
my $builder = $COMBINE_BUILDERS{$name}
or croak "munger '$name'$where does not support multiple inputs "
. "(a 'from' list); only these do: "
. join( ', ', sort keys %COMBINE_BUILDERS );
return $builder->( $spec, $where, $nsrc );
} ## end sub _build_combine
sub compile {
my ( $class, %args ) = @_;
lib/Algorithm/ToNumberMunger.pm view on Meta::CPAN
my %true = map { $_ => 1 } @{ $spec->{true} };
return sub {
my ($v) = @_;
return exists $true{ defined $v ? $v : '' } ? 1 : 0;
};
}
return sub { $_[0] ? 1 : 0 };
} ## end sub _build_bool
=head2 length
{ munger => 'length' }
The character length of the stringified input, C<undef> counting as C<0> (an
absent value is a zero-length one -- e.g. an SNI-absent TLS record). This is the
cheap shape feature behind every C<*_length> column (domain, URL, filename, SNI,
hostname, ...): tunneling and generated names run long, so raw length is a
surprisingly strong corroborator next to L</entropy>. Length is counted in
B<characters>, not bytes, so a multi-byte name is measured as a human would read
it; use L</entropy> (which is byte-oriented) when you want per-symbol randomness.
=cut
sub _build_length {
my ( $spec, $where ) = @_;
return sub {
my ($v) = @_;
return length( defined $v ? "$v" : '' );
};
}
=head2 entropy
{ munger => 'entropy' }
Shannon entropy of the input string, in B<bits per symbol> -- i.e.
C<-sum(p*log2(p))> over the frequencies of its bytes. This is the single most
common feature in the pipeline (DGA domains, randomized filenames, forged
lib/Algorithm/ToNumberMunger.pm view on Meta::CPAN
return $fn->( defined $v ? "$v" : '' );
};
}
# Pure-Perl Shannon entropy (bits), used only when the XS did not build. Byte
# view via an explicit encode so it matches the XS's SvPVutf8, and so the same
# string scores the same regardless of its internal flag.
sub _entropy_pp {
my ($str) = @_;
utf8::encode($str);
my $n = length $str;
return 0 unless $n;
my %count;
$count{$_}++ for unpack 'C*', $str;
my $ln2 = log(2);
my $h = 0;
for my $c ( values %count ) {
my $p = $c / $n;
$h -= $p * ( log($p) / $ln2 );
}
lib/Algorithm/ToNumberMunger.pm view on Meta::CPAN
# defaults: smoothing => 1, fold_case => 1; n is inferred from the keys
Mean per-gram surprisal of the input string against a B<precomputed, frozen>
n-gram count table: C<sum(-ln p(gram)) / gram_count>, each gram's probability
smoothed exactly as in L</frozen_freq_map>. This is C<frozen_freq_map>'s sequential cousin
and the strongest single gibberish detector: L</entropy> misses
I<pronounceable> generated names and is unreliable on short strings, while an
n-gram score against (say) hostname bigram statistics catches both -- real
words ride the common bigrams and score low, generated names keep hitting rare
ones and score high. Dividing by the gram count keeps scores comparable across
lengths.
C<counts> maps each n-gram to how often it was observed when the table was
built; all keys must be the same length, and that length B<is> C<n> (bigrams
are the usual choice -- a 26x26 table stays tiny in C<info.json>; past
C<$FROZEN_FREQ_MAP_WARN_KEYS> entries it warns like C<frozen_freq_map>). C<total> defaults
to the sum of counts and may be given larger to prune the tail, exactly as in
C<frozen_freq_map>. A gram absent from the table gets the smoothed unseen-bucket
probability -- an unseen gram is the interesting case -- so C<smoothing> must
be > 0 (default C<1>). With C<fold_case> (default on) the input is lowercased
before scoring, matching the usual lowercased table. A string with no grams
(shorter than C<n>) scores C<0>. Grams are taken over B<characters>, matching
L</length> rather than the byte-oriented C<entropy>.
=cut
sub _build_ngram {
my ( $spec, $where ) = @_;
my $counts = $spec->{counts};
croak "ngram munger$where requires a non-empty 'counts' hashref"
unless ref $counts eq 'HASH' && %$counts;
my $n;
my $sum = 0;
for my $g ( keys %$counts ) {
$n = length $g unless defined $n;
croak "ngram munger$where: all 'counts' keys must be the same length "
. "(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;
lib/Algorithm/ToNumberMunger.pm view on Meta::CPAN
# 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.
lib/Algorithm/ToNumberMunger.pm view on Meta::CPAN
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
{ munger => 'run', class => 'consonant' }
{ munger => 'run', class => 'digit' }
The length of the longest unbroken run of characters in a named C<class> --
the same class names L</char> recognises. Where C<char> counts how many such
characters occur in total, C<run> measures how tightly they clump: the
longest consonant run and longest digit run are staple generated-name (DGA)
features that neither total counts nor L</entropy> capture, because a real
word breaks its consonants up with vowels while a random string will happily
emit six in a row. An empty or undef input is C<0>.
=cut
# class name => a character-class pattern for the 'run' munger. Mirrors
lib/Algorithm/ToNumberMunger.pm view on Meta::CPAN
unless defined $class;
my $cc = $RUN_RE{$class}
or croak "run munger$where: unknown class '$class' (known: " . join( ', ', sort keys %RUN_RE ) . ')';
my $re = qr/((?:$cc)+)/;
return sub {
my ($v) = @_;
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)
lib/Algorithm/ToNumberMunger.pm view on Meta::CPAN
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;
lib/Algorithm/ToNumberMunger.pm view on Meta::CPAN
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': $@"
lib/Algorithm/ToNumberMunger.pm view on Meta::CPAN
: $base == 8 ? qr/\A0o/
: $base == 2 ? qr/\A0b/
: undef;
return sub {
my ($v) = @_;
my $s = defined $v ? lc "$v" : '';
my $err = "num munger$where: '" . ( defined $v ? $v : 'undef' ) . "' is not a base-$base number";
my $neg = $s =~ s/\A-//;
$s =~ s/$prefix// if defined $prefix;
croak $err unless length $s;
my $n = 0;
for my $c ( split //, $s ) {
my $d = $digit{$c};
croak $err unless defined $d && $d < $base;
$n = $n * $base + $d;
}
return $neg ? -$n : $n;
}; ## end sub
} ## end sub _build_num
lib/Algorithm/ToNumberMunger.pm view on Meta::CPAN
return $t;
},
mean => sub { my $t = 0; $t += $_ for @_; return $t / @_ },
);
sub _build_combine_op {
my ( $spec, $where, $nsrc ) = @_;
my $op = $spec->{op};
croak "combine munger$where requires an 'op' (one of: " . join( ', ', sort keys %COMBINE_OPS ) . ')'
unless defined $op && length $op;
my $fold = $COMBINE_OPS{$op}
or croak "combine munger$where: unknown op '$op' (known: " . join( ', ', sort keys %COMBINE_OPS ) . ')';
croak "combine munger$where: op 'diff' takes exactly 2 source fields, not $nsrc"
if $op eq 'diff' && $nsrc != 2;
return sub {
for my $v (@_) {
croak "combine munger$where: '" . ( defined $v ? $v : 'undef' ) . "' is not numeric"
unless looks_like_number($v);
}
lib/Algorithm/ToNumberMunger.pm view on Meta::CPAN
# it.
sub _parse_ip {
my ($s) = @_;
if ( $s =~ /\A([0-9]{1,3})\.([0-9]{1,3})\.([0-9]{1,3})\.([0-9]{1,3})\z/ ) {
return unless $1 <= 255 && $2 <= 255 && $3 <= 255 && $4 <= 255;
return ( 4, ( $1 << 24 ) | ( $2 << 16 ) | ( $3 << 8 ) | $4 );
}
if ( index( $s, ':' ) >= 0 ) {
require Socket;
my $b = eval { Socket::inet_pton( Socket::AF_INET6(), $s ) };
return ( 6, $b ) if defined $b && length $b == 16;
}
return;
} ## end sub _parse_ip
# The ip_class class names, pinned to their emitted numbers.
my %IP_CLASS = (
global => 0,
private => 1,
loopback => 2,
link_local => 3,
lib/Algorithm/ToNumberMunger.pm view on Meta::CPAN
my ($v) = @_;
my ( $fam, $p ) = _parse_ip( defined $v ? "$v" : '' );
if ($fam) {
return $IP_CLASS{ $fam == 4 ? _ip4_class($p) : _ip6_class($p) };
}
return $default if $has_default;
croak "ip_class munger$where: '" . ( defined $v ? $v : 'undef' ) . "' is not a parseable IP address";
};
} ## end sub _build_ip_class
# Build a 16-byte netmask string for an IPv6 prefix length.
sub _v6_mask {
my ($len) = @_;
my $mask = "\xff" x int( $len / 8 );
$mask .= chr( ( 0xff << ( 8 - $len % 8 ) ) & 0xff ) if $len % 8;
return $mask . ( "\0" x ( 16 - length $mask ) );
}
sub _build_cidr {
my ( $spec, $where ) = @_;
my $nets = $spec->{nets};
croak "cidr munger$where requires a non-empty 'nets' arrayref"
unless ref $nets eq 'ARRAY' && @$nets;
# [family, masked network, mask] per net; & on the 16-byte v6 strings is
lib/Algorithm/ToNumberMunger.pm view on Meta::CPAN
my $net = $nets->[$i];
croak "cidr munger$where: nets[$i] ('"
. ( defined $net ? $net : 'undef' )
. "') is not in 'address/prefix' form"
unless defined $net && $net =~ m{\A(.+)/([0-9]{1,3})\z};
my ( $addr, $len ) = ( $1, $2 );
my ( $fam, $p ) = _parse_ip($addr);
croak "cidr munger$where: nets[$i] ('$net') has an unparseable address"
unless $fam;
my $max = $fam == 4 ? 32 : 128;
croak "cidr munger$where: nets[$i] ('$net') prefix length must be 0-$max"
if $len > $max;
my $mask
= $fam == 4
? ( $len == 0 ? 0 : ( 0xffffffff << ( 32 - $len ) ) & 0xffffffff )
: _v6_mask($len);
push @match, [ $fam, $p & $mask, $mask ];
} ## end for my $i ( 0 .. $#$nets )
my $has_default = exists $spec->{default};
my $default = $spec->{default};
lib/Algorithm/ToNumberMunger.pm view on Meta::CPAN
"time_of_week": {
"munger": "datetime", "from": "timestamp",
"format": "%Y-%m-%dT%H:%M:%S",
"parts": [ "sin_week", "cos_week" ],
"into": [ "time_sin", "time_cos" ]
}
The timestamp is parsed once and both columns are filled together, so they can
never drift apart or be half-configured. C<parts> and C<into> must be the same
length. (Using C<parts> without C<into>, or C<part> with C<into>, is an error.)
B<Performance.> Two transparent accelerations, both value-identical to the plain
path: a one-slot memo returns the previous result when the same stamp string
repeats (the common case in bursty event streams); and when the format is built
from only the six numeric codes C<%Y %m %d %H %M %S> (once each, e.g.
C<%Y-%m-%dT%H:%M:%S>), parsing skips C<strptime> for a compiled regex plus
integer date math, falling back to C<strptime> for any value the regex does not
match B<or whose fields are out of range> (a month C<13>, an hour C<24>, a
C<Feb 30>) -- so an invalid stamp croaks or normalizes exactly as C<strptime>
would, never silently feeding nonsense to the date math. Like C<strptime>
lib/Algorithm/ToNumberMunger.pm view on Meta::CPAN
# Compile a strptime format into { re, idx } for the arithmetic fast path --
# idx maps field name (year/mon/...) to its capture position -- or return undef
# when the format is not fast-eligible. All six codes must appear exactly once
# so every part can be derived.
sub _compile_fast_format {
my ($format) = @_;
my $re = '';
my %idx = ();
my $n = 0;
my $rest = $format;
while ( length $rest ) {
if ( $rest =~ s/\A%(.)//s ) {
my $f = $FAST_CODE{$1} or return undef;
return undef if exists $idx{ $f->[0] };
$idx{ $f->[0] } = $n++;
$re .= '(' . $f->[1] . ')';
} elsif ( $rest =~ s/\A([^%]+)//s ) {
$re .= quotemeta($1);
} else {
return undef; # lone trailing '%' -- not fast-eligible
}
} ## end while ( length $rest )
return undef unless keys %idx == 6;
return { re => qr/\A$re\z/, idx => \%idx };
} ## end sub _compile_fast_format
# A regex match only proves each fast-path field is digits of the right width,
# not that the six of them form a real timestamp: '2026-13-01T25:00:00' matches
# the shape. Fields out of range (month 13, hour 24, Feb 30) must not reach the
# blind integer date math -- they are routed to strptime instead, which stays
# the judge of whether such a stamp croaks or normalizes (Time::Piece rolls
# Feb 30 over into March), keeping the two paths value-identical. Seconds stop
lib/Algorithm/ToNumberMunger.pm view on Meta::CPAN
# Build the parse/getter machinery for a datetime spec: ($parse, $getter_for),
# where $parse->($v) yields whatever the getters consume (a capture array on
# the fast path, a Time::Piece object otherwise) and $getter_for->($part)
# resolves a part name to a getter closure, croaking on an unknown part.
# Shared by the scalar and multi-output builders so the choice is made in
# exactly one place.
sub _datetime_engine {
my ( $format, $where ) = @_;
croak "datetime munger$where requires a strptime 'format'"
unless defined $format && length $format;
# Time::Piece is not core on the ancient perls Makefile.PL still nominally
# supports, so only pull it in for the one munger that needs it. The fast
# path keeps it loaded too: a regex mismatch falls back to strptime so the
# fast path can never reject a value the slow path would have accepted.
require Time::Piece;
my $strptime = sub {
my ($v) = @_;
my $t = eval { Time::Piece->strptime( $v, $format ) };
lib/Algorithm/ToNumberMunger.pm view on Meta::CPAN
then => { munger => 'entropy' } }
# a hex request id buried in a token like 'req-0x2F'
{ munger => 'chain',
steps => [ { op => 'capture', pattern => 'req-(0x[0-9a-fA-F]+)' } ],
then => { munger => 'num', base => 16 } }
Run the input through a list of string pre-transforms (C<steps>, applied in
order), then hand the result to a terminal munger (C<then>) for the actual
number. Every string munger above scores the I<whole> value; C<chain> is how a
feature targets a I<piece> of it -- the entropy of the TLD alone, the length
of the first path segment, an enum over a normalized token -- without asking
the writer's caller to pre-slice its input. Each step is a hashref with an
C<op>:
=over 4
=item * C<lc> / C<uc> - case-fold the value.
=item * C<trim> - strip leading and trailing whitespace.
lib/Algorithm/ToNumberMunger.pm view on Meta::CPAN
=item * C<replace> - replace every match of the regex C<pattern> with the
literal string C<with> (default: delete the matches). C<ignore_case> as above.
=back
C<then> is a full munger spec and may be any built-in that takes one value --
including another C<chain>. All step parameters and the terminal spec are
validated at build time. An undef input enters the chain as the empty string;
whether an empty result is acceptable is the terminal's call (C<entropy> and
C<length> score it C<0>, C<num> croaks).
The multi-output form works too: put C<into> on the B<chain> and the C<parts>
on the terminal, e.g. C<trim> a sloppy timestamp before a L</datetime>
C<sin>/C<cos> expansion.
=cut
# op => step builder; each validates its slice of the step spec at build time
# and returns a string-to-string closure. Steps only ever see a defined string
# (the chain entry point turns undef into '').
lib/Algorithm/ToNumberMunger.pm view on Meta::CPAN
uc => sub {
return sub { return uc $_[0] }
},
trim => sub {
return sub { my ($s) = @_; $s =~ s/\A\s+//; $s =~ s/\s+\z//; return $s };
},
split => sub {
my ( $step, $where ) = @_;
my $on = $step->{on};
croak "chain munger$where: split step requires a non-empty 'on' string"
unless defined $on && length $on;
my $idx = defined $step->{index} ? $step->{index} : 0;
croak "chain munger$where: split 'index' must be an integer"
unless $idx =~ /\A-?[0-9]+\z/;
# limit -1 keeps trailing empty pieces, so 'a.' really has two labels
# and index -1 is the empty last one, not 'a'.
return sub {
my @p = split /\Q$on\E/, $_[0], -1;
return ( $idx > $#p || $idx < -@p ) ? '' : $p[$idx];
};
},
capture => sub {
my ( $step, $where ) = @_;
my $pat = $step->{pattern};
croak "chain munger$where: capture step requires a non-empty 'pattern'"
unless defined $pat && length $pat;
my $re = eval { $step->{ignore_case} ? qr/$pat/i : qr/$pat/ };
croak "chain munger$where: cannot compile pattern '$pat': $@"
unless defined $re;
my $group = defined $step->{group} ? $step->{group} : 1;
croak "chain munger$where: capture 'group' must be a positive integer"
unless $group =~ /\A[1-9][0-9]*\z/;
# @-/@+ rather than a list-context match: a pattern with no capture
# groups returns (1) in list context, which would masquerade as a
# captured '1'; $#+ says how many groups the pattern really has.
return sub {
my ($s) = @_;
return '' unless $s =~ $re;
return '' unless $group <= $#+ && defined $-[$group];
return substr( $s, $-[$group], $+[$group] - $-[$group] );
};
},
replace => sub {
my ( $step, $where ) = @_;
my $pat = $step->{pattern};
croak "chain munger$where: replace step requires a non-empty 'pattern'"
unless defined $pat && length $pat;
my $re = eval { $step->{ignore_case} ? qr/$pat/i : qr/$pat/ };
croak "chain munger$where: cannot compile pattern '$pat': $@"
unless defined $re;
my $with = defined $step->{with} ? $step->{with} : '';
return sub { my ($s) = @_; $s =~ s/$re/$with/g; return $s };
},
);
# Compile the 'steps' list into string-to-string closures; shared by the
# scalar and multi-output chain builders.
lib/Algorithm/ToNumberMunger.pm view on Meta::CPAN
croak "chain munger$where requires a non-empty 'steps' arrayref"
unless ref $steps eq 'ARRAY' && @$steps;
my @ops;
for my $i ( 0 .. $#$steps ) {
my $step = $steps->[$i];
croak "chain munger$where: step[$i] must be a hashref"
unless ref $step eq 'HASH';
my $op = $step->{op};
croak "chain munger$where: step[$i] has no 'op'"
unless defined $op && length $op;
my $mk = $CHAIN_OPS{$op}
or croak "chain munger$where: step[$i] has unknown op '$op' (known: "
. join( ', ', sort keys %CHAIN_OPS ) . ')';
push @ops, $mk->( $step, $where );
} ## end for my $i ( 0 .. $#$steps )
return \@ops;
} ## end sub _chain_steps
# Validate and unpack the terminal spec; shared like _chain_steps.
sub _chain_terminal_spec {
my ( $spec, $where ) = @_;
my $then = $spec->{then};
croak "chain munger$where requires a 'then' hashref -- the terminal munger that produces the number"
unless ref $then eq 'HASH';
my $name = $then->{munger};
croak "chain munger$where: 'then' has no 'munger' name"
unless defined $name && length $name;
return ( $then, $name );
} ## end sub _chain_terminal_spec
sub _build_chain {
my ( $spec, $where ) = @_;
my $ops = _chain_steps( $spec, $where );
my ( $then, $name ) = _chain_terminal_spec( $spec, $where );
my $builder = $BUILDERS{$name}
or croak "chain munger$where: unknown terminal munger '$name' (known: "
lib/Algorithm/ToNumberMunger.pm view on Meta::CPAN
}
return @out;
} ## end sub _eps_txn
# Validate the spec keys shared by the scalar and multi-output eps builders.
sub _eps_spec {
my ( $spec, $where ) = @_;
my $socket = defined $spec->{socket} ? $spec->{socket} : $EPS_SOCKET;
croak "eps munger$where: 'socket' must be a non-empty path"
unless length $socket;
my $prefix = defined $spec->{prefix} ? $spec->{prefix} : '';
croak "eps munger$where: 'prefix' may not contain whitespace or control " . 'characters'
if $prefix =~ /[\s[:cntrl:]]/;
my $mark = exists $spec->{mark} ? ( $spec->{mark} ? 1 : 0 ) : 1;
my $timeout = defined $spec->{timeout} ? $spec->{timeout} : 5;
croak "eps munger$where: 'timeout' must be a positive number"
unless looks_like_number($timeout) && $timeout > 0;
lib/Algorithm/ToNumberMunger.pm view on Meta::CPAN
my @cmds
= !$mark ? ( uc $read )
: $read eq 'rate' ? ('MARKRATE')
: ( 'MARKRATE', uc $read );
return sub {
my ($v) = @_;
my $key = $prefix . ( defined $v ? "$v" : '' );
$key =~ s/[\s[:cntrl:]]/_/g;
my @replies = eval {
die "empty key\n" unless length $key;
_eps_txn( $socket, $timeout, join( '', map { "$_ $key\n" } @cmds ), scalar @cmds );
};
if ($@) {
my $err = $@;
delete $EPS_CONN{$socket}; # reconnect fresh next call
croak "eps munger$where: $err" if $on_error eq 'die';
return $on_error + 0;
}
return $replies[-1]; # the requested read is always the last reply
}; ## end sub
lib/Algorithm/ToNumberMunger.pm view on Meta::CPAN
$take[$i] = $#cmds;
}
my $n = @$parts;
my $nreplies = @cmds;
my $code = sub {
my ($v) = @_;
my $key = $prefix . ( defined $v ? "$v" : '' );
$key =~ s/[\s[:cntrl:]]/_/g;
my @replies = eval {
die "empty key\n" unless length $key;
_eps_txn( $socket, $timeout, join( '', map { "$_ $key\n" } @cmds ), $nreplies );
};
if ($@) {
my $err = $@;
delete $EPS_CONN{$socket};
croak "eps munger$where: $err" if $on_error eq 'die';
return ( $on_error + 0 ) x $n;
}
return @replies[@take];
}; ## end $code = sub
t/mungers-plan.t view on Meta::CPAN
}
},
);
};
like( $@, qr/unknown column 'nope'/, 'rejects into on an unknown column' );
# a key that is neither a tag nor an expander
eval { $M->compile( tags => ['a'], mungers => { zzz => { munger => 'log' } } ) };
like( $@, qr/is not a declared tag and has no 'into'/, 'rejects orphan key' );
# parts / into length mismatch
eval {
$M->compile(
tags => [qw(a b)],
mungers => {
g => {
munger => 'datetime',
format => $FMT,
parts => [qw(sin_week cos_week)],
into => ['a']
}
t/mungers.t view on Meta::CPAN
is_deeply(
[ $M->known_mungers ],
[
qw(aad_client_app_enum aad_signin_error_enum amavis_category_enum
app_proto_enum aws_event_type_enum aws_principal_type_enum bit bool
bucket chain char cidr clamav_result_enum clamp combine
conditional_access_result_enum count datetime dhcp_msgtype_enum
dict_enum dkim_result_enum dmarc_result_enum dns_qtype_enum
dns_rcode_enum entropy enum eps flow_reason_enum flow_state_enum
frozen_freq_map ftp_enum gemini_enum hash http_enum http_method_enum
http_version_enum ip_class ip_proto_enum kerberos_etype_enum length
log match mgcp_enum ngram nntp_enum num postfix_status_enum quantile
ratio risk_level_enum risk_state_enum rspamd_action_enum rtsp_enum
run sasl_mech_enum sasl_mech_iana_enum scale sip_enum sip_method_enum
smtp_enum spamassassin_autolearn_enum spf_result_enum
ssh_auth_method_enum suricata_action_enum syslog_facility_enum
syslog_severity_enum systemd_result_enum tcp_state_enum
tls_version_enum vpc_flow_log_status_enum
windows_impersonation_level_enum windows_integrity_level_enum
windows_logon_status_enum zscore)
],
t/mungers.t view on Meta::CPAN
my $c = $M->build( { munger => 'bool' } );
is( $c->('anything'), 1, 'bool truthy' );
is( $c->(0), 0, 'bool falsey' );
my $t = $M->build( { munger => 'bool', true => [qw(yes Y 1)] } );
is( $t->('yes'), 1, 'bool true-list hit' );
is( $t->('no'), 0, 'bool true-list miss' );
is( $t->(undef), 0, 'bool true-list undef' );
}
# ---- length ---------------------------------------------------------------
{
my $c = $M->build( { munger => 'length' } );
is( $c->('abcd'), 4, 'length counts characters' );
is( $c->(''), 0, 'length of empty string' );
is( $c->(undef), 0, 'length of undef is 0' );
is( $c->(12345), 5, 'length stringifies numbers' );
# character length, not byte length: "cafe" with a combined e-acute is 4.
is( $c->("caf\x{e9}"), 4, 'length is characters, not UTF-8 bytes' );
}
# ---- entropy --------------------------------------------------------------
{
my $c = $M->build( { munger => 'entropy' } );
is( $c->(''), 0, 'entropy of empty string is 0' );
is( $c->('aaaa'), 0, 'entropy of a single repeated symbol is 0' );
ok( abs( $c->('ab') - 1 ) < 1e-9, 'entropy of two equiprobable symbols is 1 bit' );
ok( abs( $c->('abcd') - 2 ) < 1e-9, 'entropy of four equiprobable symbols is 2 bits' );
# high-entropy DGA-ish name scores well above a real word.
t/mungers.t view on Meta::CPAN
is( $c->(undef), 0, 'ngram: undef scores 0' );
is( $c->('AB'), $c->('ab'), 'ngram: fold_case lowercases by default' );
my $nofold = $M->build( { munger => 'ngram', counts => { ab => 10, ba => 1 }, fold_case => 0 } );
ok( $nofold->('AB') > $nofold->('ab'), 'ngram: fold_case => 0 keeps case distinct' );
# validation
eval { $M->build( { munger => 'ngram', counts => {} } ) };
like( $@, qr/non-empty 'counts'/, 'ngram rejects empty counts' );
eval { $M->build( { munger => 'ngram', counts => { ab => 1, xyz => 2 } } ) };
like( $@, qr/same length/, 'ngram rejects mixed-length grams' );
eval { $M->build( { munger => 'ngram', counts => { ab => 'x' } } ) };
like( $@, qr/not a non-negative number/, 'ngram rejects non-numeric counts' );
eval { $M->build( { munger => 'ngram', counts => { ab => 1 }, smoothing => 0 } ) };
like( $@, qr/'smoothing' must be a number > 0/, 'ngram rejects zero smoothing' );
eval { $M->build( { munger => 'ngram', counts => { ab => 5 }, total => 1 } ) };
like( $@, qr/must be >= sum/, 'ngram rejects total < sum' );
}
# ---- char -----------------------------------------------------------------
{
t/mungers.t view on Meta::CPAN
eval { $strict->('192.168.1.1') };
like( $@, qr/none of the listed networks/, 'cidr croaks on no match without default' );
eval { $strict->('nope') };
like( $@, qr/not a parseable IP address/, 'cidr croaks on garbage without default' );
eval { $M->build( { munger => 'cidr', nets => [] } ) };
like( $@, qr/non-empty 'nets'/, 'cidr rejects empty nets' );
eval { $M->build( { munger => 'cidr', nets => ['10.0.0.0'] } ) };
like( $@, qr/'address\/prefix' form/, 'cidr rejects a bare address' );
eval { $M->build( { munger => 'cidr', nets => ['10.0.0.0/33'] } ) };
like( $@, qr/prefix length must be 0-32/, 'cidr rejects an oversized v4 prefix' );
eval { $M->build( { munger => 'cidr', nets => ['wat/8'] } ) };
like( $@, qr/unparseable address/, 'cidr rejects an unparseable net address' );
}
# ---- datetime -------------------------------------------------------------
SKIP: {
eval { require Time::Piece; 1 }
or skip 'Time::Piece not available', 3;
my $ep = $M->build( { munger => 'datetime', format => '%Y-%m-%dT%H:%M:%S', part => 'epoch' } );
t/mungers.t view on Meta::CPAN
eval { $M->build( { munger => 'hash', buckets => 0 } ) };
like( $@, qr/positive integer/, 'hash rejects zero buckets' );
}
# ---- chain ------------------------------------------------------------------
{
my $tld = $M->build(
{
munger => 'chain',
steps => [ { op => 'lc' }, { op => 'split', on => '.', index => -1 } ],
then => { munger => 'length' },
}
);
is( $tld->('WWW.Example.COM'), 3, 'chain: lc + split[-1] + length takes the last label' );
is( $tld->('nodots'), 6, 'chain: split with no separator keeps the whole string' );
is( $tld->(undef), 0, 'chain: undef enters as the empty string' );
my $oob = $M->build(
{
munger => 'chain',
steps => [ { op => 'split', on => '.', index => 5 } ],
then => { munger => 'length' },
}
);
is( $oob->('a.b'), 0, 'chain: out-of-range split index yields empty' );
my $cap = $M->build(
{
munger => 'chain',
steps => [ { op => 'capture', pattern => 'req-(0x[0-9a-f]+)', ignore_case => 1 } ],
then => { munger => 'num', base => 16 },
}
);
is( $cap->('REQ-0x2F done'), 47, 'chain: capture feeds num base 16' );
my $nogroup = $M->build(
{
munger => 'chain',
steps => [ { op => 'capture', pattern => 'xyz' } ],
then => { munger => 'length' },
}
);
is( $nogroup->('xyz'), 0, 'chain: capture with no group in the pattern yields empty' );
my $norm = $M->build(
{
munger => 'chain',
steps => [ { op => 'trim' }, { op => 'uc' } ],
then => { munger => 'enum', map => { GET => 0, POST => 1 } },
}
);
is( $norm->(' post '), 1, 'chain: trim + uc normalizes into an enum' );
my $strip = $M->build(
{
munger => 'chain',
steps => [ { op => 'replace', pattern => '[0-9]' } ],
then => { munger => 'length' },
}
);
is( $strip->('a1b2c3'), 3, 'chain: replace deletes matches by default' );
my $swap = $M->build(
{
munger => 'chain',
steps =>
[ { op => 'replace', pattern => '-+', with => '.' }, { op => 'split', on => '.', index => 1 } ],
then => { munger => 'length' },
}
);
is( $swap->('ab--cdef'), 4, 'chain: replace with a literal string feeds later steps' );
# nested chain as the terminal
my $nested = $M->build(
{
munger => 'chain',
steps => [ { op => 'lc' } ],
then => {
munger => 'chain',
steps => [ { op => 'split', on => '.', index => 0 } ],
then => { munger => 'length' },
},
}
);
is( $nested->('AB.cd'), 2, 'chain: a chain can terminate in another chain' );
# build-time error surface
eval { $M->build( { munger => 'chain', then => { munger => 'length' } } ) };
like( $@, qr/non-empty 'steps'/, 'chain requires steps' );
eval { $M->build( { munger => 'chain', steps => [ { op => 'nope' } ], then => { munger => 'length' } } ) };
like( $@, qr/unknown op 'nope'/, 'chain rejects an unknown op' );
eval { $M->build( { munger => 'chain', steps => [ { op => 'lc' } ] }, 'x' ) };
like( $@, qr/requires a 'then' hashref/, 'chain requires a terminal' );
eval { $M->build( { munger => 'chain', steps => [ { op => 'lc' } ], then => { munger => 'wat' } } ) };
like( $@, qr/unknown terminal munger 'wat'/, 'chain rejects an unknown terminal' );
eval { $M->build( { munger => 'chain', steps => [ { op => 'split' } ], then => { munger => 'length' } } ) };
like( $@, qr/split step requires a non-empty 'on'/, 'chain split requires on' );
eval {
$M->build(
{ munger => 'chain', steps => [ { op => 'capture', pattern => '(' } ], then => { munger => 'length' } }
);
};
like( $@, qr/cannot compile pattern/, 'chain capture rejects a broken pattern at build time' );
eval {
$M->build( { munger => 'chain', steps => [ { op => 'lc' } ], then => { munger => 'log', base => 'x' } },
'sometag' );
};
like( $@, qr/chain terminal/, 'a bad terminal parameter names the chain terminal' );
}
( run in 1.239 second using v1.01-cache-2.11-cpan-6aa56a78535 )