#!/usr/bin/perl

use warnings;
use strict;
use IO::Handle;

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

# top source directory
my $topdir = "$ENV{ARBHOME}";
my $toplen = length($topdir);

# 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) ";

sub check_ignore_external($\$$) {
  my ($text,$ignore_r,$reason) = @_;
  if (not defined $$ignore_r) {
    # if you encounter errors/warnings in foreign libraries you wont be able to fix them.
    # To ignore them add a search expression here.
    # Please add current date as well, to make it easier to find outdated expressions.

    if ($reason =~ 'loss record') { # memory leaks
      # Xtoolkit leaks / ARB leaks which we wont fix for motif - retry after gtk merge

      if ($reason =~ 'still reachable' or $reason =~ 'possibly lost') { # reachable memory leaks

        if ($text =~ /\b(XLoadQueryFont)\b.*libXt/) { $$ignore_r = $&; return; } # 29/05/2010
        if ($text =~ /\b(XRebindKeysym)\b.*libXt/) { $$ignore_r = $&; return; } # 29/05/2010
        if ($text =~ /\b(XmGetPixmap)\b.*libXm/) { $$ignore_r = $&; return; } # 29/05/2010
        if ($text =~ /\b(XtOpenApplication)\b.*libXt/) { $$ignore_r = $&; return; } # 29/05/2010
        if ($text =~ /\b(XtRealizeWidget)\b.*libXt/) { $$ignore_r = $&; return; } # 29/05/2010
        if ($text =~ /\b(XtVaCreateManagedWidget)\b.*libXt/) { $$ignore_r = $&; return; } # 29/05/2010
        if ($text =~ /\b(XtVaCreatePopupShell)\b.*libXt/) { $$ignore_r = $&; return; } # 29/05/2010
        if ($text =~ /\b(XtVaSetValues)\b.*libXt/) { $$ignore_r = $&; return; } # 29/05/2010
        if ($text =~ /\b(XtVaCreateWidget)\b.*libXt/) { $$ignore_r = $&; return; } # 03/12/2013
        if ($text =~ /\b(XtParseTranslationTable)\b.*libXt/) { $$ignore_r = $&; return; } # 03/12/2013
        if ($text =~ /\b(XtAugmentTranslations)\b.*libXt/) { $$ignore_r = $&; return; } # 03/12/2013
        if ($text =~ /\b(XQueryColor|XGetGeometry|XAllocNamedColor)\b.*libX11/) { $$ignore_r = $&; return; } # 04/12/2013
      }
    }
    else { # illegal memory access (in fact everything else -- @@@ need condition here)
      # X11 bugs:
      if ($text =~ /\b(_X11TransWrite)\b.*libX11/) { $$ignore_r = $&; return; } # 24/11/2005
      if ($text =~ /\b(_XSend)\b.*libX11/) { $$ignore_r = $&; return; } # 16/05/2009
      # Xtoolkit bugs:
      if ($text =~ /\b(_XtGet(Sub)?[rR]esources)\b.*libXt/) { $$ignore_r = $&; return; } # 24/11/2005
      if ($text =~ /\b(XtOpenApplication)\b.*libXt/) { $$ignore_r = $&; return; } # 13/06/2009
      # motif bugs:
      if ($text =~ /\b(XmRenderTableCopy)\b.*libXm/) { $$ignore_r = $&; return; } # 09/02/2009
      if ($text =~ /\b(XmRenderTableFree)\b.*libXm/) { $$ignore_r = $&; return; } # 09/02/2009
      if ($text =~ /\b(XmIsMotifWMRunning)\b.*libXm/) { $$ignore_r = $&; return; } # 13/06/2009
      if ($text =~ /\b(XmGetPixmap)\b.*libXm/) { $$ignore_r = $&; return; } # 22/04/2010
    }
  }
}

sub check_ignore_internal($\$$) {
  my ($text,$ignore_r,$reason) = @_;
  if (not defined $$ignore_r) {
    # defines ignored leaks/errors occurring in internal libraries (wontfixes)
    # To ignore them add a search expression here.
    # Please add current date as well, to make it easier to find outdated expressions.

    # print "check_ignore_internal: reason='$reason'\n";

    if ($reason =~ 'loss record') { # memory leaks
      if ($reason =~ 'still reachable' or $reason =~ 'possibly lost') { # reachable memory leaks
        # things broken in ARB motif (wontfix; remove these exclusions after gtk merge)
        if ($text =~ /\b(aw_create_shell)\b/) { $$ignore_r = $&; return; } # 03/12/2013
        if ($text =~ /\b(AW_window::(load_xfig|insert_option_internal))\b/) { $$ignore_r = $&; return; } # 04/12/2013
        if ($text =~ /\b(gbmGetMemImpl)\b/) { $$ignore_r = $&; return; } # 04/12/2013 -- not all blocks of internal mem.management were freed (set MEMORY_TEST 1 in gb_memory.h to find leakers)
      }
      elsif ($reason =~ 'definitely lost') { # unreachable memory leaks
        if ($text =~ /\b(awt_create_selection_list_on_(trees|alignments))\b/) { $$ignore_r = $&; return; } # 03/12/2013
        if ($text =~ /\b(AW_window::(create_toggle|create_option_menu))\b/) { $$ignore_r = $&; return; } # 03/12/2013
        if ($text =~ /\b(AW_root::create_colormap)\b/) { $$ignore_r = $&; return; } # 03/12/2013
      }
      if ($text =~ /\b(AW_manage_GC)\b/) { $$ignore_r = $&; return; } # 04/12/2013
    }
    elsif ($reason =~ 'file descriptor') { # open file descriptors
      if ($text =~ /\b(aw_initstatus)\b/) { $$ignore_r = $&; return; } # 03/12/2013
    }
    # else { # illegal memory access
    # }
  }
}



sub is_boring($) {
  my ($text) = @_;
  if ($text =~ /provoke_core_dump/) { return 1; }
  return 0;
}

my $debug = 0;

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

# get args:

my $args = scalar(@ARGV);

if ($args<2 or $args>3) { die "Usage: valgrind2grep <callers> <filter> [--suppress-common]\n"; }
my $callers = $ARGV[0];
my $filter  = $ARGV[1];

my $suppress_common = 0;
if ($args==3) {
  my $a = $ARGV[2];
  if ($a eq '--suppress-common') { $suppress_common=1; }
  else { die "Unknown argument '$a'"; }
}

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

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

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

# read list of source files:

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

my %fileIndex = ();

sub addFileIndex($$) {
  my ($key,$val) = @_;
  if (not exists $fileIndex{$key}) {
    my @array = ();
    $fileIndex{$key} = \@array;
  }
  my $array_r = $fileIndex{$key};
  push @$array_r, $val;
}

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

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

close(SOURCELIST);

sub parentDir($) {
  my ($dirOrFile) = @_;
  if ($dirOrFile =~ /\/[^\/]+$/o) { return $`; }
  return undef;
}

sub makeTargetAbsolute($$) {
  my ($abslink,$reltarget) = @_;
  my $absdir = parentDir($abslink);
  if (defined $absdir) {
    while ($reltarget =~ /^\.\.\//o) {
      $reltarget = $';
      my $absparent = parentDir($absdir);
      if (defined $absparent) {
        $absdir = $absparent;
      }
      else {
        die "Can't detect parent dir of '$absdir'";
      }
    }

    my $result = $absdir.'/'.$reltarget;
    return $result;
  }
  else {
    die "Can't detect parent dir of '$abslink'";
  }
}

# make entries unique
foreach (keys %fileIndex) {
  my $array_r = $fileIndex{$_};
  my %unique = map { $_ => 1; } @$array_r;

  my $changed = 1;
  while ($changed==1) {
    $changed = 0;
    my @del = ();
    my @add = ();
    foreach (keys %unique) {
      my $target = undef;
      eval { $target = readlink($_); };
      if ($@) {                 # a link with invalid target?
        push @del, $_;
        $out->print("Remove invalid link '$_' (Reason: $!)\n");
      }
      elsif (defined $target) { # a link with valid target
        $target = makeTargetAbsolute($_,$target);
        push @del, $_;
        push @add, $target;
        # $out->print("Replace link '$_'\n   by target '$target'\n");
        # $out->print("Target '$target' exists:".(-e $target ? 'yes' : 'no')."\n");
      }
      # else not a link
    }
    if (scalar(@del)) { foreach (@del) { delete $unique{$_}; } $changed=1; }
    if (scalar(@add)) { foreach (@add) { $unique{$_} = 1; } $changed=1; }
  }
  @$array_r = keys %unique;
}


$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)')
  ($_) = @_;
  s/([(].*)(:)(.*[)])/$1_$2_$3/ig;
  $_;
}

my $reg_topdir = qr/^$topdir\//o;

sub shorten_location($) {
  my ($locline) = @_;
  if ($locline =~ /^([^:]+):([0-9]+):/o) {
    my ($loc,$line,$msg) = ($1,$2,$');
    if ($loc =~ $reg_topdir) {
      $loc = $';
    }
    $locline = $loc.':'.$line.':'.$msg;
  }
  $locline;
}

my $entered=0;

sub entering() {
  if ($entered==0) {
    $out->print('vake[2]: Entering directory `'.$topdir."\'\n");
    $entered = 1;
  }
}
sub leaving() {
  if ($entered==1) {
    $out->print('vake[2]: Leaving directory `'.$topdir."\'\n");
    $entered = 0;
  }
}

sub hideMessages($\@) {
  my ($hidePrefix,$outstack_r) = @_;
  $hidePrefix = "($hidePrefix) ";
  @$outstack_r = map { $hidePrefix.$_; } @$outstack_r;
}

# variables:

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

# the filter loop:

my @outstack = ();

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
        my ($file,$line) = ($1,$2);
        if ($filtered == 1) {
          $_ = $unmark_filtered.' '.&avoid_location($_);
        }
        else {
          my $array_r = $fileIndex{$file};
          if (defined $array_r) {
            my @lines = ();
            if (scalar(@$array_r)>1) {
              push @lines, $unmark_rest."Multiple occurrences of '$file' - not sure which location is the correct one\n";
            }

            if ($reason eq $called_from) { # its a caller
              $caller_count++;
            }
            else {
              $caller_count = 0;
            }

            foreach my $replace (@$array_r) {
              if (not -f $replace) {
                $_ = "$sourcelist:1: might be outdated ($replace does not exist)\n";
              }
              else {
                $_ = "$replace:$line: $reason ($content)\n";
                if ($caller_count > $callers) {
                  $_ = $unmark_callers.$_;
                }             # hide this caller
              }
              push @lines, $_;
            }

            $reason = $called_from;
            $_ = join '', @lines;
          }
          else {                # location in unavailable file (i.e. in library)
            $_ = $unmark_rest.$prefix.$reason." $content (in unavailable file $file line $line)\n";
          }
          if ($reason ne $called_from) { $non_caller_reason = $reason; }
          if ($suppress_common==1) {
            check_ignore_internal($_, $ignore, $non_caller_reason);
          }
        }
      }
      else {                    # valgrind error w/o location
        $non_caller_reason = $reason;
        $_=$unmark_rest.' '.$_;
        if ($suppress_common==1) { check_ignore_external($_, $ignore, $reason); }
      }
    }
    else {                      # no location found
      if ($content =~ /^TRANSLATE: / or
          $content =~ /^Reading syms from/ or
          $content =~ /unhandled CFI instruction/ or # happens since gcc 5.4.2
          $content =~ /object doesn.t have a/) {
        $ignore_curr_line = 1;
      }
      elsif ($content =~ /^[ ]*$/) {
        if (defined $ignore) { hideMessages('ign2', @outstack); }
        foreach my $line (@outstack) { $out->print($line); } @outstack = ();
        $out->flush;

        $ignore = undef;
        $_      = '(    ) '.$_;
      }
      else {
        $reason = $content;
        $_='(    ) '.$_;

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

          if ($filtered == 1) { $ignore = undef; }
        }
        if ($filtered==0) { $non_caller_reason = $reason; }
      }
    }
  }

  my $boring = 0;
  if ($ignore_curr_line==0) {
    $boring = $ignore_curr_line = is_boring($_);
  }

  # print out line
  if ($ignore_curr_line==0) {
    if (not defined $ignore) {
      entering();
      push @outstack, shorten_location($_);
      $last_ignore = '';
    }
    else { # defined ignore
      # print "last_ignore='$last_ignore' ignore='$ignore'\n";
      if ($ignore ne $last_ignore) {
        hideMessages('ign3', @outstack);
        foreach my $line (@outstack) { $out->print($line); } @outstack = ();

        s/^\(note\)[ ]*//;
        $out->print("(igno) '$ignore' ".$_);
        $out->print("(skip) further messages suppressed\n");
        $out->flush;
        $last_ignore = $ignore;
      }
      else {
        if ($debug==1) {
          $out->print("(comm) ".$_);
          $out->flush;
        }
      }
    }
  }
  else {
    if ($boring) {
      $out->print("(BORE) ".$_);
      $out->flush();
    }
    elsif ($debug==1) {
      $out->print("(SUPP) ".$_);
      $out->flush();
    }
    $ignore_curr_line = 0;
  }
}

if (defined $ignore) { hideMessages('ign4', @outstack); }
foreach my $line (@outstack) { $out->print($line); } @outstack = ();
leaving();
$out->flush;

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