#!/usr/bin/perl -w
# $Id: xviv_msg_filter 1172 2019-06-29 07:27:24Z mueller $
# SPDX-License-Identifier: GPL-3.0-or-later
# Copyright 2016-2019 by Walter F.J. Mueller <W.F.J.Mueller@gsi.de>
#
#  Revision History:
# Date         Rev Version  Comment
# 2018-12-22  1091   1.1.3  add count-only rules; add -pcnt; add [bit] handling
# 2018-11-18  1072   1.1.2  display INFO Common 17-14 'further message disabled'
# 2018-08-11  1039   1.1.1  allow {yyyy.x} tags (in addition to ranges)
# 2017-06-06   909   1.1    add version-range tags
# 2016-06-04   772   1.0    Initial version
#

use 5.14.0;                                 # require Perl 5.14 or higher
use strict;                                 # require strict checking
use FileHandle;

use Getopt::Long;

my %opts = ();

GetOptions(\%opts, "help", "pacc", "pcnt")
  or bailout("bad command options");

my $type   = shift @ARGV;
my $mfsnam = shift @ARGV;
my $lognam = shift @ARGV;
my %finfokill;
my @flist;
my @mlist;
my %msgcnt;
my %msgsev;
my $nackcnt  = 0;
my $ackcnt   = 0;
my $imisscnt = 0;
my $rmisscnt = 0;
my $cntcnt   = 0;
my $timebad  = 0;
my $timegood = 0;
my $bitgood  = 0;

my $vercur;
my $vermin = "0000.0";
my $vermax = "9999.9";

my $retrobase = $ENV{RETROBASE};

autoflush STDOUT 1 if (-p STDOUT);          # autoflush if output into pipe

if (exists $opts{help}) {
  print_help();
  exit 0;
}

if (!defined $type || !defined $mfsnam || !defined $lognam) {
  bailout("one of 'type mfset log' missing");
}

if ($type !~ m{^(syn|imp|bit)$}) {
  bailout("type must be syn, imp or bit");
}

if (read_ver($lognam)) {exit 1;}
if (read_mfs($mfsnam)) {exit 1;}
if (read_log($lognam)) {exit 1;}

foreach my $m (@mlist) {
  my $msgmatch = 0;

  # check for timing closure
  #   bad:  [Route 35-39] The design did not meet timing requirements
  #   bad:  [Timing 38-282] The design failed to meet the timing ...
  #   good: [Route 35-61] The design met the timing requirement
  $timebad  += 1 if $type eq 'imp' && $$m{code} eq 'Route 35-39';
  $timebad  += 1 if $type eq 'imp' && $$m{code} eq 'Timing 38-282';
  $timegood += 1 if $type eq 'imp' && $$m{code} eq 'Route 35-61';
  # check for proper bitstream generation
  #   good: [Vivado 12-1842] Bitgen Completed Successfully
  $bitgood  += 1 if $type eq 'bit' && $$m{code} eq 'Vivado 12-1842';

  foreach my $f (@flist) {
    if ($$f{rege} eq '') {
      $msgmatch = $$m{code} eq $$f{code};
    } else {
      $msgmatch = $$m{code} eq $$f{code} && $$m{text} =~ m{$$f{rege}};
    }
    if ($msgmatch) {
      #print "+++m '$fmode' '$fcode' '$frege' : '$mcode' '$mtext'\n";
      $$f{cnt} += 1;
      last;
    }
  }

  # accept all INFO except 'further msg disabled'
  # show 'further msg disabled' only
  #   if the code is not an INFO messages
  #   if the code is not covered by a 'I' rule
  if ($$m{sev} eq 'INFO') {
    if ($$m{code} eq 'Common 17-14') {
      if ($$m{text} =~ m/Message '(.*?)' appears/) {
        my $code = $1;
        $msgmatch = 1 if exists $msgsev{$code} && $msgsev{$code} eq 'INFO';
        $msgmatch = 1 if $finfokill{$code};
      }
    } else {
      $msgmatch = 1;
    }
  }

  if ($msgmatch) {
    $$m{cnt} += 1;
  } else {
    $nackcnt += 1;
  }
}

if ($nackcnt) {
  print "Unexpected messages of type [$type] from $lognam:\n";
  foreach my $m (@mlist) {
    next if $$m{cnt};

    # now prety print the message
    #   remove $RETROBASE from file names
    my $mtext = $$m{text};
    $mtext =~ s/${retrobase}/.../g if defined $retrobase;
    #   and break it up into 80 character wide lines
    my @mwl = split /\s+/,$mtext;
    unshift @mwl, '[' . $$m{code} . ']';
    unshift @mwl, $$m{sev} . ':';
    my $pref = '   ';
    my $line = ' ';
    while (scalar(@mwl)) {
      my $word = shift @mwl;
      if (length($line) + length($word) + 1 > 80) {
        print "$line\n";
        $line = $pref;
      }
      $line .= ' ' . $word;
    }
    print "$line\n" if $line ne $pref;
  }
  print "\n";
}

foreach my $f (@flist) {
  if ($$f{cnt} != 0) {                     # matches seen
    $ackcnt  += 1;
  } else {                                 # matches not seen
    if ($$f{mode} eq 'i') {                  # complain if 'i'
      $imisscnt += 1;
    } elsif ($$f{mode} eq 'r') {             # complain if 'r'
      $rmisscnt += 1;
    } elsif ($$f{mode} eq 'c') {             # show count if 'c'
      $cntcnt += 1;
    }
  }
}

if ($ackcnt && exists $opts{pacc}) {
  print "Accepted messages for type [$type] from $lognam:\n";
  foreach my $f (@flist) {
    next if $$f{cnt} == 0;
    printf "%4d: [%s] %s\n", $$f{cnt}, $$f{code}, $$f{rege};
  }
  print "\n";
}

if ($cntcnt) {
  print "Count-only filter rules for $lognam:\n";
  foreach my $f (@flist) {
    printf "%4d: [%s] %s\n", $$f{cnt}, $$f{code}, $$f{rege}
      if $$f{mode} eq 'c';
  }
  print "\n";
}

if ($imisscnt) {
  print "Ignore filter rules with no matches for type [$type] from $lognam:\n";
  foreach my $f (@flist) {
    next if $$f{cnt} != 0;
    printf "%4d: [%s] %s\n", $$f{cnt}, $$f{code}, $$f{rege} if $$f{mode} eq 'i';
  }
  print "\n";
}

if ($rmisscnt) {
  print "Missed required messages for type [$type] from $lognam:\n";
  foreach my $f (@flist) {
    next if $$f{cnt} != 0;
    printf "%4d: [%s] %s\n", $$f{cnt}, $$f{code}, $$f{rege} if $$f{mode} eq 'r';
  }
  print "\n";
}

if ($opts{pcnt}) {
  print "Message statistics:\n";
  foreach my $code (sort keys %msgcnt) {
    printf "%4d  %s : %s\n", $msgcnt{$code}, $code, $msgsev{$code};
  }
  print "\n";
}

if ($type eq 'imp' && ($timebad > 0 || $timegood == 0)) {
  printf "!! ------------------------------ !!\n";
  printf "!! FAILED TO REACH TIMING CLOSURE !!\n";
  printf "!! ------------------------------ !!\n";
}
if ($type eq 'bit' && $bitgood == 0) {
  printf "!! --------------------------- !!\n";
  printf "!! FAILED TO CREATE BIT STREAM !!\n";
  printf "!! --------------------------- !!\n";
}

#-------------------------------------------------------------------------------
sub read_mfs {
  my ($fname) = @_;

  if (not -r $fname) {
    print STDERR "xviv_msg_filter-E: '$fname' not existing or readable\n";
    return 1;
  }

  my $fh = new FileHandle;
  $fh->open($fname) or bailout("can't open for read '$fname': $!");

  my $intyp = 0;

  while (<$fh>) {
    chomp;
    s/#.*//;                                # remove comments after #
    s/\s+$//;                               # remove trailing blanks
    next if /^\s*$/;			    # drop empty lines

    if (/^\@(.+)$/) {                       # @<filename> found
      my $rc = read_mfs($1);
      return $rc if $rc;
      next;
    }

    if (m{^\[([a-z]{3})\]$}) {              # [typ] tag found
      if ($1 eq $type) {
        $intyp = 1;
        $vermin = "0000.0";
        $vermax = "9999.9";
      } else {
        $intyp = 0;
      }
      next;
    }

    next unless $intyp;                     # only process relevant lines

    if (m/\{(\d{4}\.\d)}/) {                # {ver} tag found
      $vermin = $1;
      $vermax = $1;
      next;
    }

    if (m/\{(\d{4}\.\d)?:(\d{4}\.\d)?\}/) {  # {vermin:varmax} tag found
      $vermin = (defined $1) ? $1 : "0000.0";
      $vermax = (defined $2) ? $2 : "9999.9";
      next;
    }

    next if $vercur lt $vermin || $vercur gt $vermax;

    if (/^([iIrc])\s+\[(.+?)\]\s*(.*)\s*$/) {
      #print "+++0m '$1' '$2' '$3'\n";
      my $fmode = $1;
      my $fcode = $2;
      my $frege = $3;
      $frege =~ s/\[/\\\[/g;
      $frege =~ s/\]/\\\]/g;
      push @flist, {mode => $fmode,
                    code => $fcode,
                    rege => $frege,
                    cnt  => 0};
      $finfokill{$fcode} += 1 if $fmode eq 'I';
    } else {
      printf STDERR "xviv_msg_filter-E: bad line in mfset: '%s'\n", $_;
    }
  }

  $fh->close();

  return 0;
}

#-------------------------------------------------------------------------------
sub read_log {
  my ($fname) = @_;

  if (not -r $fname) {
    print STDERR "xviv_msg_filter-E: \'$fname\' not existing or readable\n";
    return 1;
  }

  open (LFILE, $fname) or bailout("can't open for read '$fname': $!");

  my $skip = $type eq 'bit';                # enable skip for bit

  while (<LFILE>) {
    chomp;
    if ($type eq 'bit') {
      $skip = 0 if m/INFO: \[Common 17-206\] Exiting Vivado/;
      next if $skip;
    }

    if (m{^(INFO|WARNING|CRITICAL WARNING|ERROR):\s*\[(.+?)\]\s*(.*)}) {
      # print "+++0l '$1' '$2' '$3'\n";
      push @mlist, {sev  => $1,
                    code => $2,
                    text => $3,
                    cnt  => 0};
      $msgcnt{"$2"} += 1;                   # message counter
      $msgsev{"$2"}  = $1;                  # message severity tracking
    }
  }

  close (LFILE);

  return 0;
}

#-------------------------------------------------------------------------------
sub read_ver {
  my ($fname) = @_;

  if (not -r $fname) {
    print STDERR "xviv_msg_filter-E: \'$fname\' not existing or readable\n";
    return 1;
  }

  open (LFILE, $fname) or bailout("can't open for read '$fname': $!");

  my $nline = 0;
  while (<LFILE>) {
    chomp;
    if (m/\*\*\*\*\*\* Vivado v(\d{4}\.\d)/) {
      $vercur = $1;
      close (LFILE);
      return 0;
    }
    last if $nline++ > 100;                 # stop looking after 100 lines
  }

  close (LFILE);
  print STDERR "xviv_msg_filter-E: no vivado version found in \'$fname\'\n";
  return 1;
}

#-------------------------------------------------------------------------------

sub bailout {
  my ($msg) = @_;
  print STDERR "xviv_msg_filter-F: $msg\n";
  exit 1;
}

#-------------------------------------------------------------------------------

sub print_help {
  print "usage: xviv_msg_filter [options] type mfset log\n";
  print "  type   log file type: syn, imp or bit\n";
  print "  mfset  message filter set file\n";
  print "  log    log file\n";
  print "  Options:\n";
  print "    --pacc           print summary of accepted messages\n";
  print "    --pcnt           print message counts\n";
  print "    --help           this message\n";
}
