source: branches/gcc/UNIT_TESTER/reporter.pl

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