#!/usr/bin/perl -w
# $Id: tbfilt 1065 2018-11-04 11:32:06Z mueller $
#
# Copyright 2016-2018 by Walter F.J. Mueller <W.F.J.Mueller@gsi.de>
#
# This program is free software; you may redistribute and/or modify it under
# the terms of the GNU General Public License as published by the Free
# Software Foundation, either version 3, or (at your option) any later version.
#
# This program is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY, without even the implied warranty of MERCHANTABILITY
# or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
# for complete details.
#
#  Revision History:
# Date         Rev Version  Comment
# 2018-11-03  1065   1.1    add and use bailout; update exit code usage
# 2016-09-10   806   1.0    Initial version
# 2016-08-05   795   0.1    First draft
#

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

use Getopt::Long;
use FileHandle;
use POSIX qw(strftime);

my %opts = ();

GetOptions(\%opts, "tee=s",  "pcom",
           "find=s", "all",
           "summary", "wide", "compact", "format=s", "nohead"
          )
  or bailout("bad command options");

sub conv_fd;
sub conv_ft;
sub conv_fs;
sub conv_fa;
sub conv_tr;
sub conv_tu;
sub conv_ts;
sub conv_tc;
sub conv_tg;
sub conv_st;
sub conv_ss;
sub conv_sc;
sub conv_sg;
sub conv_sp;
sub conv_sm;
sub conv_ec;
sub conv_pf;
sub conv_nf;
sub conv_ns;

my %fmttbl = (fd => {conv => \&conv_fd, head=>' file-date'},
              ft => {conv => \&conv_ft, head=>'    time'},
              fs => {conv => \&conv_fs, head=>' time'},
              fa => {conv => \&conv_fa, head=>'age'},
              tr => {conv => \&conv_tr, head=>'  time-real'},
              tu => {conv => \&conv_tu, head=>'  time-user'},
              ts => {conv => \&conv_ts, head=>'   time-sys'},
              tc => {conv => \&conv_tc, head=>'   time-cpu'},
              tg => {conv => \&conv_tg, head=>'       time t'},
              st => {conv => \&conv_st, head=>'stime(ns)'},
              ss => {conv => \&conv_ss, head=>'stime'},
              sc => {conv => \&conv_sc, head=>'  cycles'},
              sg => {conv => \&conv_sg, head=>' cyc|tim'},
              sp => {conv => \&conv_sp, head=>'sperf'},
              sm => {conv => \&conv_sm, head=>'MHz'},
              ec => {conv => \&conv_ec, head=>'err'},
              pf => {conv => \&conv_pf, head=>'stat'},
              nf => {conv => \&conv_nf, head=>'filename'},
              ns => {conv => \&conv_ns, head=>'filename'});
my @fmtlst;

my $format = $ENV{TBFILT_FORMAT};
$format = '%fd %fs %tr %tc %sc %ec %pf %nf' if $opts{wide};
$format = '%fa %tg %sg %ec %pf %ns' if $opts{compact};
$format = $opts{format} if defined $opts{format};
$format = '%ec %pf %nf' unless defined $format;

while (length($format)) {
  if ($format =~ m/^([^%]*)%([a-z][a-z])/) {
    my $pref = $1;
    my $code = $2;
    if (exists $fmttbl{$code}) {
      push @fmtlst, {pref => $pref,
                     conv => $fmttbl{$code}{conv},
                     head => $fmttbl{$code}{head}};
    } else { last; };
    $format = $';
  } else { last; };
}
bailout("bad format '$format'") if length($format);

autoflush STDOUT 1 if (-p STDOUT);

my $fh_tee;
if (defined $opts{tee} && $opts{tee} ne '') {
  $fh_tee = new FileHandle;
  $fh_tee->open($opts{tee},'>') or
    bailout("failed to open for write '$opts{tee}': $!");
}

my @flist = @ARGV;

# if find pattern has no '*', expand it
if (defined $opts{find}) {
  unless ($opts{find} =~ m/\*/) {
    $opts{find} = '.*/tb_.*_' . $opts{find} . '.*\.log';
  }
}

if (defined $opts{all}) {
  if (defined $opts{find}) {
    print STDERR "tbfilt-I: -find ignored because -all given\n";
  }
  $opts{find} = '.*/tb_.*_[bfsorept]sim(_.*)?\.log';
}

if (defined $opts{find}) {
  if (scalar (@flist)) {
    print STDERR "tbfilt-I: file names ignored because -all or -find given\n";
    @flist = ();
  }
  open FIND,'-|',"find -regextype egrep -regex '$opts{find}'"
    or bailout("failed to open find pipe: $!");

  while (<FIND>) {
    chomp;
    s|^\./||;                               # drop leading ./
    push @flist, $_;
  }

  close FIND;
  @flist = sort @flist;
  bailout("no files found by -find or -all") if (scalar (@flist) == 0);

} else {
  push @flist, '-' if (scalar(@flist) == 0);
}

my $manyfile = scalar(@flist) > 1;
my $notsumm  = not $opts{summary};
my %vals;
my $exitcode = 0;

if ($opts{summary} && (not $opts{nohead})) {
  foreach my $item (@fmtlst) {
    print $item->{pref};
    print $item->{head};
  }
  print "\n";
}

foreach my $fnam (@flist) {
  my $nfail = do_file($fnam);
  $exitcode = 2 if $nfail;
}

exit $exitcode;

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

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

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

sub do_file {
  my ($fnam) = @_;

  %vals = ();
  $vals{fnam}  = $fnam;
  $vals{nfail} = 0;

  my $fh;
  if ($fnam eq '-') {
    $fh = *STDIN;
  } else {
    $fh = new FileHandle;
    $fh->open($fnam,'<') or bailout("failed to open for read '$fnam': $!");
  }

  if ($manyfile && $notsumm) {
    print "-- $fnam";
    my $npad = 74-length($fnam);
    print ' '.('-' x $npad) if $npad > 0;
    print "\n";
  }

  while (<$fh>) {
    print $fh_tee $_ if defined  $fh_tee;
    chomp;
    my $show;
    my $fail;

    $fail = 1 if m/-[EF]:/;
    $fail = 1 if m/(ERROR|FAIL)/;
    $show = 1 if m/-W:/;
    $show = 1 if m/(PASS)/;
    $show = 1 if $opts{pcom} && m/^C/;      # show lines starting with C

    # ghdl reports or assertions (warning and higher)
    if (m/:\((report|assertion) (warning|error|failure)\):/) {
      # ignore ieee lib warnings at t=0
      next if /:\@0ms:\(assertion warning\): NUMERIC_STD.*metavalue detected/;
      next if /:\@0ms:\(assertion warning\): CONV_INTEGER: There is an 'U'/;
      next if /std_logic_arith.*:\@0ms:\(assertion warning\): There is an 'U'/;
      # ignore ' Simulation Finished' report failure (used to end ghdl sim)
      next if /:\(report failure\): Simulation Finished/;
      $fail = 1;
    }

    # check for DONE line accept
    #           920 ns: DONE                   -- tb'swithout clock
    #     7798080.0 ns 389893: DONE            -- single clock tb's
    #       56075.0 ns   2094: DONE-w          -- multiclock tb's  (max taken)
    #
    if (m/^\s*(\d+\.?\d*)\s+ns\s*(\d*):\s+DONE(-\S+)?\s*$/) {
      $show = 1;
      $vals{done_ns}  = $1;
      if ($2 ne '') {
        if (defined $vals{done_cyc}) {
          $vals{done_cyc} = $2 if $2 > $vals{done_cyc};
        } else {
          $vals{done_cyc} = $2;
        }
      }
    }

    # check for time line
    # Note: don't root the pattern with /^ --> allow arbitary text before
    #       the 'time' output. In practice 'time' output (to stderr by bash)
    #       and ghdl 'report' (also to stderr) get mixed and one might get
    #         tb_w11a_b3real 0m49.179s   user 0m0.993s   sys 0m0.293s
    #
    if (m/real\s+(\d*)m(\d+\.\d*)s\s+
          user\s+(\d*)m(\d+\.\d*)s\s+
           sys\s+(\d*)m(\d+\.\d*)s/x) {
      $show = 1;
      $vals{treal} = [$1,$2];
      $vals{tuser} = [$3,$4];
      $vals{tsys}  = [$5,$6];
    }

    print "$_\n" if ($show || $fail) && $notsumm;
    $vals{nfail} += 1 if $fail;
  }

  if (not defined $vals{done_ns}) {
    print "tbfilt-I: no DONE seen; FAIL\n" if $notsumm;
    $vals{nfail} += 1;
  }

  $vals{mtime} = ($fnam eq '-') ? time :  (stat($fh))[9];

  if ($opts{summary}) {
    foreach my $item (@fmtlst) {
      print $item->{pref};
      print &{$item->{conv}};
    }
    print "\n";
  }

  return $vals{nfail};
}

#-------------------------------------------------------------------------------
sub time_val {
  my ($tdsc) = @_;
  return undef unless defined $tdsc;
  return 60.*$tdsc->[0] + $tdsc->[1];
}

sub time_str {
  my ($tdsc) = @_;
  return '          -' unless defined $tdsc;
  return sprintf '%3dm%06.3fs', $tdsc->[0],$tdsc->[1];
}

sub time_sum {
  my ($tdsc1,$tdsc2) = @_;
  return undef unless defined $tdsc1 && defined $tdsc2;
  return time_val($tdsc1) + time_val($tdsc2);
}

sub gconv {
  my ($val) = @_;
  my $str = sprintf '%4.2f', $val;
  return substr($str,0,4);
}

#-------------------------------------------------------------------------------
sub conv_fd {
  return strftime "%F", localtime($vals{mtime});
}

sub conv_ft {
  return strftime "%T", localtime($vals{mtime});
}

sub conv_fs {
  return strftime "%H:%M", localtime($vals{mtime});
}

sub conv_fa {
  my $dt = time - $vals{mtime};
             return sprintf '%2ds', $dt if $dt < 99;
  $dt /= 60; return sprintf '%2dm', $dt if $dt < 99;
  $dt /= 60; return sprintf '%2dh', $dt if $dt < 60;
  $dt /= 24; return sprintf '%2dd', $dt if $dt < 99;
             return 'old';
}

sub conv_tr {
  return time_str($vals{treal});
}

sub conv_tu {
  return time_str($vals{tuser});
                }

sub conv_ts {
  return time_str($vals{tsys});
}

sub conv_tc {
  my $tsum = time_sum($vals{tuser}, $vals{tsys});
  return '          -' unless defined $tsum;
  my $min = int($tsum/60.);
  my $sec = $tsum - 60. * $min;
  return sprintf '%3dm%06.3fs', $min, $sec;
}

sub conv_tg {
  my $treal = time_val($vals{treal});
  my $tcpu  = time_sum($vals{tuser}, $vals{tsys});
  if (defined $treal && defined $tcpu && $tcpu > 0.4 * $treal) {
    return conv_tc() . ' c' ;
  } else {
    return conv_tr() . ((defined $treal) ? ' r': ' -');
  }
}

sub conv_st {
  return '        -' unless defined $vals{done_ns};
  return sprintf '%9d', $vals{done_ns};
}

sub conv_ss {
  return '    -' unless defined $vals{done_ns};
  my $stim = 0.001 * $vals{done_ns};
                  return gconv($stim) . 'u' if $stim < 999;
  $stim *= 0.001; return gconv($stim) . 'm' if $stim < 999;
  $stim *= 0.001; return gconv($stim) . 's';
}

sub conv_sc {
  return '       -' unless defined $vals{done_cyc};
  return sprintf '%8d', $vals{done_cyc};
}

sub conv_sg {
  return conv_sc() if defined $vals{done_cyc};
  return '   ' . conv_ss();
}

sub conv_sp {
  my $nc   = $vals{done_cyc};
  my $tsum = time_sum($vals{tuser}, $vals{tsys});
  return '    -' unless defined $nc && defined $tsum;
  my $sperf = 1000000. * $tsum / $nc;
                   return gconv($sperf) . 'u' if $sperf < 999;
  $sperf *= 0.001; return gconv($sperf) . 'm';
}

sub conv_sm {
  return '  -' unless defined $vals{done_ns} && $vals{done_ns} > 200 &&
                      defined $vals{done_cyc};
  my $mhz = (1000. * $vals{done_cyc}) / ($vals{done_ns} - 200);
  return sprintf '%3d', int($mhz+0.5);
}

sub conv_ec {
  return sprintf '%3d', $vals{nfail};
}

sub conv_pf {
  return $vals{nfail} ? 'FAIL' : 'PASS';
}

sub conv_nf {
  return $vals{fnam};
}

sub conv_ns {
  my $val = $vals{fnam};
  $val =~ s|^.*/||;
  return $val;
}