source: branches/items/UNIT_TESTER/reporter.pl

Last change on this file was 18311, checked in by westram, 6 years ago
  • Property svn:executable set to *
File size: 15.8 KB
Line 
1#!/usr/bin/perl
2
3use strict;
4use warnings;
5
6use lib $ENV{ARBHOME}.'/SOURCE_TOOLS';
7use arb_build_common;
8
9# --------------------------------------------------------------------------------
10
11my $logdirectory = undef;
12my $slow_delay   = undef;
13
14my $verbose = 0;
15
16# --------------------------------------------------------------------------------
17
18sub getModtime($) {
19  my ($file_or_dir) = @_;
20  if (-f $file_or_dir or -d $file_or_dir) {
21    my @st = stat($file_or_dir);
22    if (not @st) { die "can't stat '$file_or_dir' ($!)"; }
23    return $st[9];
24  }
25  return 0; # does not exist -> use epoch
26}
27sub getAge($) { my ($file_or_dir) = @_; return time-getModtime($file_or_dir); }
28
29# --------------------------------------------------------------------------------
30
31# when file $slow_stamp exists, slow tests get skipped (see sym2testcode.pl@SkipSlow)
32my $slow_stamp = 'skipslow.stamp';
33my $slow_age   = getAge($slow_stamp); # seconds since of last successful slow test
34
35sub shall_run_slow() { return (($slow_delay==0) or ($slow_age>($slow_delay*60))); }
36
37sub slow_init() {
38  if (shall_run_slow()) {
39    print "Running SLOW tests\n";
40    unlink($slow_stamp);
41  }
42  else {
43    print "Skipping SLOW tests\n";
44  }
45}
46
47sub slow_cleanup($) {
48  my ($tests_failed) = @_;
49
50  if (shall_run_slow() and not $tests_failed) {
51    system("touch $slow_stamp");
52  }
53}
54
55# --------------------------------------------------------------------------------
56
57sub get_existing_logs() {
58  my @logs;
59  opendir(LOGDIR,$logdirectory) || die "can't read directory '$logdirectory' (Reason: $!)";
60  foreach (readdir(LOGDIR)) {
61    if (/\.log$/o) { push @logs, $logdirectory.'/'.$_; }
62  }
63  closedir(LOGDIR);
64  return @logs;
65}
66
67sub do_init() {
68  if (-d $logdirectory) {
69    my @logs = get_existing_logs();
70    foreach (@logs) { unlink($_) || die "can't unlink '$_' (Reason: $!)"; }
71  }
72  slow_init();
73  return undef;
74}
75# --------------------------------------------------------------------------------
76
77my $expand_list_read = 0;
78my @expand_list = ();
79
80sub add_std_expands() {
81  my $ARBHOME = $ENV{ARBHOME};
82  push @expand_list, $ARBHOME.'/UNIT_TESTER/Makefile.test';
83  push @expand_list, $ARBHOME.'/UNIT_TESTER/Makefile.suite';
84}
85
86sub read_expand_list() {
87  my $expand_list = "../SOURCE_TOOLS/valgrind2grep.lst";
88
89  if (not -f $expand_list) {
90    my $cmd = '(cd ../SOURCE_TOOLS; make valgrind_update)';
91    system($cmd)==0 || die "failed to execute '$cmd' (Reason: $?)";
92  }
93
94  my $dir = `pwd`;
95  open(LIST,'<'.$expand_list) || die "can't read '$expand_list' (Reason: $!) in dir '$dir'";
96  my $line;
97  while (defined($line=<LIST>)) {
98    chomp($line);
99    push @expand_list, $line;
100  }
101  close(LIST);
102
103  add_std_expands();
104
105  $expand_list_read = 1;
106}
107
108my %expanded = (); # key=$filename, value=ref to array of possible expanded filenames.
109
110sub get_expanded_filenames($) { # @@@ move into arb_build_common
111  my ($file) = @_;
112
113  my $found_r = $expanded{$file};
114  if (not defined $found_r) {
115    if ($expand_list_read==0) { read_expand_list(); }
116    my @expanded = ();
117    foreach (@expand_list) { if (/\/$file$/) { push @expanded, $_; } }
118    $expanded{$file} = \@expanded;
119    $found_r = $expanded{$file};
120  }
121  return @$found_r;
122}
123
124sub print_expand_pathless_messages($$) {
125  my ($line,$topdir) = @_;
126  chomp($line);
127  if ($line =~ /^([a-z0-9_\.\/]+):([0-9:]+):/oi) {
128    my ($file,$lineCol,$rest) = ($1,$2,$');
129    my @expanded = get_expanded_filenames($file);
130
131    if (scalar(@expanded)==0) {
132      print "$file:$lineCol: [unknown -> call 'make valgrind_update'] $rest\n";
133    }
134    else {
135      foreach (@expanded) {
136        my $expFile = $_;
137        my $relFile = $expFile;
138        removeDirPrefix($topdir,$relFile);
139        if ($verbose) {
140          print "$relFile:$lineCol: $rest"." [path expanded: '$file'->'$expFile'->'$relFile']\n";
141        }
142        else {
143          print "$relFile:$lineCol: $rest\n";
144        }
145      }
146    }
147  }
148  else {
149    print $line."\n";
150  }
151}
152
153sub dump_log($) {
154  my ($log) = @_;
155
156  my @former_dirs = ();
157
158  my $topdir = $ENV{ARBHOME};
159  my $currDir = $topdir;
160
161  open(LOG,'<'.$log) || die "can't open '$log' (Reason: $!)";
162  my $seen_AS = 0;
163  my $line;
164  while (defined($line=<LOG>)) {
165    my $printed = 0;
166    if ($seen_AS==1) {
167      my $formatted_line = format_asan_line($line,$currDir);
168      if (defined $formatted_line) {
169        if ($verbose) {
170          print_expand_pathless_messages(add_suffix($formatted_line,' [formatted_DL]'), $currDir);
171        }
172        else {
173          print_expand_pathless_messages($formatted_line, $currDir);
174        }
175        $printed = 1;
176      }
177    }
178    else {
179      if ($line =~ /(AddressSanitizer|LeakSanitizer|runtime.error:)/o) {
180        $seen_AS = 1;
181        if (defined $topdir) {
182          print('fake[2]: Entering directory `'.$topdir."\'\n");
183          $currDir = $topdir;
184        }
185      }
186    }
187    if ($printed==0) {
188      if ($line =~ /:\s(Entering|Leaving)\s+directory\s+[`']([^`']+)[`']$/o) {
189        my ($what,$where) = ($1,$2);
190        if ($verbose) { print "[detected dir-change: what='$what' where='$where']\n"; }
191
192        if ($what eq 'Entering') {
193          push @former_dirs, $currDir;
194          $currDir = $where;
195        }
196        else {
197          if ($what ne 'Leaving') { die "confused"; }
198          $currDir = pop @former_dirs;
199          if ($verbose) { print "[changing dir '$where' -> '$currDir']\n"; }
200        }
201
202        print $line; # do not modify enter/leave lines
203      }
204      elsif ($verbose) {
205        print_expand_pathless_messages(add_suffix($line,' [unformatted_DL seen_AS='.$seen_AS.']'), $currDir);
206      }
207      else {
208        print_expand_pathless_messages($line, $currDir);
209      }
210    }
211  }
212  if (defined $topdir and $seen_AS==1) { print('fake[2]: Leaving directory `'.$topdir."\'\n"); }
213  close(LOG);
214}
215
216# --------------------------------------------------------------------------------
217
218sub dump_junitlog(\@) {
219  my ($content_r) = @_;
220  my $logfile = "logs/junit_log.xml"; # see also Makefile.suite@JUNITLOGNAME
221  open(JLOG,'>'.$logfile) || die "can't write '$logfile' (Reason: $!)";
222  print JLOG "<testsuites>\n";
223  foreach (@$content_r) {
224    print JLOG $_."\n";
225  }
226  print JLOG "</testsuites>\n";
227  close(JLOG);
228}
229
230sub removeDonefileFor($) {
231  my ($unitName) = @_;
232
233  my @donefiles = ();
234  my $donefile_dir = ($slow_delay==0) ? 'tests.slow' : 'tests';
235  opendir(DIR,$donefile_dir) || die "can't read directory '$donefile_dir' (Reason: $!)";
236  foreach (readdir(DIR)) {
237    if (/\.done$/o) {
238      if (/$unitName/) {
239        push @donefiles, $_;
240      }
241    }
242  }
243  closedir(DIR);
244
245  my $donefiles = scalar(@donefiles);
246  if ($donefiles==1) {
247    my $donefile = $donefile_dir.'/'.$donefiles[0];
248    print "Unlinking $donefile (for unit '$unitName')\n";
249    unlink($donefile);
250  }
251  else {
252    print "donefiles found: $donefiles\n";
253    if ($donefiles>0) {
254      foreach (@donefiles) { print "- $_\n"; }
255      die "could not determine .done-file for '$unitName'";
256    }
257  }
258}
259
260# --------------------------------------------------------------------------------
261
262my $tests     = 0;
263my $skipped   = 0;
264my $passed    = 0;
265my $failed    = 0;
266my $warnings  = 0;
267my $elapsed   = 0;
268my $crashed   = 0;
269my $valgrind  = 0;
270my $sanitized = 0;
271
272my %duration = (); # key=unit, value=ms
273
274sub parse_log($\@) {
275  # parse reports generated by UnitTester.cxx@generateReport
276  my ($log,$junit_r) = @_;
277  open(LOG,'<'.$log) || die "can't open '$log' (Reason: $!)";
278
279  my $tests_this    = 0;
280  my $skipped_this  = 0;
281  my $passedALL     = 0;
282  my $seenSummary   = 0;
283  my $seenSanitized = 0;
284
285  my $curr_target        = undef;
286  my $last_error_message = undef;
287
288  my $unitName = 'unknownUnit';
289  if ($log =~ /\/([^\.\/]+)\.[^\/]+$/o) { $unitName = $1; }
290
291  my $dump_log = 0;
292  my $remove_donefile = 0;
293
294  my @testcases   = ();
295  my $case_ok     = 0;
296  my $case_failed = 0;
297
298  while ($_ = <LOG>) {
299    chomp;
300    if (/^UnitTester:/) {
301      my $rest = $';
302      if ($rest =~ /^\s+\*\s+([A-Za-z0-9_]+)\s+=\s+([A-Z]*)/o) {
303        my ($testname,$result) = ($1,$2);
304        my $err = undef;
305        if ($result ne 'OK') {
306          if (defined $last_error_message) {
307            $err = $last_error_message;
308          }
309          else {
310            $err = 'unknown failure reason';
311          }
312        }
313        # append to junit log
314        my $testcase = "  <testcase name=\"$testname\" classname=\"$unitName.noclass\"";
315        if (defined $err) {
316          $testcase .= ">\n";
317          $testcase .= "   <error message=\"$err\"/>\n";
318          $testcase .= "  </testcase>";
319          $case_failed++;
320        }
321        else {
322          $testcase .= '/>';
323          $case_ok++;
324        }
325        push @testcases, $testcase;
326        $last_error_message = undef;
327      }
328
329      if (/tests=([0-9]+)/)   { $tests_this += $1; $seenSummary=1; }
330      if (/skipped=([0-9]+)/) {
331        $skipped_this += $1;
332        if (shall_run_slow()) {
333          $dump_log = 1; # @@@ TODO: should dump log only if warnings are enabled
334        }
335      }
336
337      if (/passed=([0-9]+)/)  { $passed += $1; }
338      if (/passed=ALL/)       { $passedALL = 1; }
339
340      if (/failed=([0-9]+)/)  { $failed += $1; $dump_log = 1; }
341      if (/warnings=([0-9]+)/)  { $warnings += $1; if ($failed==0) { $dump_log = 1; } }
342      if (/target=([^\s]+)/)  { $curr_target = $1; }
343      if (/time=([0-9.]+)/)   {
344        $elapsed += $1;
345        if (not defined $curr_target) { die "Don't know current target"; }
346        $duration{$curr_target} = $1;
347      }
348      if (/valgrind.*error/)  { $valgrind++; $dump_log = 1; $remove_donefile = 1; }
349      if (/coverage/)  { $dump_log = 1; }
350    }
351    elsif (/^[^\s:]+:[0-9]+:\s+Error:\s+/o) {
352      if (not /\(details\sabove\)/) {
353        $last_error_message = $';
354      }
355    }
356    elsif (/^-+\s+(ARB-backtrace.*):$/) {
357      $last_error_message = $1;
358    }
359    elsif (/ERROR:\s*(AddressSanitizer|LeakSanitizer):/o) {
360      $last_error_message = $';
361      $seenSanitized++;
362      $remove_donefile = 1;
363    }
364    elsif (/\s+runtime\s+error:\s+/o) {
365      $dump_log = 1;
366    }
367  }
368  close(LOG);
369
370  if ($remove_donefile == 1) {
371    removeDonefileFor($unitName);
372  }
373
374  # write whole suite to junit log
375  {
376    my $case_all = $case_ok + $case_failed;
377    # my $stamp    = localtime;
378    my $stamp    = `date "+%Y-%m-%dT%T.%N%:z"`;
379    chomp($stamp);
380    push @$junit_r, " <testsuite name=\"$unitName\" tests=\"$case_all\" failures=\"$case_failed\" timestamp=\"$stamp\">";
381    foreach (@testcases) { push @$junit_r, $_; }
382    push @$junit_r, " </testsuite>";
383  }
384
385  if (not $seenSummary) { $dump_log = 1; }
386  if ($seenSanitized>0) { $dump_log = 1; }
387
388  if ($dump_log==1) {
389    dump_log($log);
390  }
391
392  if (not $seenSummary) {
393    my $ARBHOME = $ENV{ARBHOME};
394    print "$ARBHOME/UNIT_TESTER/$log:1:0: Warning: No summary found in '$log' ";
395    if ($seenSanitized>0) {
396      $sanitized++;
397      print "(was aborted by Sanitizer)\n";
398    }
399    else {
400      $crashed++;
401      print "(maybe the test did not compile or crashed)\n";
402    }
403  }
404  else {
405    if ($seenSanitized>0) {
406      $sanitized++;
407      print "Detected Sanitizer warnings\n";
408    }
409  }
410
411  $tests   += $tests_this;
412  $skipped += $skipped_this;
413
414  if ($passedALL==1) { $passed += ($tests_this-$skipped_this); }
415}
416
417sub percent($$) {
418  my ($part,$all) = @_;
419  if ($all) {
420    my $percent = 100*$part/$all;
421    return sprintf("%5.1f%%", $percent);
422  }
423  else {
424    $part==0 || die;
425    return "  0.0%";
426  }
427}
428
429sub slow_note() {
430  return (shall_run_slow() ? "" : " (slow tests skipped)");
431}
432
433my $BigOk = <<EndOk;
434  __  __ _    _  _
435 /  \\(  / )  (_)( \\
436(  O ))  (    _  ) )
437 \\__/(__\\_)  (_)(_/
438EndOk
439
440my $BigFailed = <<EndFailed;
441 ____  __   __  __    ____  ____   _
442(  __)/ _\\ (  )(  )  (  __)(    \\ / \\
443 ) _)/    \\ )( / (_/\\ ) _)  ) D ( \\_/
444(__) \\_/\\_/(__)\\____/(____)(____/ (_)
445EndFailed
446
447
448sub readableDuration($) {
449  # result should not be longer than 9 characters! (5 chars value, space, 3 chars unit)
450  my ($ms) = @_;
451  if ($ms>5000) {
452    my $sec = $ms / 1000.0;
453    if ($sec>99) {
454      my $min = $sec / 60.0;
455      return sprintf("%5.2f min", $min);
456    }
457    return sprintf("%5.2f sec", $sec);
458  }
459  return sprintf("%5i ms ", $ms);
460}
461
462sub trimTail($) {
463  my ($str) = @_;
464  $str =~ s/\s+$//go;
465  $str;
466}
467
468sub print_summary($) {
469  my ($tests_failed) = @_;
470  print "\n-------------------- [ Unit-test summary ] --------------------\n";
471
472  my @summary = ();
473
474  push @summary, sprintf(" Tests   : %5i", $tests);
475  push @summary, sprintf(" Skipped : %5i =%s%s", $skipped, percent($skipped,$tests), slow_note());
476  push @summary, sprintf(" Passed  : %5i =%s", $passed, percent($passed,$tests));
477  push @summary, sprintf(" Failed  : %5i =%s", $failed, percent($failed,$tests));
478  push @summary, sprintf(" Sum.dur.: %9s", trimTail(readableDuration($elapsed)));
479  {
480    my @slowest = sort {
481      $duration{$b} <=> $duration{$a};
482    } map {
483      if ((defined $_) and ($_ ne '') and $duration{$_}>0) { $_; }
484      else { ; }
485    } keys %duration;
486
487    my $show = scalar(@slowest);
488    if ($show>3) { $show = 3; }
489    if ($show>0) {
490      for (my $s=0; $s<$show; ++$s) {
491        my $slowunit = $slowest[$s];
492        push @summary, sprintf("%s%9s (%s)", ($s==0 ? " Max.dur.: " : "           "), readableDuration($duration{$slowunit}), $slowunit);
493      }
494    }
495  }
496  if ($sanitized>0) {
497    push @summary, sprintf(" Sanitizd: %5i units", $sanitized);
498  }
499  push @summary, sprintf(" Crashed : %5i units", $crashed);
500  push @summary, sprintf(" Warnings: %5i", $warnings);
501  if ($valgrind>0) {
502    push @summary, sprintf(" Valgrind: %5i failures", $valgrind);
503  }
504
505  my @big;
506  my $Big = $tests_failed ? $BigFailed : $BigOk;
507  @big= split '\n', $Big;
508
509  my $vOffset = scalar(@summary) - scalar(@big);
510  if ($vOffset<0) { $vOffset = 0; }
511
512  my $col = 0;
513  for (my $i=0; $i<scalar(@big); $i++) {
514    my $j = $i+$vOffset;
515    my $len = length($summary[$j]);
516    if ($len>$col) { $col = $len; }
517  }
518
519  $col += 6; # add horizontal offset
520
521  for (my $i=0; $i<scalar(@big); $i++) {
522    my $j = $i+$vOffset;
523    my $padded = $summary[$j];
524    my $len = length($padded);
525    while ($len<$col) { $padded .= ' '; $len++; }
526    $summary[$j] = $padded.$big[$i];
527  }
528
529  foreach (@summary) { print $_."\n"; }
530}
531
532sub do_report() {
533  my @junit = ();
534  my @logs = get_existing_logs();
535  foreach (@logs) {
536    parse_log($_,@junit);
537  }
538
539  dump_junitlog(@junit);
540
541  my $tests_failed = (($failed>0) or ($crashed>0) or ($valgrind>0) or ($sanitized>0));
542  print_summary($tests_failed);
543  slow_cleanup($tests_failed);
544  if ($tests_failed) {
545    my $ARBHOME = $ENV{ARBHOME};
546    print "rake[0]: Entering directory `$ARBHOME/UNIT_TESTER'\n";
547    die "tests failed\n";
548  }
549  return undef;
550}
551
552sub check_obsolete_restricts() {
553  my $restrict = $ENV{CHECK_RESTRICT};
554  if (not defined $restrict) {
555    print "Can't check restriction (empty)\n";
556  }
557  else {
558    $restrict = ':'.$restrict.':';
559    if ($restrict =~ /:(WINDOW|ARBDB|AWT|CORE):/) {
560      my $lib = $1;
561      my $msl = 'Makefile.setup.local';
562
563      print "UNIT_TESTER/$msl:1: Error: Obsolete restriction '$lib' (should be 'lib$lib')\n";
564      my $grepcmd = "grep -n \'RESTRICT_LIB.*=.*$lib\' $msl";
565      open(GREP,$grepcmd.'|') || die "can't execute '$grepcmd' (Reason: $?)";
566      foreach (<GREP>) {
567        print "UNIT_TESTER/$msl:$_";
568      }
569      die;
570    }
571  }
572}
573
574# --------------------------------------------------------------------------------
575
576sub main() {
577  my $error = undef;
578  my $cb    = undef;
579  {
580    my $args = scalar(@ARGV);
581    if ($args==3) {
582      my $command   = shift @ARGV;
583
584      if ($command eq 'init') { $cb = \&do_init; }
585      elsif ($command eq 'report') { $cb = \&do_report; }
586      else { $error = "Unknown command '$command'"; }
587
588      if (not $error) {
589        $logdirectory = shift @ARGV;
590        $slow_delay = shift @ARGV;
591      }
592    }
593    else {
594      $error = 'Wrong number of arguments';
595    }
596  }
597  if ($error) {
598    print "Usage: reporter.pl [init|report] logdirectory slow-delay\n";
599    print "       slow-delay    >0 => run slow tests only every slow-delay minutes\n";
600  }
601  else {
602    check_obsolete_restricts();
603    eval { $error = &$cb(); };
604    if ($@) { $error = $@; }
605  }
606  if ($error) { die "Error: ".$error; }
607}
608main();
Note: See TracBrowser for help on using the repository browser.