make getpeername() return the original socket address which before it was intercepted

[hband-tools.git] / tabdata / td-filter

#!/usr/bin/env perl

=pod

=head1 NAME

td-filter - Show only those records from the input tabular data stream which match to the conditions.

=head1 USAGE

td-filter [I<OPTIONS>] [--] I<COLUMN> I<OPERATOR> I<R-VALUE> [[B<or>] I<COLUMN> I<OPERATOR> I<R-VALUE> [[B<or>] ...]]

td-filter [I<OPTIONS>] --perl I<EXPR>

=head1 DESCRIPTION

Pass through those records which match at least one of the conditions (inclusive OR).
A condition consists of a triplet of I<COLUMN>, I<OPERATOR>, and I<R-VALUE>.
You may put together conditions conjunctively (AND) by chaining multiple td-filter(1) commands by shell pipes.
Example:

  td-filter NAME eq john NAME eq jacob | tr-filter AGE -gt 18

This gives the records with either john or jacob, and all of them will be above 18.

The optional word "B<or>" between triplets makes your code more explicite.

td-filter(1) evaluates the Perl expression in the second form and passes through records
only if the result is true-ish in Perl (non zero, non empty string, etc).
Each field's value is in C<@F> by index, and in C<%F> by column name.
You can implement more complex conditions in this way.

=head1 OPTIONS

=over 4

=item -H, --no-header

do not show headers

=item -h, --header

show headers (default)

=item -i, --ignore-non-existing-columns

do not treat non-existing (missing or typo) column names as failure

=item -w, --warn-non-existing-columns

only show warning on non-existing (missing or typo) column names, but don't fail

=item -N, --no-fail-non-numeric

do not fail when a non-numeric r-value is given to a numeric operator

=item -W, --no-warn-non-numeric

do not show warning when a non-numeric r-value is given to a numeric operator

=back

=head1 OPERATORS

These operators are supported, semantics are the same as in Perl, see perlop(1).

 == != <= >= < > =~ !~ eq ne gt lt

For your convenience, not to bother with escaping, you may also use these operators as alternatives to the canonical ones above:

=over 4

=item is

=item = I<(single equal sign)>

string equality (B<eq>)

=item is not

string inequality (B<ne>)

=item -eq

numeric equality (B<==>)

=item -ne

numeric inequality (B<!=>)

=item <>

numeric inequality (B<!=>)

=item -gt

numeric greater than (B<E<gt>>)

=item -ge

numeric greater or equal (B<E<gt>=>)

=item -lt

numeric less than (B<E<lt>>)

=item -le

numeric less or equal (B<E<lt>=>)

=item match

=item matches

regexp match (B<=~>)

=item does not match

=item do not match

=item not match

negated regexp match (B<!~>)

=back

Other operators:

=over 4

=item is [not] one of

=item is [not] any of

I<R-VALUE> is split into pieces by commas (C<,>) and
equality to at least one of them is required.
Equality to none of them is required if the operator is negated.

=item contains [whole word]

Substring match.
Plural form "contain" is also accepted.
Optional I<whole word> is a literal part of the operator.

=item contains [one | any] [whole word] of

Similar to B<is one of>, but substring match is checked
instead of full string equality.
Plural form "contain" is also accepted.
Optional I<whole word> is a literal part of the operator.

=item ends with

=item starts with

Plural forms are also accepted.

=back

Operators may be preceeded by I<not>, I<does not>, I<do not> to negate their effect.

=head1 CAVEATS

If there is no I<COLUMN> column in the input data, it's silently considered empty.
td-filter(1) does not need I<R-VALUE> to be quoted or escaped, however your shell may do.

=head1 REFERENCES

td-filter(1) is analogous to SQL WHERE.

=cut


$OptShowHeader = 1;
$OptWarnBadColumnNames = 1;
$OptFailBadColumnNames = 1;
$OptWarnNonNumericRValue = 1;
$OptFailNonNumericRValue = 1;
%OptionDefs = (
        'H|no-header' => sub { $OptShowHeader = 0; },
        'h|header' => sub { $OptShowHeader = 1; },
        'i|ignore-non-existing-columns' => sub { $OptFailBadColumnNames = 0; $OptWarnBadColumnNames = 0; },
        'w|warn-non-existing-columns' => sub { $OptFailBadColumnNames = 0; $OptWarnBadColumnNames = 1; },
        'N|no-fail-non-numeric' => sub { $OptFailNonNumericRValue = 0; },
        'W|no-warn-non-numeric' => sub { $OptWarnNonNumericRValue = 0; },
);

use Switch;
use List::MoreUtils qw/all any none uniq/;
use Data::Dumper;
no if ($] >= 5.018), 'warnings' => 'experimental::smartmatch';
do '/usr/lib/tool/perl5/tabdata/common.pl' or die "$@";

use Math::Cartesian::Product;


sub subst_alternate_forms
{
        my $words = shift;
        my $altforms = shift;
        my @product_terms = ();
        for my $word (split /\s+/, $words)
        {
                push @product_terms, ($word ~~ [keys %$altforms]) ? $altforms->{$word} : [$word];
        }
        my @results = ();
        cartesian {push @results, join ' ', @_} @product_terms;
        return @results;
}
sub parse_operator
{
        my @args = @_;
        my %alternate_form = (
                'ANY' => [qw/one any/],
                'MATCH' => [qw/match matches/],
                'CONTAIN' => [qw/contain contains/],
                'DOES' => [qw/do does/],
                'START' => [qw/start starts/],
                'END' => [qw/end ends/],
        );
        my @opdef = (
                { phrase => 'MATCH',                                operator => '=~'},
                { phrase => 'not MATCH',                            operator => '!~'},
                { phrase => 'DOES not match',                       operator => '!~'},
                
                { phrase => 'is not ANY of',                        operator => 'is-one-of',       negation => 1},
                { phrase => 'is ANY of',                            operator => 'is-one-of'},
                { phrase => 'is not',                               operator => 'ne'},
                { phrase => 'is',                                   operator => 'eq'},
                
                { phrase => '=',   operator => 'eq'},
                { phrase => '-eq', operator => '=='},
                { phrase => '-ne', operator => '!='},
                { phrase => '<>',  operator => '!='},
                { phrase => '-gt', operator => '>'},
                { phrase => '-ge', operator => '>='},
                { phrase => '-lt', operator => '<'},
                { phrase => '-le', operator => '<='},
                
                { phrase => 'CONTAIN whole word',                   operator => 'contains',                       wholeword => 1},
                { phrase => 'CONTAIN ANY whole word of',            operator => 'contains-one-of',                wholeword => 1},
                { phrase => 'CONTAIN ANY of',                       operator => 'contains-one-of'},
                { phrase => 'CONTAIN',                              operator => 'contains'},
                { phrase => 'not CONTAIN whole word',               operator => 'contains',        negation => 1, wholeword => 1},
                { phrase => 'not CONTAIN ANY whole word of',        operator => 'contains-one-of', negation => 1, wholeword => 1},
                { phrase => 'not CONTAIN ANY of',                   operator => 'contains-one-of', negation => 1},
                { phrase => 'not CONTAIN',                          operator => 'contains',        negation => 1},
                { phrase => 'DOES not contain ANY whole word of',   operator => 'contains-one-of', negation => 1, wholeword => 1},
                { phrase => 'DOES not contain whole word',          operator => 'contains',        negation => 1, wholeword => 1},
                { phrase => 'DOES not contain ANY of',              operator => 'contains-one-of', negation => 1},
                { phrase => 'DOES not contain',                     operator => 'contains',        negation => 1},
                
                { phrase => 'START with',                           operator => 'starts-with'},
                { phrase => 'not START with',                       operator => 'starts-with',     negation => 1},
                { phrase => 'DOES not start with',                  operator => 'starts-with',     negation => 1},
                
                { phrase => 'END with',                             operator => 'ends-with'},
                { phrase => 'not END with',                         operator => 'ends-with',       negation => 1},
                { phrase => 'DOES not end with',                    operator => 'ends-with',       negation => 1},
        );
        my @canonical_operators = uniq map {$_->{operator}} @opdef;
        for my $opdef (@opdef)
        {
                my $phrase = $opdef->{phrase};
                my $nwords = scalar split /\s+/, $phrase;
                my @phrases = subst_alternate_forms($phrase, \%alternate_form);
                #warn Dumper \@phrases;
                for my $possible_operator (@phrases)
                {
                        my $argstr = join ' ', @args[0..($nwords-1)];
                        if($argstr eq $possible_operator)
                        {
                                my %result = %$opdef;
                                $result{remaining_args} = [@args[$nwords..$#args]];
                                return \%result;
                        }
                }
        }
        if($args[0] ~~ [@canonical_operators])
        {
                return {operator => $args[0], remaining_args => [@args[1..$#args]]};
        }
        die "valid operator expected; found this: @args";
}



@Filter = ();
$Expr = undef;


if($ARGV[0] eq '--perl')
{
        shift @ARGV;
        die "$0: missing Perl expression\n" unless @ARGV;
        $Expr = join ';', @ARGV;
}
else
{
        while(scalar @ARGV)
        {
                shift @ARGV if $ARGV[0] eq 'or';
                
                my $column = shift @ARGV;
                
                my $complex_operator = parse_operator(@ARGV);
                #warn Dumper $complex_operator;
                my $operator = $complex_operator->{operator};
                my $negation = $complex_operator->{negation};
                my $wholeword = $complex_operator->{wholeword};
                @ARGV = @{$complex_operator->{remaining_args}};
                
                my $rvalue = shift @ARGV;
                die "$0: missing r-value for: $column $operator\n" if not defined $rvalue;
                
                if($operator ~~ [qw/== != <= >= < >/] and $rvalue !~ /^[+-]?[0-9]\d*(.\d+|)(E[+-]?\d+|)$/i)
                {
                        warn "$0: operator ($operator) is numeric but r-value ($rvalue) is not\n" if $OptWarnNonNumericRValue;
                        exit -1 if $OptFailNonNumericRValue;
                }
                
                push @Filter, {'field'=>$column, 'operator'=>$operator, 'negation'=>$negation, 'value'=>$rvalue, 'wholeword'=>$wholeword};
        }
}

process_header(scalar <STDIN>);

if(not defined $Expr)
{
        for my $filter (@Filter)
        {
                my $colname = $filter->{'field'};
                if(not exists $Header{$colname})
                {
                        my $cols = join ", ", @Header;
                        warn "$0: $colname: no such column. known columns: $cols\n" if $OptWarnBadColumnNames;
                        exit 3 if $OptFailBadColumnNames;
                }
        }
}

if($OptShowHeader and length $HeaderLine)
{
        print $HeaderLine.$RS;
}

while(not eof STDIN)
{
        my @Field = read_record(\*STDIN);
        
        if(defined $Expr)
        {
                my @F = @Field;
                my %F = map {$_=>$Field[$Header{$_}]} keys %Header;
                $pass = eval $Expr;
                warn $@ if $@;
        }
        else
        {
                $pass = 0;
                
                for my $filter (@Filter)
                {
                        my $left_data = exists $Header{$filter->{'field'}} ? $Field[$Header{$filter->{'field'}}] : '';
                        my $right_data = $filter->{'value'};
                        my $operator = $filter->{'operator'};
                        my $result;
                        
                        if($filter->{'wholeword'})
                        {
                                # have to match "whole word" - simple substring match won't be enough.
                                # transform "contains" and "contains-one-of" operators into a regexp match.
                                
                                if($operator eq 'contains-one-of')
                                {
                                        $right_data = '\b(' . (join '|', map { quotemeta($_) } split /,/, $right_data) . ')\b';
                                }
                                elsif($operator eq 'contains')
                                {
                                        $right_data = '\b' . quotemeta($right_data) . '\b';
                                }
                                else { die "$0: should not happen\n"; }
                                $operator = '=~';
                        }
                        
                        switch($operator)
                        {
                                case 'contains'
                                {
                                        $result = 1 + index $left_data, $right_data;
                                }
                                case 'is-one-of'
                                {
                                        $result = any { $left_data eq $_ } split /,/, $right_data;
                                }
                                case 'contains-one-of'
                                {
                                        $result = any { 1 + index $left_data, $_ } split /,/, $right_data;
                                }
                                case 'starts-with'
                                {
                                        $result = $right_data eq substr($left_data, 0, length $right_data);
                                }
                                case 'ends-with'
                                {
                                        $result = $right_data eq substr($left_data, -length $right_data);
                                }
                                else
                                {
                                        my $left_code = '$left_data';
                                        my $right_code = '$right_data';
                                        $right_code = "/$right_code/" if $operator ~~ ['=~', '!~'];
                                        $result = eval "$left_code $operator $right_code";
                                }
                        }
                        
                        $result = !$result if $filter->{'negation'};
                        
                        if($result)
                        {
                                $pass = 1;
                                last;
                        }
                }
        }
        
        if($pass)
        {
                print join($FS, @Field).$RS;
        }
}