Algorithm-ToNumberMunger
view release on metacpan or search on metacpan
lib/Algorithm/ToNumberMunger.pm view on Meta::CPAN
my $code = Algorithm::ToNumberMunger->build(
{ munger => 'enum', map => { GET => 0, POST => 1, PUT => 2 } },
);
my $n = $code->('POST'); # 1
# a whole table of them at once, from a 'field => spec' hash
my $by_tag = Algorithm::ToNumberMunger->build_all(
\%mungers,
);
my $row_value = $by_tag->{method}->($raw{method});
=head1 DESCRIPTION
Many numeric pipelines -- anomaly detectors, feature stores, CSV loaders --
want every column to be a number, but the values they are handed are not always
numbers to begin with: an HTTP method is a string, a timestamp is a formatted
date, a high-cardinality label wants bucketing. An B<input munger> turns such a
raw value into a single number. Munging happens on the input side, before a row
is stored.
Mungers are declared as a plain data spec -- a hash naming a built-in munger and
carrying that munger's parameters -- so a table of them can be read straight out
of JSON or a config file:
{
"method": { "munger": "enum", "map": { "GET": 0, "POST": 1 } },
"bytes": { "munger": "log", "offset": 1 },
"label": { "munger": "hash", "buckets": 1024 }
}
B<Any field without an entry is raw> and is passed through unchanged; this module
is only concerned with fields that name a munger.
This class does not read or write files. It B<compiles> a spec into a closure
that maps one raw value to one number, so a caller can build its mungers once
from configuration and then apply them per row with no re-parsing. All
configuration errors are caught at build time; the returned closure only croaks
on genuinely un-mungeable I<input>.
=head1 CLASS METHODS
=head2 build
my $code = ...->build( \%spec );
my $code = ...->build( \%spec, $tag_name ); # $tag_name only sharpens errors
Compile a single munger spec into a coderef. C<%spec> must contain a C<munger>
key naming one of the L</BUILT-IN MUNGERS>; the remaining keys are that munger's
parameters. Croaks on an unknown munger name or an invalid parameter set. The
optional second argument is only used to make error messages point at a tag.
=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,
log => \&_build_log,
clamp => \&_build_clamp,
num => \&_build_num,
bit => \&_build_bit,
ip_class => \&_build_ip_class,
cidr => \&_build_cidr,
datetime => \&_build_datetime,
hash => \&_build_hash,
chain => \&_build_chain,
eps => \&_build_eps,
mgcp_enum => \&_build_mgcp_enum,
);
# Status-class mungers (http_enum, smtp_enum, sip_enum, ...) are one transform
# -- collapse a numeric reply code to its leading digit, int(code/div), with a
# divisor of 100 (10 for gemini's two-digit codes) -- differing only in which
# range 'strict' accepts. Register them all from this table so a new protocol
# is a single line and they can never drift apart. mgcp_enum is deliberately
# NOT a row here: its strict range has a hole (8xx exists, 6xx/7xx do not),
# which a single [lo, hi] cannot express, so it has its own builder below.
my %STATUS_PROTO = (
http => [ 100, 599 ], # 1xx-5xx
smtp => [ 200, 599 ], # 2xx-5xx; SMTP never issues 1yz in practice
sip => [ 100, 699 ], # 1xx-6xx; SIP adds a 6xx global-failure class
ftp => [ 100, 599 ], # 1xx-5xx FTP reply codes
rtsp => [ 100, 599 ], # RTSP (RFC 2326) reuses HTTP's status scheme
nntp => [ 100, 599 ], # 1xx-5xx NNTP (RFC 3977), SMTP-convention codes
dict => [ 100, 599 ], # DICT (RFC 2229) uses SMTP-style codes
gemini => [ 10, 69, 10 ], # two-digit codes, 1x-6x; class = int(code/10)
);
for my $proto ( keys %STATUS_PROTO ) {
my ( $lo, $hi, $div ) = @{ $STATUS_PROTO{$proto} };
$div = 100 unless defined $div;
$BUILDERS{"${proto}_enum"}
= sub { _status_class_munger( $proto, $lo, $hi, $div, @_ ) };
}
# ratio and combine consume several source fields at once, so they are only
# buildable through compile()'s multi-input form ('from' as an arrayref) -- a
# scalar build can never hand them more than one value. Registering a stub
# keeps known_mungers() honest and turns "used it as a scalar munger" into a
# pointed error instead of an unknown-munger one.
for my $name (qw(ratio combine)) {
$BUILDERS{$name} = sub {
my ( $spec, $where ) = @_;
croak "$name munger$where combines several inputs; it is only usable "
. "via compile() with 'from' as an arrayref of source fields";
};
}
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} );
Compile a whole C<mungers> hash (tag name => spec) into a hash of tag name =>
coderef. A false/absent argument yields an empty hashref (every tag is raw).
Croaks if any spec is invalid, naming the offending tag.
=cut
sub build_all {
my ( $class, $mungers ) = @_;
return {} unless $mungers;
croak "'mungers' must be a hashref"
unless ref $mungers eq 'HASH';
my %by_tag;
for my $tag ( keys %$mungers ) {
$by_tag{$tag} = $class->build( $mungers->{$tag}, $tag );
}
return \%by_tag;
} ## end sub build_all
=head2 compile
my $plan = ...->compile( tags => \@tags, mungers => $info->{mungers} );
my $row = $plan->apply_named( \%named_input ); # numbers, in tags order
Compile a set's C<tags> and (optional) C<mungers> into a B<plan> object that maps
one input record to a fully-numeric row in tag order. Unlike L</build_all> (which
just compiles each spec in isolation), C<compile> understands the whole set:
=over 4
=item * a scalar munger, keyed by its output tag, fills that one column; its
input is read from the tag's own name, or from C<< from => 'other' >> to alias a
source field;
=item * an B<expanding> munger, keyed by any label and carrying C<< into =>
[tag, ...] >>, reads one source (C<from>, defaulting to the label) and fills
several columns at once -- this is how a single timestamp becomes both a
C<sin>/C<cos> pair without the two ever drifting apart (see L</datetime>);
=item * a B<combining> munger, keyed by its output tag and carrying a C<from>
B<list> (C<< from => ['bytes_out', 'bytes_in'] >>), reads several source
fields and fills that one column -- this is how a ratio becomes a single
feature without precomputing it upstream (see L</ratio> and L</combine>). The
sources are raw input fields, not other (possibly munged) columns;
=item * every remaining tag is B<raw> and passed through unchanged.
=back
Coverage is validated up front: C<compile> croaks if two mungers write the same
column, if an C<into> names a column not in C<tags>, if a munger key is neither a
tag nor an expander, if an expander's output count does not match its C<into>,
or if a C<from> list is given to a munger that cannot combine inputs. The
returned plan has two methods, both returning an arrayref of numbers in C<tags>
order: C<apply_named(\%hash)> (keyed by field name, the only form that supports
expanders and combiners) and C<apply_positional(\@row)> (positional; croaks if
the set has any expanding or combining munger, since a shared or combined
source cannot be expressed by position).
=cut
# name => builder returning ($list_returning_code, $arity), for the mungers that
# can fan one input out into several columns via 'into'.
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 ) = @_;
my $tags = $args{tags};
croak "compile requires a non-empty 'tags' arrayref"
unless ref $tags eq 'ARRAY' && @$tags;
my $mungers = $args{mungers} || {};
croak "compile: 'mungers' must be a hashref"
unless ref $mungers eq 'HASH';
my %pos;
for my $i ( 0 .. $#$tags ) {
croak "compile: duplicate tag '$tags->[$i]'"
if exists $pos{ $tags->[$i] };
$pos{ $tags->[$i] } = $i;
}
my ( @scalar, @expand, @combine, %claimed );
my $claim = sub {
my ( $tag, $by ) = @_;
croak "munger '$by' targets unknown column '$tag'"
unless exists $pos{$tag};
croak "two mungers write column '$tag'"
if $claimed{$tag}++;
};
for my $key ( sort keys %$mungers ) {
my $spec = $mungers->{$key};
croak "munger '$key' spec must be a hashref"
unless ref $spec eq 'HASH';
my $from = defined $spec->{from} ? $spec->{from} : $key;
if ( ref $from eq 'ARRAY' ) {
croak "munger '$key': a 'from' list needs at least 2 source fields"
unless @$from >= 2;
croak "munger '$key': 'into' cannot be combined with a 'from' list"
if defined $spec->{into};
croak "munger '$key' is not a declared tag and has no 'into'"
unless exists $pos{$key};
my $code = $class->_build_combine( $spec, " for '$key'", scalar @$from );
$claim->( $key, $key );
push @combine, { tag => $key, from => [@$from], code => $code };
} elsif ( defined $spec->{into} ) {
my $into = $spec->{into};
croak "munger '$key': 'into' must be a non-empty arrayref"
unless ref $into eq 'ARRAY' && @$into;
my ( $code, $arity ) = $class->_build_multi( $spec, " for '$key'" );
croak "munger '$key' produces $arity value(s) but 'into' lists " . scalar(@$into)
unless $arity == @$into;
$claim->( $_, $key ) for @$into;
push @expand, { from => $from, into => [@$into], code => $code };
} else {
croak "munger '$key' is not a declared tag and has no 'into'"
lib/Algorithm/ToNumberMunger.pm view on Meta::CPAN
notapplied => 1,
notenabled => 2,
reportonly => 3,
failure => 4,
},
},
);
for my $name ( keys %NAMED_ENUM ) {
my $e = $NAMED_ENUM{$name};
$BUILDERS{"${name}_enum"} = sub { _named_enum_munger( $name, $e, @_ ) };
}
# Shared closure for the named-map enums registered from %NAMED_ENUM.
sub _named_enum_munger {
my ( $name, $e, $spec, $where ) = @_;
my $has_default = exists $spec->{default};
my $default = $spec->{default};
croak "${name}_enum munger$where: 'default' must be numeric"
if $has_default && !looks_like_number($default);
my ( $map, $numeric ) = @{$e}{qw(map numeric)};
return sub {
my ($v) = @_;
if ( defined $v ) {
return $v + 0 if $numeric && looks_like_number($v);
my $k = lc $v;
return $map->{$k} if exists $map->{$k};
}
return $default if $has_default;
croak "${name}_enum munger$where: no mapping for '" . ( defined $v ? $v : 'undef' ) . "'";
}; ## end sub
} ## end sub _named_enum_munger
=head2 bool
{ munger => 'bool' } # Perl truthiness -> 1/0
{ munger => 'bool', true => [ 'yes', 'Y', '1', 'true' ] }
Coerce to C<1> or C<0>. With a C<true> list, only those (string-compared) values
are C<1>; otherwise ordinary Perl truthiness is used.
=cut
sub _build_bool {
my ( $spec, $where ) = @_;
if ( exists $spec->{true} ) {
croak "bool munger$where: 'true' must be an arrayref"
unless ref $spec->{true} eq 'ARRAY';
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
User-Agents, generated SNIs / hostnames / principal names), because
machine-generated strings spread their characters far more evenly than
human-chosen ones and so score high, while a real word scores low. An empty
string is C<0>; the maximum is C<8> (every byte value equally likely).
Entropy is computed over the string's B<UTF-8 bytes> (matching L</hash>), so the
value is well-defined regardless of the scalar's internal encoding flag. Like
C<hash>, this munger is XS-accelerated -- a per-byte histogram plus a C<log> per
distinct byte -- with a pure-Perl fallback that produces identical values;
C<$Algorithm::ToNumberMunger::HAVE_XS> says which
is in use.
=cut
sub _build_entropy {
my ( $spec, $where ) = @_;
my $fn = $HAVE_XS ? \&_entropy_xs : \&_entropy_pp;
return sub {
my ($v) = @_;
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 );
}
return $h;
} ## end sub _entropy_pp
=head2 ngram
{ munger => 'ngram', counts => { th => 152, he => 128, in => 94, ... } }
# 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;
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
{ 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
# %CHAR_COUNT's class names (keep in sync); runs need a regex quantifier, so
# tr///'s speed trick does not apply here.
my %RUN_RE = (
alnum => '[A-Za-z0-9]',
non_alnum => '[^A-Za-z0-9]',
ascii => '[\x00-\x7f]',
non_ascii => '[^\x00-\x7f]',
digit => '[0-9]',
alpha => '[A-Za-z]',
upper => '[A-Z]',
lower => '[a-z]',
vowel => '[aeiouAEIOU]',
consonant => '[b-df-hj-np-tv-zB-DF-HJ-NP-TV-Z]',
xdigit => '[0-9A-Fa-f]',
space => '\s',
punct => '[[:punct:]]',
);
sub _build_run {
my ( $spec, $where ) = @_;
my $class = $spec->{class};
croak "run munger$where requires a 'class'"
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)
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 ) = @_;
my $bounds = $spec->{bounds};
croak "bucket munger$where requires a non-empty 'bounds' arrayref"
unless ref $bounds eq 'ARRAY' && @$bounds;
my @b = @$bounds;
for my $i ( 0 .. $#b ) {
croak "bucket munger$where: bound[$i] ('" . ( defined $b[$i] ? $b[$i] : 'undef' ) . "') is not numeric"
unless looks_like_number( $b[$i] );
croak "bucket munger$where: 'bounds' must be strictly ascending"
if $i && $b[$i] <= $b[ $i - 1 ];
}
return sub {
my ($v) = @_;
croak "bucket munger$where: '" . ( defined $v ? $v : 'undef' ) . "' is not numeric"
unless looks_like_number($v);
lib/Algorithm/ToNumberMunger.pm view on Meta::CPAN
if $have_min && $have_max && $min > $max;
return sub {
my ($v) = @_;
croak "clamp munger$where: '" . ( defined $v ? $v : 'undef' ) . "' is not numeric"
unless looks_like_number($v);
$v = $min if $have_min && $v < $min;
$v = $max if $have_max && $v > $max;
return $v;
};
} ## end sub _build_clamp
=head2 num
{ munger => 'num', base => 16 } # '0x1a' or '1a' -> 26
{ munger => 'num' } # plain numeric coercion
Parse a string as a number in C<base> (2-36, default 10). Base 10 simply
validates and numifies. Other bases accept the digits C<0-9a-z> below the
base, case-insensitively, an optional leading C<->, and the conventional
prefix for that base (C<0x> for 16, C<0b> for 2, C<0o> for 8). Plenty of
tooling logs flag words and IDs in hex (C<0x2f>), which the Writer would
reject as non-numeric; this munger is the bridge. Croaks on anything that is
not a clean number in the chosen base.
=cut
sub _build_num {
my ( $spec, $where ) = @_;
my $base = defined $spec->{base} ? $spec->{base} : 10;
croak "num munger$where: 'base' must be an integer from 2 to 36"
unless $base =~ /\A[0-9]+\z/ && $base >= 2 && $base <= 36;
if ( $base == 10 ) {
return sub {
my ($v) = @_;
croak "num munger$where: '" . ( defined $v ? $v : 'undef' ) . "' is not numeric"
unless looks_like_number($v);
return $v + 0;
};
}
my %digit;
my $i = 0;
$digit{$_} = $i++ for ( '0' .. '9', 'a' .. 'z' );
# Strip only the base's own conventional prefix; for other bases a letter
# like 'b' is just a digit, so there is nothing to disambiguate.
my $prefix
= $base == 16 ? qr/\A0x/
: $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
=head2 ratio
# 'io_ratio' is a tag; bytes_out and bytes_in are input fields
"io_ratio": { "munger": "ratio", "from": ["bytes_out", "bytes_in"] }
{ munger => 'ratio', from => [qw(bytes_out bytes_in)], zero => -1 }
First source divided by the second: with C<< from => [a, b] >> the column gets
C<a / b>. Asymmetry between two counters is a classic feature the counters
alone cannot express -- bytes out over bytes in flags exfiltration, requests
over responses flags scanning -- and the division has to happen at munge time
because a forest split only ever sees one column. A zero denominator yields
C<zero> (default C<0>) instead of dying, since "nothing came back" is a
legitimate row, not bad input; pick a C<zero> outside the ratio's normal range
if you want those rows to stand out. Both inputs must be numeric.
This is a B<multi-input> munger: it only makes sense with several sources, so
it is only usable through L</compile> with C<from> as an arrayref of exactly
two field names (and thus C<apply_named> / C<write_named>). The sources are
raw input fields, not other columns.
=head2 combine
{ munger => 'combine', op => 'sum', from => [qw(bytes_in bytes_out)] }
{ munger => 'combine', op => 'max', from => [qw(req_time resp_time)] }
Fold two or more numeric source fields into one column with C<op>: C<sum>,
C<diff> (first minus second; exactly two sources), C<product>, C<min>, C<max>,
or C<mean>. The general-purpose sibling of L</ratio> for when the interesting
feature is a total, a gap, or an extreme across fields rather than any one
field. Every input must be numeric.
Like C<ratio>, this is a B<multi-input> munger: only usable through
L</compile> with C<from> as an arrayref of source field names.
=cut
sub _build_ratio {
my ( $spec, $where, $nsrc ) = @_;
croak "ratio munger$where takes exactly 2 source fields (numerator, denominator), not $nsrc"
unless $nsrc == 2;
my $zero = defined $spec->{zero} ? $spec->{zero} : 0;
croak "ratio munger$where: 'zero' must be numeric"
unless looks_like_number($zero);
return sub {
for my $v (@_) {
croak "ratio munger$where: '" . ( defined $v ? $v : 'undef' ) . "' is not numeric"
unless looks_like_number($v);
}
return $zero if $_[1] == 0;
return $_[0] / $_[1];
};
} ## end sub _build_ratio
# op => fold over the already numeric-checked source values. A table so the
# error message can enumerate them and a new op is one line.
my %COMBINE_OPS = (
sum => sub { my $t = 0; $t += $_ for @_; return $t },
diff => sub { return $_[0] - $_[1] },
product => sub { my $t = 1; $t *= $_ for @_; return $t },
min => sub {
my $t = shift;
for (@_) { $t = $_ if $_ < $t }
return $t;
},
max => sub {
my $t = shift;
for (@_) { $t = $_ if $_ > $t }
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);
}
return $fold->(@_);
};
} ## end sub _build_combine_op
=head2 bit
{ munger => 'bit', mask => '0x12' } # SYN or ACK set?
{ munger => 'bit', mask => '0x02', mode => 'all' } # the SYN bit itself
{ munger => 'bit', mode => 'popcount' } # how many flags at all
{ munger => 'bit', mask => '0x0f', mode => 'value' } # low nibble, 0-15
{ munger => 'bit', mask => '0x02', base => 16 } # Suricata tcp_flags "1b"
Bit-level features from an integer flags word (TCP flags, DNS header flags,
protocol option words): the raw word is meaningless to a threshold split, but
individual bits and bit I<counts> are real signals. The input must be a
non-negative integer, in decimal or C<0x> hex (so a logged C<0x12> works
as-is); C<mask> may be written either way too.
Set C<< base => 16 >> to read the B<input> as bare hexadecimal with no C<0x>
prefix -- Suricata logs C<tcp.tcp_flags> (and C<tcp_flags_ts>/C<tcp_flags_tc>)
as e.g. C<"1b">, which is otherwise ambiguous with decimal. A C<0x> prefix on
the input is still accepted under C<< base => 16 >>. C<mask> is always written
in decimal or C<0x> hex regardless of C<base>. Modes:
=over 4
=item * C<any> (default) - C<1> if any bit of C<mask> is set in the value.
=item * C<all> - C<1> only if every bit of C<mask> is set.
=item * C<value> - the masked bits, shifted down to the mask's lowest set
bit: C<< mask => '0x0f' >> extracts the low nibble as C<0>-C<15>.
=item * C<popcount> - the number of set bits in C<value & mask>; C<mask> is
optional here and defaults to all bits. An abnormal flag I<count> (a
Christmas-tree packet) is anomalous even when each individual bit is common.
=back
C<mask> is required (and must be non-zero) for every mode except C<popcount>.
=cut
my %BIT_MODE = map { $_ => 1 } qw(any all value popcount);
# Accept an integer in decimal or 0x-hex form; returns the number, or undef
# if it is neither. Shared by bit's mask (spec) and value (input) parsing.
sub _bit_int {
my ($v) = @_;
return undef unless defined $v;
lib/Algorithm/ToNumberMunger.pm view on Meta::CPAN
=head2 ip_class
{ munger => 'ip_class' }
{ munger => 'ip_class', default => -1 }
Collapse an IPv4 or IPv6 address to its address-space class -- to addresses
what the status-class enums are to reply codes: the literal address is
high-cardinality noise, but "an internal host suddenly talking multicast" is
a class-level signal. Classes and their emitted numbers:
0 global anything not covered below
1 private 10/8, 172.16/12, 192.168/16, 100.64/10 (CGNAT), fc00::/7 (ULA)
2 loopback 127/8, ::1
3 link_local 169.254/16, fe80::/10
4 multicast 224/4, ff00::/8
5 broadcast 255.255.255.255
6 unspecified 0.0.0.0, ::
7 reserved 0/8, 192.0.0/24, the documentation nets (192.0.2/24,
198.51.100/24, 203.0.113/24, 2001:db8::/32), benchmarking
(198.18/15), 240/4, and the 100::/64 discard prefix
An IPv4-mapped IPv6 address (C<::ffff:a.b.c.d>) is classified as its embedded
IPv4 address. An unparseable input croaks, or yields the numeric C<default>
when one is given. IPv6 parsing uses L<Socket>'s C<inet_pton>, loaded lazily
the way L</datetime> loads Time::Piece. For B<site-specific> zones (DMZ,
server VLAN, guest Wi-Fi) use L</cidr>, which knows your networks instead of
the RFCs'.
=head2 cidr
{ munger => 'cidr',
nets => [ '10.10.0.0/16', '10.20.0.0/16', '2001:db8:5::/48' ],
default => -1 }
Membership in a list of CIDR networks: the result is the (0-based) index of
the B<first> net in C<nets> containing the address -- L</bucket> for address
space, and the way a site encodes its own zones (DMZ vs. server VLAN vs.
guest Wi-Fi) that L</ip_class>'s generic RFC classes cannot know about.
C<nets> may mix IPv4 and IPv6; an address is only tested against nets of its
own family. Overlapping nets are fine -- list the most specific first, since
the first match wins. An input that is unparseable or in none of the listed
nets croaks, or yields the numeric C<default> when one is given (a catch-all
C<default> is the usual configuration).
=cut
# Parse an IP address string: (4, $int) for IPv4, (6, $bytes16) for IPv6, or
# an empty list for neither. v4 goes through a regex (also pinning the
# dotted-quad form, so inet_pton's odd shorthands never sneak in); v6 leans
# on Socket's inet_pton, loaded lazily so no munger that skips IPs pays for
# 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,
multicast => 4,
broadcast => 5,
unspecified => 6,
reserved => 7,
);
sub _ip4_class {
my ($n) = @_;
return 'unspecified' if $n == 0;
return 'broadcast' if $n == 0xffffffff;
my $a = $n >> 24;
my $b = ( $n >> 16 ) & 0xff;
my $c = ( $n >> 8 ) & 0xff;
return 'reserved' if $a == 0; # 0/8 "this network"
return 'private' if $a == 10;
return 'private' if $a == 100 && $b >= 64 && $b <= 127; # CGNAT 100.64/10
return 'loopback' if $a == 127;
return 'link_local' if $a == 169 && $b == 254;
return 'private' if $a == 172 && $b >= 16 && $b <= 31;
return 'reserved' if $a == 192 && $b == 0 && ( $c == 0 || $c == 2 );
return 'private' if $a == 192 && $b == 168;
return 'reserved' if $a == 198 && ( $b == 18 || $b == 19 ); # benchmarking
return 'reserved' if $a == 198 && $b == 51 && $c == 100; # TEST-NET-2
return 'reserved' if $a == 203 && $b == 0 && $c == 113; # TEST-NET-3
return 'multicast' if $a >= 224 && $a <= 239;
return 'reserved' if $a >= 240; # 240/4 future use
return 'global';
} ## end sub _ip4_class
sub _ip6_class {
my ($bytes) = @_;
my @o = unpack 'C16', $bytes;
my $lead0 = 1;
for my $i ( 0 .. 14 ) { $lead0 &&= $o[$i] == 0 }
if ($lead0) {
return 'unspecified' if $o[15] == 0;
return 'loopback' if $o[15] == 1;
}
# v4-mapped ::ffff:a.b.c.d -- classify as the embedded v4 address.
my $map = 1;
for my $i ( 0 .. 9 ) { $map &&= $o[$i] == 0 }
return _ip4_class( ( $o[12] << 24 ) | ( $o[13] << 16 ) | ( $o[14] << 8 ) | $o[15] )
if $map && $o[10] == 0xff && $o[11] == 0xff;
return 'multicast' if $o[0] == 0xff;
return 'private' if ( $o[0] & 0xfe ) == 0xfc; # ULA fc00::/7
return 'link_local' if $o[0] == 0xfe && ( $o[1] & 0xc0 ) == 0x80; # fe80::/10
return 'reserved' if $o[0] == 0x20 && $o[1] == 0x01 && $o[2] == 0x0d && $o[3] == 0xb8; # 2001:db8::/32
my $discard = $o[0] == 0x01; # 100::/64
for my $i ( 1 .. 7 ) { $discard &&= $o[$i] == 0 }
return 'reserved' if $discard;
return 'global';
} ## end sub _ip6_class
sub _build_ip_class {
my ( $spec, $where ) = @_;
my $has_default = exists $spec->{default};
my $default = $spec->{default};
croak "ip_class munger$where: 'default' must be numeric"
if $has_default && !looks_like_number($default);
return sub {
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
# Perl's bitwise string AND, so both families match the same way.
my @match;
for my $i ( 0 .. $#$nets ) {
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};
croak "cidr munger$where: 'default' must be numeric"
if $has_default && !looks_like_number($default);
return sub {
my ($v) = @_;
my ( $fam, $p ) = _parse_ip( defined $v ? "$v" : '' );
if ($fam) {
for my $i ( 0 .. $#match ) {
my ( $f, $network, $mask ) = @{ $match[$i] };
next unless $f == $fam;
return $i
if $fam == 4
? ( ( $p & $mask ) == $network )
: ( ( $p & $mask ) eq $network );
}
return $default if $has_default;
croak "cidr munger$where: '$v' is in none of the listed networks (and no 'default')";
} ## end if ($fam)
return $default if $has_default;
croak "cidr munger$where: '" . ( defined $v ? $v : 'undef' ) . "' is not a parseable IP address";
}; ## end sub
} ## end sub _build_cidr
=head2 datetime
{ munger => 'datetime', format => '%Y-%m-%dT%H:%M:%S', part => 'epoch' }
{ munger => 'datetime', format => '%Y-%m-%d %H:%M:%S', part => 'hour' }
Parse a formatted timestamp with L<Time::Piece> (C<strptime>, so C<format> is a
standard strptime pattern) and extract one numeric C<part>:
=over 4
=item * C<epoch> (default) - seconds since the epoch.
=item * C<year>, C<mon> (1-12), C<mday> (1-31), C<hour>, C<min>, C<sec>.
=item * C<wday> - day of week, C<0>=Sunday .. C<6>=Saturday.
=item * C<yday> - day of year, C<0>-based.
=item * C<frac_day> - time of day as a fraction in C<[0, 1)>, i.e.
C<(hour*3600 + min*60 + sec) / 86400>. Handy as a cyclic-ish time-of-day feature.
=item * C<frac_week> - position within the week as a fraction in C<[0, 1)>, the
week starting Sunday to match C<wday>: C<(wday*86400 + hour*3600 + min*60 + sec)
/ 604800>. Like C<frac_day> but cycling over a week, so a weekly rhythm (weekend
vs. weekday, or a Monday-morning batch) shows up as a feature.
=item * C<sin_day> / C<cos_day>, C<sin_week> / C<cos_week> - the C<frac_*> value
mapped onto a circle, C<sin(2*pi*frac)> and C<cos(2*pi*frac)>. Prefer these over
the raw C<frac_*> when feeding the forest: a plain fraction has a false seam at
the wrap (23:59 and 00:00 sit at opposite ends, 1 vs 0, though they are a minute
apart), whereas the sin/cos pair is continuous across midnight/Sunday. Store
I<both> of a pair in two columns so the position is unambiguous.
=back
Time features often carry the anomaly (a job that normally runs at 03:00
suddenly firing at noon, or a weekday task firing on a Sunday), which is why this
is a first-class munger.
B<Multi-output form.> A cyclic pair belongs together -- C<sin> alone collides
(C<sin> is symmetric about its peak, so two different times map to one value) and
the forest then treats distinct times as identical. To emit a pair atomically,
give C<parts> (plural) and route them to two columns with C<into> (see
L</compile>):
"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>
without a zone code, stamps are treated as UTC.
=cut
# Fraction (in [0,1)) of the way through the day / week, shared by the frac_*
# parts and their sin/cos cyclic encodings.
sub _frac_day {
my $t = shift;
return ( $t->hour * 3600 + $t->min * 60 + $t->sec ) / 86400;
}
sub _frac_week {
my $t = shift;
return ( $t->day_of_week * 86400 + $t->hour * 3600 + $t->min * 60 + $t->sec ) / 604800;
}
my $TWO_PI = 2 * atan2( 0, -1 ); # atan2(0,-1) == pi, core-only, no POSIX
# part name => how to pull it off a Time::Piece object.
my %DATETIME_PART = (
epoch => sub { $_[0]->epoch },
year => sub { $_[0]->year },
mon => sub { $_[0]->mon },
mday => sub { $_[0]->mday },
hour => sub { $_[0]->hour },
min => sub { $_[0]->min },
sec => sub { $_[0]->sec },
wday => sub { $_[0]->day_of_week },
yday => sub { $_[0]->yday },
frac_day => \&_frac_day,
frac_week => \&_frac_week,
sin_day => sub { sin( $TWO_PI * _frac_day( $_[0] ) ) },
cos_day => sub { cos( $TWO_PI * _frac_day( $_[0] ) ) },
sin_week => sub { sin( $TWO_PI * _frac_week( $_[0] ) ) },
cos_week => sub { cos( $TWO_PI * _frac_week( $_[0] ) ) },
);
# ---- fast fixed-format engine ----------------------------------------------
#
# Time::Piece->strptime costs microseconds per call. When the format is built
# from only the six all-numeric codes below (once each, e.g. the ubiquitous
# '%Y-%m-%dT%H:%M:%S'), we can compile it to a capture regex and derive every
# part with integer math instead -- several times faster, and bit-identical:
# both paths treat the stamp as UTC (strptime with no zone does the same).
# Anything fancier (%b, %z, %j, ...) stays on strptime.
# strptime code => [ field name, capture pattern ].
my %FAST_CODE = (
Y => [ 'year', '[0-9]{4}' ],
m => [ 'mon', '[0-9]{2}' ],
d => [ 'mday', '[0-9]{2}' ],
H => [ 'hour', '[0-9]{2}' ],
M => [ 'min', '[0-9]{2}' ],
S => [ 'sec', '[0-9]{2}' ],
);
# 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
# at 59: a :60 leap second is not representable in epoch math, so strptime
# arbitrates it too.
my @DAYS_IN_MONTH = ( 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31 );
sub _fast_fields_in_range {
my ( $c, $idx ) = @_;
my ( $y, $m, $d, $H, $M, $S ) = @{$c}[ @{$idx}{qw(year mon mday hour min sec)} ];
return 0 if $m < 1 || $m > 12;
my $dim = $DAYS_IN_MONTH[ $m - 1 ];
$dim = 29 if $m == 2 && ( ( !( $y % 4 ) && $y % 100 ) || !( $y % 400 ) );
return 0 if $d < 1 || $d > $dim;
return 0 if $H > 23 || $M > 59 || $S > 59;
return 1;
} ## end sub _fast_fields_in_range
# Days since 1970-01-01 for a proleptic-Gregorian date (Howard Hinnant's
# days-from-civil). Pure integer math; Perl's % already yields a non-negative
# result for the wday derivation even on pre-1970 dates.
sub _days_from_civil {
my ( $y, $m, $d ) = @_;
$y -= $m <= 2;
my $era = int( ( $y >= 0 ? $y : $y - 399 ) / 400 );
my $yoe = $y - $era * 400;
my $doy = int( ( 153 * ( $m + ( $m > 2 ? -3 : 9 ) ) + 2 ) / 5 ) + $d - 1;
my $doe = $yoe * 365 + int( $yoe / 4 ) - int( $yoe / 100 ) + $doy;
return $era * 146097 + $doe - 719468;
}
# part name => factory(\%idx) => getter(\@captures). Mirrors %DATETIME_PART;
# t/mungers-datetime-fast.t asserts the two stay value-identical. The factories
# bake the capture positions in at build time so a per-row getter indexes the
# raw capture array directly -- no intermediate hash per row, which is where
# the fast path's time would otherwise go. Slot 6 of the capture array caches
# days-from-civil so a multi-part (sin/cos) extraction computes it once.
my %DATETIME_PART_FAST;
{
my $days_of = sub {
my ( $iy, $im, $id ) = @{ $_[0] }{qw(year mon mday)};
return sub {
my $c = shift;
return defined $c->[6]
? $c->[6]
: ( $c->[6] = _days_from_civil( $c->[$iy], $c->[$im], $c->[$id] ) );
};
};
my $sod_of = sub {
my ( $ih, $in, $is ) = @{ $_[0] }{qw(hour min sec)};
return sub { $_[0][$ih] * 3600 + $_[0][$in] * 60 + $_[0][$is] };
};
my $frac_day_of = sub {
lib/Algorithm/ToNumberMunger.pm view on Meta::CPAN
return sub {
my $i = $_[0]{$name};
return sub { $_[0][$i] + 0 }
};
};
%DATETIME_PART_FAST = (
year => $field_of->('year'),
mon => $field_of->('mon'),
mday => $field_of->('mday'),
hour => $field_of->('hour'),
min => $field_of->('min'),
sec => $field_of->('sec'),
epoch => sub {
my ( $days, $sod ) = ( $days_of->( $_[0] ), $sod_of->( $_[0] ) );
return sub { $days->( $_[0] ) * 86400 + $sod->( $_[0] ) };
},
wday => sub { # epoch day 0 = Thursday = 4
my $days = $days_of->( $_[0] );
return sub { ( $days->( $_[0] ) + 4 ) % 7 };
},
yday => sub {
my ($idx) = @_;
my $days = $days_of->($idx);
my $iy = $idx->{year};
return sub {
my $c = shift;
return $days->($c) - _days_from_civil( $c->[$iy], 1, 1 );
};
},
frac_day => $frac_day_of,
frac_week => $frac_week_of,
sin_day => sub {
my $f = $frac_day_of->( $_[0] );
return sub { sin( $TWO_PI * $f->( $_[0] ) ) };
},
cos_day => sub {
my $f = $frac_day_of->( $_[0] );
return sub { cos( $TWO_PI * $f->( $_[0] ) ) };
},
sin_week => sub {
my $f = $frac_week_of->( $_[0] );
return sub { sin( $TWO_PI * $f->( $_[0] ) ) };
},
cos_week => sub {
my $f = $frac_week_of->( $_[0] );
return sub { cos( $TWO_PI * $f->( $_[0] ) ) };
},
);
}
# 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 ) };
croak "datetime munger$where: cannot parse '$v' with '$format'"
unless $t;
return $t;
};
if ( my $fast = _compile_fast_format($format) ) {
my ( $re, $idx ) = @{$fast}{qw(re idx)};
my $parse = sub {
my ($v) = @_;
croak "datetime munger$where: undefined value" unless defined $v;
if ( my @c = $v =~ $re ) {
return \@c if _fast_fields_in_range( \@c, $idx );
}
# Regex mismatch or out-of-range fields: let strptime be the judge,
# rebuilding the capture array (normalized, when strptime chooses
# to normalize rather than reject) in this format's capture order.
my $t = $strptime->($v);
my @c;
@c[ @{$idx}{qw(year mon mday hour min sec)} ]
= ( $t->year, $t->mon, $t->mday, $t->hour, $t->min, $t->sec );
return \@c;
}; ## end $parse = sub
my $getter_for = sub {
my ($part) = @_;
my $factory = $DATETIME_PART_FAST{$part}
or croak "datetime munger$where: unknown part '$part' (known: "
. join( ', ', sort keys %DATETIME_PART ) . ')';
return $factory->($idx);
};
return ( $parse, $getter_for );
} ## end if ( my $fast = _compile_fast_format($format...))
my $parse = sub {
my ($v) = @_;
croak "datetime munger$where: undefined value" unless defined $v;
return $strptime->($v);
};
my $getter_for = sub {
my ($part) = @_;
my $get = $DATETIME_PART{$part}
or croak "datetime munger$where: unknown part '$part' (known: "
. join( ', ', sort keys %DATETIME_PART ) . ')';
return $get;
};
return ( $parse, $getter_for );
} ## end sub _datetime_engine
sub _build_datetime {
my ( $spec, $where ) = @_;
lib/Algorithm/ToNumberMunger.pm view on Meta::CPAN
two hashed columns.
This is the one munger that is XS-accelerated: FNV-1a is a per-byte loop with a
32-bit modular multiply, which is slow in pure Perl and (on a 32-bit perl) fussy
to get exactly right. C<$Algorithm::ToNumberMunger::HAVE_XS>
reports whether the compiled path is in use; a pure-Perl fallback (exact on a
64-bit perl) is used otherwise, and both produce identical values.
=cut
sub _build_hash {
my ( $spec, $where ) = @_;
my $buckets = $spec->{buckets};
croak "hash munger$where: 'buckets' must be a positive integer"
if defined $buckets && $buckets !~ /\A[1-9][0-9]*\z/;
my $seed = defined $spec->{seed} ? $spec->{seed} : 0;
croak "hash munger$where: 'seed' must be a non-negative integer"
if $seed !~ /\A[0-9]+\z/;
my $fn = $HAVE_XS ? \&_fnv1a_xs : \&_fnv1a_pp;
return sub {
my ($v) = @_;
my $h = $fn->( defined $v ? "$v" : '', $seed );
return defined $buckets ? $h % $buckets : $h;
};
} ## end sub _build_hash
# Pure-Perl 32-bit FNV-1a, used only when the XS did not build. On a 64-bit
# perl the intermediate h*16777619 (< 2**57) stays an exact integer, so the
# masked result matches the C version bit for bit. The string is always
# utf8-encoded first so a value hashes as its UTF-8 bytes no matter the internal
# flag -- the same well-defined bytes SvPVutf8 hands the XS.
sub _fnv1a_pp {
my ( $str, $seed ) = @_;
utf8::encode($str);
my $h = ( 2166136261 ^ ( $seed & 0xFFFFFFFF ) ) & 0xFFFFFFFF;
for my $c ( unpack 'C*', $str ) {
$h ^= $c;
$h = ( $h * 16777619 ) & 0xFFFFFFFF;
}
return $h;
} ## end sub _fnv1a_pp
=head2 chain
# Shannon entropy of just the TLD: lowercase, keep the last dot-label
{ munger => 'chain',
steps => [ { op => 'lc' }, { op => 'split', on => '.', index => -1 } ],
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.
=item * C<split> - split on the literal separator C<on> and keep piece
C<index> (0-based; negative counts from the end, so C<-1> is a hostname's last
label). An index past either end yields the empty string.
=item * C<capture> - match the regex C<pattern> and keep capture group
C<group> (default C<1>). No match, or a group that did not participate, yields
the empty string. A true C<ignore_case> matches case-insensitively; the
L</match> trust note applies here too.
=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 '').
my %CHAIN_OPS = (
lc => sub {
return sub { return lc $_[0] }
},
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.
sub _chain_steps {
my ( $spec, $where ) = @_;
my $steps = $spec->{steps};
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: "
. join( ', ', sort keys %BUILDERS ) . ')';
my $term = $builder->( $then, "$where (chain terminal)" );
return sub {
my $s = defined $_[0] ? "$_[0]" : '';
$s = $_->($s) for @$ops;
return $term->($s);
};
} ## end sub _build_chain
# Multi-output chain: the same pre-transforms, but the terminal is one of the
# multi-output ('into') mungers. Returns ($list_returning_code, $arity) like
# every multi builder; the arity is the terminal's.
sub _build_chain_multi {
my ( $spec, $where ) = @_;
my $ops = _chain_steps( $spec, $where );
my ( $then, $name ) = _chain_terminal_spec( $spec, $where );
my $builder = $MULTI_BUILDERS{$name}
or croak "chain munger$where: terminal munger '$name' does not support "
. "multiple outputs ('into'); only these do: "
. join( ', ', sort keys %MULTI_BUILDERS );
my ( $term, $arity ) = $builder->( $then, "$where (chain terminal)" );
my $code = sub {
my $s = defined $_[0] ? "$_[0]" : '';
$s = $_->($s) for @$ops;
return $term->($s);
};
return ( $code, $arity );
} ## end sub _build_chain_multi
=head2 eps
{ munger => 'eps', prefix => 'http-req:', from => 'src_ip' }
{ munger => 'eps', prefix => 'dns-nxd:', from => 'src_ip',
read => 'rate', mark => 0 }
# multi-output: one daemon round trip fills several columns
{ munger => 'eps', prefix => 'http-req:', from => 'src_ip',
parts => [ 'rate', 'count' ], into => [ 'req_rate', 'req_count' ] }
Per-entity sliding-window event rates via the C<iqbi-damiq> daemon shipped with
L<Algorithm::EventsPerSecond> (see
L<Algorithm::EventsPerSecond::Sukkal>). The input value becomes a meter B<key>
(after C<prefix> is prepended); by default the munger B<marks> one event against
that key and returns the key's current events-per-second, using the daemon's
C<MARKRATE> command -- mark and query in a single command with a single reply.
This is the munger behind rate columns like a per-source request rate: every
event marks its source's meter and stores the rate the meter now reads.
lib/Algorithm/ToNumberMunger.pm view on Meta::CPAN
# Persistent daemon connections, keyed by socket path, shared by every eps
# munger in the process. Entries record the pid that opened them so a forked
# writer transparently reopens instead of sharing a socket with its parent.
# Connections are made lazily on first use -- never at munger build time, so a
# plan can compile (eager validation) with no daemon running.
my %EPS_CONN;
sub _eps_conn {
my ( $path, $timeout ) = @_;
my $c = $EPS_CONN{$path};
return $c->{fh} if $c && $c->{pid} == $$;
require Socket;
require IO::Socket::UNIX;
my $fh = IO::Socket::UNIX->new(
Type => Socket::SOCK_STREAM(),
Peer => $path,
) or die "cannot connect to iqbi-damiq at $path: $!\n";
# Best-effort read/write timeouts so a wedged daemon cannot hang a writer.
eval {
my $tv = pack( 'l!l!', $timeout, 0 );
setsockopt( $fh, Socket::SOL_SOCKET(), Socket::SO_RCVTIMEO(), $tv );
setsockopt( $fh, Socket::SOL_SOCKET(), Socket::SO_SNDTIMEO(), $tv );
};
$EPS_CONN{$path} = { fh => $fh, pid => $$ };
return $fh;
} ## end sub _eps_conn
# One pipelined transaction: send $cmd (possibly several lines) and read
# $nreplies "OK n" lines, one per command sent. The munger only ever sends
# commands that reply exactly once -- MARKRATE (which marks AND returns the
# rate in one go), RATE, COUNT, TOTAL; never a bare MARK, whose reply-only-on-
# error behavior would let a failure desynchronize the reply stream. Dies on
# ERR, EOF, or timeout; the caller still drops the cached connection on error
# as belt and braces.
sub _eps_txn {
my ( $path, $timeout, $cmd, $nreplies ) = @_;
my $fh = _eps_conn( $path, $timeout );
print {$fh} $cmd or die "write to iqbi-damiq failed: $!\n";
my @out;
for ( 1 .. $nreplies ) {
my $reply = <$fh>;
die "iqbi-damiq closed the connection (or timed out)\n"
unless defined $reply;
$reply =~ /\AOK (\S+)/
or die "iqbi-damiq replied: $reply";
push @out, $1 + 0;
}
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;
my $on_error = defined $spec->{on_error} ? $spec->{on_error} : 'die';
croak "eps munger$where: 'on_error' must be 'die' or a number"
unless $on_error eq 'die' || looks_like_number($on_error);
return ( $socket, $prefix, $mark, $timeout, $on_error );
} ## end sub _eps_spec
my %EPS_READ = map { $_ => 1 } qw(rate count total);
sub _build_eps {
my ( $spec, $where ) = @_;
croak "eps munger$where: 'parts' is for the multi-output form (needs " . "'into'); use 'read' for a single column"
if defined $spec->{parts};
my ( $socket, $prefix, $mark, $timeout, $on_error ) = _eps_spec( $spec, $where );
my $read = defined $spec->{read} ? $spec->{read} : 'rate';
croak "eps munger$where: unknown read '$read' (known: " . join( ', ', sort keys %EPS_READ ) . ')'
unless $EPS_READ{$read};
# Command plan, fixed at build time. The common case -- mark and read the
# rate -- is the daemon's single MARKRATE command. mark+count/total rides
# MARKRATE too (its rate reply is discarded) so marking failures come back
# as an ordinary first reply instead of a bare MARK's error-only surprise.
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
} ## end sub _build_eps
# Multi-output eps: one key, several reads (rate/count/total), one round trip.
# Returns ($list_returning_code, $arity) for compile()'s 'into' check.
sub _build_eps_multi {
my ( $spec, $where ) = @_;
my $parts = $spec->{parts};
croak "eps munger$where: 'parts' must be a non-empty arrayref"
unless ref $parts eq 'ARRAY' && @$parts;
for my $p (@$parts) {
croak "eps munger$where: unknown part '"
. ( defined $p ? $p : 'undef' )
. "' (known: "
. join( ', ', sort keys %EPS_READ ) . ')'
unless defined $p && $EPS_READ{$p};
}
my ( $socket, $prefix, $mark, $timeout, $on_error ) = _eps_spec( $spec, $where );
# Command plan, fixed at build time. When marking, the mark is a MARKRATE
# whose own reply serves the first 'rate' part for free; the remaining
# parts become one read command each. @take maps each part to the reply
# index that answers it, so the output stays in 'parts' order.
my ( @cmds, @take );
my $rate_served = 0;
push @cmds, 'MARKRATE' if $mark;
for my $i ( 0 .. $#$parts ) {
if ( $mark && !$rate_served && $parts->[$i] eq 'rate' ) {
$take[$i] = 0; # MARKRATE's reply is the rate
$rate_served = 1;
next;
}
push @cmds, uc $parts->[$i];
$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
return ( $code, $n );
} ## end sub _build_eps_multi
# A compiled munging plan for one set, produced by Mungers->compile. It turns an
# input record into a fully-numeric row in tags order; the Writer then only has
# to validate and append. Kept in its own package so the assembly logic is
# testable without a Writer or the filesystem.
package Algorithm::ToNumberMunger::Plan;
use strict;
use warnings;
use Carp qw(croak);
sub tags { return $_[0]->{tags} }
# Assemble a row from a name-keyed record. Scalar/raw columns read their own tag
# (or the munger's 'from'); expanding mungers read one source and fill several
# columns; combining mungers read several sources and fill one. This is the only
# form that supports expanders and combiners.
sub apply_named {
my ( $self, $hash ) = @_;
croak 'apply_named requires a hashref' unless ref $hash eq 'HASH';
my @row;
for my $s ( @{ $self->{scalar} } ) {
croak "missing value for '$s->{from}'"
unless exists $hash->{ $s->{from} };
my $v = $hash->{ $s->{from} };
$row[ $self->{pos}{ $s->{tag} } ] = $s->{code} ? $s->{code}->($v) : $v;
}
for my $e ( @{ $self->{expand} } ) {
croak "missing value for '$e->{from}'"
unless exists $hash->{ $e->{from} };
my @vals = $e->{code}->( $hash->{ $e->{from} } );
croak "expanding munger for [@{ $e->{into} }] returned "
. scalar(@vals)
. ' value(s), expected '
. scalar( @{ $e->{into} } )
unless @vals == @{ $e->{into} };
for my $i ( 0 .. $#{ $e->{into} } ) {
$row[ $self->{pos}{ $e->{into}[$i] } ] = $vals[$i];
}
} ## end for my $e ( @{ $self->{expand} } )
for my $c ( @{ $self->{combine} } ) {
my @vals;
for my $f ( @{ $c->{from} } ) {
croak "missing value for '$f'"
unless exists $hash->{$f};
( run in 2.187 seconds using v1.01-cache-2.11-cpan-54e63673c56 )