user-tools/stdfilt

   1 #!/usr/bin/env perl
   2
   3 use Data::Dumper;
   4 use Getopt::Long qw/:config no_ignore_case bundling no_getopt_compat/;
   5 use Fcntl qw/F_GETFL F_SETFL O_NONBLOCK/;
   6 use POSIX;
   7 use Pod::Usage;
   8 use List::MoreUtils qw/all any none/;
   9 no if ($] >= 5.018), 'warnings' => 'experimental::smartmatch';
  10
  11
  12 @Filters = ();
  13 @initialARGV = @ARGV;
  14
  15
  16 sub debug
  17 {
  18         warn @_ if $ENV{DEBUG};
  19 }
  20
  21 sub process_args
  22 {
  23         @ARGV = @initialARGV;
  24         pop @Filters while @Filters;
  25         return GetOptions(
  26                 'F|filter-file=s@' => sub { parse_filter_file($_[1]); },
  27                 'f|filter=s@' => sub {
  28                         eval { push @Filters, parse_filter_expr($_[1], \@Filters); 1; }
  29                         or die sprintf "%s: error in filter expression %d: %s\n%s", $0, scalar @Filters, $_[1], $@;
  30                 },
  31                 'help' => sub {
  32                         pod2usage(-exitval=>0, -verbose=>99);
  33                         exit 0;
  34                 },
  35                 '<>' => sub { unshift @ARGV, @_[0]; die '!FINISH'; },
  36         );
  37 }
  38
  39 process_args or exit 2;
  40
  41 if(not @ARGV)
  42 {
  43         pod2usage(-exitval=>2, -verbose=>99);
  44 }
  45
  46
  47 sub parse_filter_file
  48 {
  49         my $filepath = shift;
  50         open my $fh, '<', $filepath or die "$filepath: $!\n";
  51         while(<$fh>)
  52         {
  53                 chomp;
  54                 s/(^|\s+)#.*$//;
  55                 next if /^$/;
  56                 eval {
  57                         push @Filters, parse_filter_expr($_, \@Filters);
  58                         1;
  59                 } or die "$0: filter expression error in $filepath in line $.:\n$@";
  60         }
  61         close $fh;
  62 }
  63
  64 sub parse_filter_expr
  65 {
  66         local $_ = shift;
  67         my $prev_filters = shift;
  68         my $prev_filter = $prev_filters->[-1];
  69         my $filt = { expr=>$_, };
  70
  71         if(@$prev_filters and %{$prev_filter->{section_tags}})
  72         {
  73                 $filt->{section_tags}->{$_} = $filt->{match_tags}->{$_} = $prev_filter->{section_tags}->{$_} for keys %{$prev_filter->{section_tags}};
  74         }
  75
  76         my $remainder = $_;
  77         while($_)
  78         {
  79                 s/^\s*//;
  80                 if(s{^(?'negate'!|)\s*/(?'pattern'.*?)(?<!\\)/(?'modifiers'[a-zA-Z]*)\s*(\+(?'offset'\d+))?}{})
  81                 {
  82                         if(exists $filt->{replacer})
  83                         {
  84                                 die "$0: pattern matching can not follow a replace: $remainder\n";
  85                         }
  86                         $filt->{negate} = $+{negate} ? 1 : 0;
  87                         $filt->{pattern} = $+{pattern};
  88                         $filt->{modifiers} = $+{modifiers};
  89                         $filt->{offset} = $+{offset};
  90                 }
  91                 elsif(s/^\[\/(.+?)\]//)
  92                 {
  93                         if(exists $filt->{pattern})
  94                         {
  95                                 push @{$filt->{tag_end}}, $1;
  96                         }
  97                         else
  98                         {
  99                                 delete $filt->{match_tags}->{$1};
 100                         }
 101                 }
 102                 elsif(s/^\[(.+?)\]//)
 103                 {
 104                         if(exists $filt->{pattern})
 105                         {
 106                                 push @{$filt->{tag_start}}, $1;
 107                         }
 108                         else
 109                         {
 110                                 $filt->{match_tags}->{$1} = 1;
 111                         }
 112                 }
 113                 elsif(s{^(s/.*?(?<!\\)/.*?(?<!\\)/[a-zA-Z]*)}{})
 114                 {
 115                         my $replacer = $1;
 116                         eval 'my $test = ""; $test =~ '.$replacer.'; 1' or die "$0: error in s/// expression: $@\n";
 117                         $filt->{replacer} = $replacer;
 118                 }
 119                 else
 120                 {
 121                         die "$0: can not parse expression: $_\n";
 122                 }
 123
 124                 $remainder = $_;
 125         }
 126
 127         # if it's a "[blue]" type of line, ie. a lone tag specification, then it opens a section of rules, all of which must match to "blue" tag.
 128         if(all {not exists $filt->{$_}} qw/pattern replacer tag_start tag_end/)
 129         {
 130                 if(exists $filt->{match_tags})
 131                 {
 132                         $filt->{section_tags} = {};
 133                         $filt->{section_tags}->{$_} = $filt->{match_tags}->{$_} for keys %{$filt->{match_tags}};
 134                 }
 135         }
 136
 137         debug Dumper $filt;
 138         return $filt;
 139 }
 140
 141 sub stream_tags_match
 142 {
 143         my $current_tags = shift;
 144         my $mandatory_tags = shift;
 145         return all { $_ ~~ [keys %$current_tags] } keys %$mandatory_tags;
 146 }
 147
 148 sub apply_filter_rule
 149 {
 150         my $rule = shift;
 151         my $line = shift;
 152         my $context = shift;
 153         my $result = shift;
 154         my $applied = 0;
 155
 156         if(exists $rule->{replacer})
 157         {
 158                 eval '$line =~ '.$rule->{replacer}.'; 1' or warn "$0: $@\n";
 159                 $result->{line} = $line;
 160                 $applied = 1;
 161         }
 162         if(exists $rule->{tag_start})
 163         {
 164                 $context->{tags}->{$_} = 1 for @{$rule->{tag_start}};
 165                 $applied = 1;
 166         }
 167         if(exists $rule->{tag_end})
 168         {
 169                 delete $context->{tags}->{$_} for @{$rule->{tag_end}};
 170                 $applied = 1;
 171         }
 172         return $applied;
 173 }
 174
 175 sub evaluate_filters
 176 {
 177         my $line = shift;
 178         my $context = shift;
 179         my $result = {pass => 1, line => $line,};
 180
 181         for my $fnum (0 .. $#Filters)
 182         {
 183                 my $filt = $Filters[$fnum];
 184
 185                 debug Dumper { filter => $filt, context => $context, };
 186
 187                 $context->{delayed_rule}->[$fnum]->{count_down} -= 1 if $context->{delayed_rule}->[$fnum]->{count_down} > 0;
 188                 if(%{$context->{delayed_rule}->[$fnum]} and $context->{delayed_rule}->[$fnum]->{count_down} <= 0)
 189                 {
 190                         debug Dumper { apply_delayed_rule => $context->{delayed_rule}->[$fnum]->{rule}, };
 191                         apply_filter_rule($context->{delayed_rule}->[$fnum]->{rule}, $line, $context, $result);
 192                         delete $context->{delayed_rule}->[$fnum];
 193                 }
 194
 195                 next if not stream_tags_match($context->{tags}, $filt->{match_tags});
 196
 197                 my %applicable_rule = map {($_=>$filt->{$_})} grep {$_ ~~ [qw/tag_start tag_end replacer/]} keys %$filt;
 198
 199                 if(exists $filt->{pattern})
 200                 {
 201                         my $pattern_matched = $line =~ m/(?$filt->{modifiers})$filt->{pattern}/;
 202                         $pattern_matched = !$pattern_matched if $filt->{negate};
 203                         if($pattern_matched)
 204                         {
 205                                 if($filt->{offset})
 206                                 {
 207                                         debug Dumper { delay_rule_application => \%applicable_rule, };
 208                                         $context->{delayed_rule}->[$fnum]->{count_down} = $filt->{offset};
 209                                         $context->{delayed_rule}->[$fnum]->{rule} = \%applicable_rule;
 210                                 }
 211                                 else
 212                                 {
 213                                         $result->{pass} = 1;
 214                                         apply_filter_rule(\%applicable_rule, $line, $context, $result);
 215                                 }
 216                         }
 217                         else
 218                         {
 219                                 if(not %applicable_rule)
 220                                 {
 221                                         $result->{pass} = 0;
 222                                 }
 223                         }
 224                 }
 225                 else
 226                 {
 227                         apply_filter_rule(\%applicable_rule, $line, $context, $result);
 228                 }
 229         }
 230
 231         return $result;
 232 }
 233
 234 sub process_line
 235 {
 236         my $line = shift;
 237         my $stream = shift;
 238         my $filt_result = evaluate_filters($line, $stream->{filter_context});
 239         print {$stream->{'write_fh'}} $filt_result->{line} if $filt_result->{pass};
 240 }
 241
 242 sub process_stream
 243 {
 244         my $stream = shift;
 245         while(1)
 246         {
 247                 my $nl = index $stream->{'buf'}, "\n";
 248                 last if $nl == -1;
 249                 $nl++;
 250
 251                 my $line = substr $stream->{'buf'}, 0, $nl;
 252                 process_line $line, $stream;
 253
 254                 $stream->{'buf'} = substr $stream->{'buf'}, $nl;
 255         }
 256 }
 257
 258
 259
 260 pipe($stdout_r, $stdout_w) or die "$0: pipe: $!\n";
 261 pipe($stderr_r, $stderr_w) or die "$0: pipe: $!\n";
 262
 263
 264 $CHILD_PID = fork // die "$0: fork: $!\n";
 265
 266 if($CHILD_PID == 0)
 267 {
 268         open STDOUT, '>&', $stdout_w or die "$0: replace stdout: $!\n";
 269         open STDERR, '>&', $stderr_w or die "$0: replace stderr: $!\n";
 270         select STDERR; $|++;
 271         select STDOUT; $|++;
 272
 273         exec {$ARGV[0]} @ARGV;
 274         my ($errno, $errstr) = (int $!, $!);
 275         warn "$0: ${ARGV[0]}: $errstr\n";
 276         exit 125+$errno;
 277 }
 278
 279
 280 my $child_status = undef;
 281 close STDIN;
 282 close $stdout_w;
 283 close $stderr_w;
 284 fcntl($stdout_r, F_SETFL, fcntl($stdout_r, F_GETFL, 0) | O_NONBLOCK);
 285 fcntl($stderr_r, F_SETFL, fcntl($stderr_r, F_GETFL, 0) | O_NONBLOCK);
 286 select STDERR; $|++;
 287 select STDOUT; $|++;
 288
 289
 290 $streams = {
 291         'out' => {
 292                 'fh' => $stdout_r,
 293                 'write_fh' => \*STDOUT,
 294                 'fd' => fileno $stdout_r,
 295                 'buf' => '',
 296         },
 297         'err' => {
 298                 'fh' => $stderr_r,
 299                 'write_fh' => \*STDERR,
 300                 'fd' => fileno $stderr_r,
 301                 'buf' => '',
 302         },
 303 };
 304
 305 sub reset_stream_contexts
 306 {
 307         $streams->{'out'}->{'filter_context'} = {
 308                 'tags' => {
 309                         'STDOUT' => 1,
 310                 },
 311         };
 312         $streams->{'err'}->{'filter_context'} = {
 313                 'tags' => {
 314                         'STDERR' => 1,
 315                 },
 316         };
 317 }
 318
 319 reset_stream_contexts();
 320
 321 $SIG{'HUP'} = sub { $do_reload = 1; };
 322
 323
 324 while(1)
 325 {
 326         $fds = '';
 327         for my $stream_name (keys %$streams)
 328         {
 329                 vec($fds, $streams->{$stream_name}->{'fd'}, 1) = 1 if defined $streams->{$stream_name}->{'fh'};
 330         }
 331         last if $fds eq '';
 332
 333         $! = 0;
 334         select($fds, undef, undef, undef);
 335         my $errno = int $!;
 336
 337         if($do_reload)
 338         {
 339                 $do_reload = 0;
 340                 reset_stream_contexts();
 341                 process_args();
 342         }
 343
 344         next if $errno;
 345
 346         for my $stream_name (keys %$streams)
 347         {
 348                 if(vec($fds, $streams->{$stream_name}->{'fd'}, 1) == 1)
 349                 {
 350                         my $bytes = sysread $streams->{$stream_name}->{'fh'}, $streams->{$stream_name}->{'buf'}, 1024, length $streams->{$stream_name}->{'buf'};
 351                         if($bytes)
 352                         {
 353                                 process_stream($streams->{$stream_name});
 354                         }
 355                         else
 356                         {
 357                                 # this stream is closed.
 358                                 undef $streams->{$stream_name}->{'fh'};
 359                                 # process last unterminated line (if any)
 360                                 process_line($streams->{$stream_name}->{'buf'}, $streams->{$stream_name}) if length $streams->{$stream_name}->{'buf'};
 361                         }
 362                 }
 363         }
 364 }
 365
 366 waitpid($CHILD_PID, 0);
 367 $child_status = $?;
 368 $exit_status = WEXITSTATUS($child_status);
 369 $exit_status = 128 + WTERMSIG($child_status) if WIFSIGNALED($child_status);
 370 exit $exit_status;
 371
 372
 373 __END__
 374
 375 =pod
 376
 377 =head1 NAME
 378
 379 stdfilt - Run a command but filter its STDOUT and STDERR
 380
 381 =head1 SYNOPSIS
 382
 383 stdfilt [I<OPTIONS>] [--] I<COMMAND> [I<ARGS>]
 384
 385 =head1 DESCRIPTION
 386
 387 Run I<COMMAND> and match each of its output lines (both stdout and stderr separately) against
 388 the filter rules given by command arguments (B<-f>) or in files (B<-F>).
 389 All filter expressions are evaluated and the last matching rule wins.
 390 So it's a good idea to add wider matching patterns first, then the more specific ones later.
 391
 392 =head1 OPTIONS
 393
 394 =over 4
 395
 396 =item -F, --filter-file I<FILE>
 397
 398 =item -f, --filter I<EXPR>
 399
 400 =back
 401
 402 =head1 FILTER FILE FORMAT
 403
 404 Empty and comments are ignored as well as leading whitespace.
 405 Comment is everything after a hashmark (C<#>) preceded by whitespace or the while line if it starts with a hashmark.
 406
 407 Each line is a filter rule, of which syntax is:
 408
 409 [B<match_tags>] [B<pattern> [B<offset>]] [B<replacer>] [B<set_tags>]
 410
 411 =over 4
 412
 413 =item B<match_tags>
 414
 415 Tag names, each of them in square-bracket (eg. C<[blue] [red]>).
 416 The rest of the rule will be evaluated only if the tags are on the current stream.
 417 Tags can be added, removed by the B<set_tags> element.
 418
 419 If a rule only consists of B<match_tags> tags, it opens a section in the filter file (and in B<-f> arguments too).
 420 In this section, all rules are interpreted as they had the given B<match_tags> of the section written in them.
 421 For example this filter-set selects all ranges in the output (and stderr) stream bound by those regexp patterns inclusively,
 422 and blocks everying in them except "errors":
 423
 424  /begin checking procedure/ [checking]
 425  /checking finished/+1 [/checking]
 426  [checking]
 427  !//
 428  /error/i
 429  [/checking]
 430
 431 The 2 streams, stdout and stderr are tagged by default by "STDOUT" and "STDERR" respectively:
 432 So this filters out everying in the stdout except "errors":
 433
 434  [STDOUT]
 435  !//
 436  /error/i
 437  [/STDOUT]
 438
 439 =item B<pattern>
 440
 441 Regexp pattern (perlre(1)) to match to the streams' (stdout and stderr) lines.
 442 In the form of C<< /B<PATTERN>/B<MODIFIERS> >>.
 443 Optionally prefixed with an exclamation mark (C<!>) which negates the result.
 444
 445 Pass every line by C<//>.
 446 Exclude every line by C<!//>.
 447
 448 If there is a B<pattern> in the rule, replacement or tagging will only take place
 449 if the pattern matched (or not matched if it was negated).
 450
 451 If there is no B<pattern>, only B<match_tags> controls if the rest will be applied or not.
 452
 453 You may escape slash (C</>) in the B<PATTERN> normally as it's customary in Perl,
 454 by backslash, but to keep the filter expression parsing simple,
 455 an escaped backslash itself (double backslash) at the end of the regexp pattern,
 456 ie. just before the closing slash,
 457 won't be noticed.
 458 So type it as C<\x5C> instead.
 459
 460 Further limitation, that only slash C</> can be used, others, eg. C<m{...}> not.
 461
 462 =item B<offset>
 463
 464 A B<pattern> may be followed by a plus sign and a number (C<< +B<N> >>)
 465 to denote that the given action (string replacement, or tagging)
 466 should take effect after the given number of lines.
 467
 468 This way you can exclude the triggering line from the tagging.
 469
 470 A B<pattern> with B<offset> but without B<replacer> or B<set_tags> is meaningless.
 471
 472 =item B<replacer>
 473
 474 A C<s///> string substitution Perl expression.
 475 Optionally with modifiers.
 476 This can be abused to execute any perl code (with the "e" modifier).
 477
 478 =item B<set_tags>
 479
 480 The syntax is the same as for B<match_tags>.
 481 But is the square-bracketed tags are at the right of the B<pattern>,
 482 then the tags are applied to the stream.
 483
 484 Remove tags by a leading slash, like C<[/blue]>.
 485
 486 B<set_tags> is useful with a B<pattern>.
 487
 488 Example filter:
 489
 490  /BEGIN/ [keyblock]
 491  /END/ [/keyblock]
 492  [keyblock] s/^/\t/
 493
 494 This prepends a TAB char to each lines in the output stream which are between the lines containing "BEGIN" and "END".
 495
 496 =back
 497
 498 =head1 SIGNALS
 499
 500 HUP - re-read filter files given at command line
 501
 502 =head1 EXAMPLES
 503
 504 Prefix each output (and stderr) lines with the I<COMMAND> process'es PID:
 505
 506  stdfilt -f 's/^/$CHILD_PID: /' some_command...
 507
 508 Prefix each line with STDOUT/STDERR:
 509
 510  stdfile -f '[STDOUT]' -f 's/^/STDOUT: /' -f '[/STDOUT]' -f '[STDERR]' -f 's/^/STDERR: /' -f '[/STDERR]' some_command...
 511
 512 =head1 SEE ALSO
 513
 514 grep(1), stdbuf(1), logwall(8), perlre(1)
 515
 516 =cut
 517
 518 EOF