#!/usr/bin/perl -w

use IO::Handle;

# -------------------------------------------------------------------- customize here

# top source directory
my $topdir = "$ENV{ARBHOME}";

# list containing paths of all source files (generated by arb_valgrind)
my $sourcelist = "$topdir/SOURCE_TOOLS/valgrind2grep.lst";

# prefix to write before hidden caller-lines
# (-> emacs will not jump to them automatically, you have to remove the prefix first)
my $unmark_callers  = "(hide) ";

# prefix to write before filtered lines
my $unmark_filtered = "(filt) ";

# prefix to write before other non-error lines
my $unmark_rest     = "(note) ";

# --------------------------------------------------------------- customize till here

# get args:

if ($#ARGV != 1) { die "Usage: valgrind2grep <callers> <filter>\n"; }
my $callers = $ARGV[0];
my $filter  = $ARGV[1];

# read list of source files:

open(SOURCELIST,"<$sourcelist") || die "can't open $sourcelist";

my %fileIndex = ();
foreach (<SOURCELIST>) {
  chomp;
  $fileIndex{$_} = $_;
  if (/\/([^\/]+)\/([^\/]+)$/) {
    my $last_dir = $1;
    my $fname    = $2;

    $fileIndex{$fname} = $_;
    $fileIndex{$last_dir.'/'.$fname} = $_;
  }
  elsif (/\/([^\/]+)$/) {
    my $fname = $1;
    $fileIndex{$fname} = $_;
  }
  else {
    die "invalid entry in $sourcelist ('$_')"
  }
}

close(SOURCELIST);

# use unbuffered I/O (otherwise pipe waits for valgrind to terminate???)

$in = new IO::Handle;
$in->fdopen(fileno(STDIN),"r") || die "can't open STDIN";

$out = new IO::Handle;
$out->fdopen(fileno(STDOUT),"w") || die "can't open STDOUT";

$out->print("Settings: Showing $callers caller(s).\n");
$out->print("          Filtering with '$filter'.\n");

sub avoid_location($) { # invalidate everything emacs could missinterpret as error-location (i.e. '(file:lineno)')
  $_ = shift;
  s/([(].*)(:)(.*[)])/$1_$2_$3/ig;
  $_;
}

# variables:

my $i;
my $called_from = "called from";
my $reason       = 'no reason yet';
my $caller_count = 0; # counts callers
my $filtered = 0; # filter current error

# the filter loop:

while (not $in->eof) {
  # read one line:
  $_ = $in->getline;

  # convert error messages to grep format:
  if (/^([=\-0-9]+[ ]+)(.*)$/) {
    my $prefix  = $1;
    my $content = $2;

    if ($content =~ /^([ab][ty].*)([(][^()]+[)])$/) { # looks like an valgrind error
      $content = $1;
      my $location = $2;

      if ($location =~ /[(](.*):(.*)[)]/) { # seems to have a valid '(file:line)' location at eol
        if ($filtered == 1) {
          $_ = $unmark_filtered.' '.&avoid_location($_);
        }
        else {
          my $replace = $fileIndex{$1};
          if ($replace) {
            if (not -f $replace) {
              $_ = "$sourcelist:1: might be outdated ($replace does not exist)\n";
            }
            else {
              $_ = "$replace:$2: $reason ($content)\n";
              if ($reason eq $called_from) { # its a caller
                $caller_count++;
                if ($caller_count > $callers) {
                  $_ = $unmark_callers.$_;
                }               # hide this caller
              } else {
                $caller_count = 0;
              }
              $reason = $called_from;
            }
          }
          else {              # location in unavailable file (i.e. in library)
            $_ = $prefix.$reason." $content (in unavailable file $1 line $2)\n";
          }
        }
      }
      else { # valgrind error w/o location
        $_=$unmark_rest.' '.$_;
      }
    }
    else { # no location found
      $reason = $content;
      $_=$unmark_rest.' '.$_;

      # should that reason be filtered ?
      if ($reason =~ /alloc\'d/) { # an allocator message (applies to last message) -> so never filter
        $reason = "ORIGIN: $reason";
      }
      else {
        if ($reason =~ /$filter/i) { $filtered = 0; }
        else { $filtered = 1; }
      }
    }
  }

  # print out line
  $out->print($_);
  $out->flush;
}

$in->close;
$out->close;

