source: trunk/UNIT_TESTER/reporter.pl

Last change on this file was 19613, checked in by westram, 7 days ago
  • reintegrates 'lib' into 'trunk'
    • replace dynamic library AWT by several static libraries: APP, ARB_SPEC, MASKS, CANVAS, MAPKEY, GUI_TK
    • now also check wrong library dependencies for untested units (only4me)
  • adds: log:branches/lib@19578:19612
  • Property svn:executable set to *
File size: 16.2 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
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 print_expand_pathless_messages($$) {
132  my ($line,$topdir) = @_;
133  chomp($line);
134  if ($line =~ /^([a-z0-9_\.\/]+):([0-9:]+):/oi) {
135    my ($file,$lineCol,$rest) = ($1,$2,$');
136    my @expanded = get_expanded_filenames($file);
137
138    if (scalar(@expanded)==0) {
139      if ($file =~ /^tests(\.slow)?\//o) { # generated test code -> accept unmodified ($file is relative to UNIT_TESTER)
140        print "$file:$lineCol: $rest\n";
141      }
142      else {
143        print "$file:$lineCol: [unknown source file -> call 'make valgrind_update'] $rest\n";
144      }
145    }
146    else {
147      foreach (@expanded) {
148        my $expFile = $_;
149        my $relFile = $expFile;
150        removeDirPrefix($topdir,$relFile);
151        if ($verbose) {
152          print "$relFile:$lineCol: $rest"." [path expanded: '$file'->'$expFile'->'$relFile']\n";
153        }
154        else {
155          print "$relFile:$lineCol: $rest\n";
156        }
157      }
158    }
159  }
160  else {
161    print $line."\n";
162  }
163}
164
165sub dump_log($) {
166  my ($log) = @_;
167
168  my @former_dirs = ();
169
170  my $topdir = $ENV{ARBHOME};
171  my $currDir = $topdir;
172
173  open(LOG,'<'.$log) || die "can't open '$log' (Reason: $!)";
174  my $seen_AS = 0;
175  my $line;
176  while (defined($line=<LOG>)) {
177    my $printed = 0;
178    if ($seen_AS==1) {
179      my $formatted_line = format_asan_line($line,$currDir);
180      if (defined $formatted_line) {
181        if ($verbose) {
182          print_expand_pathless_messages(add_suffix($formatted_line,' [formatted_DL]'), $currDir);
183        }
184        else {
185          print_expand_pathless_messages($formatted_line, $currDir);
186        }
187        $printed = 1;
188      }
189    }
190    else {
191      if ($line =~ /(AddressSanitizer|LeakSanitizer|runtime.error:)/o) {
192        $seen_AS = 1;
193        if (defined $topdir) {
194          print('fake[2]: Entering directory `'.$topdir."\'\n");
195          $currDir = $topdir;
196        }
197      }
198    }
199    if ($printed==0) {
200      if ($line =~ /:\s(Entering|Leaving)\s+directory\s+[`']([^`']+)[`']$/o) {
201        my ($what,$where) = ($1,$2);
202        if ($verbose) { print "[detected dir-change: what='$what' where='$where']\n"; }
203
204        if ($what eq 'Entering') {
205          push @former_dirs, $currDir;
206          $currDir = $where;
207        }
208        else {
209          if ($what ne 'Leaving') { die "confused"; }
210          $currDir = pop @former_dirs;
211          if ($verbose) { print "[changing dir '$where' -> '$currDir']\n"; }
212        }
213
214        print $line; # do not modify enter/leave lines
215      }
216      elsif ($verbose) {
217        print_expand_pathless_messages(add_suffix($line,' [unformatted_DL seen_AS='.$seen_AS.']'), $currDir);
218      }
219      else {
220        print_expand_pathless_messages($line, $currDir);
221      }
222    }
223  }
224  if (defined $topdir and $seen_AS==1) { print('fake[2]: Leaving directory `'.$topdir."\'\n"); }
225  close(LOG);
226}
227
228# --------------------------------------------------------------------------------
229
230sub dump_junitlog(\@) {
231  my ($content_r) = @_;
232  my $logfile = "logs/junit_log.xml"; # see also Makefile.suite@JUNITLOGNAME
233  open(JLOG,'>'.$logfile) || die "can't write '$logfile' (Reason: $!)";
234  print JLOG "<testsuites>\n";
235  foreach (@$content_r) {
236    print JLOG $_."\n";
237  }
238  print JLOG "</testsuites>\n";
239  close(JLOG);
240}
241
242sub removeDonefileFor($) {
243  my ($unitName) = @_;
244
245  my @donefiles = ();
246  my $donefile_dir = ($slow_delay==0) ? 'tests.slow' : 'tests';
247  opendir(DIR,$donefile_dir) || die "can't read directory '$donefile_dir' (Reason: $!)";
248  foreach (readdir(DIR)) {
249    if (/\.done$/o) {
250      if (/$unitName/) {
251        push @donefiles, $_;
252      }
253    }
254  }
255  closedir(DIR);
256
257  my $donefiles = scalar(@donefiles);
258  if ($donefiles==1) {
259    my $donefile = $donefile_dir.'/'.$donefiles[0];
260    print "Unlinking $donefile (for unit '$unitName')\n";
261    unlink($donefile);
262  }
263  else {
264    print "donefiles found: $donefiles\n";
265    if ($donefiles>0) {
266      foreach (@donefiles) { print "- $_\n"; }
267      die "could not determine .done-file for '$unitName'";
268    }
269  }
270}
271
272# --------------------------------------------------------------------------------
273
274my $tests     = 0;
275my $skipped   = 0;
276my $passed    = 0;
277my $failed    = 0;
278my $warnings  = 0;
279my $elapsed   = 0;
280my $crashed   = 0;
281my $valgrind  = 0;
282my $sanitized = 0;
283
284my %duration = (); # key=unit, value=ms
285
286sub parse_log($\@) {
287  # parse reports generated by UnitTester.cxx@generateReport
288  my ($log,$junit_r) = @_;
289  open(LOG,'<'.$log) || die "can't open '$log' (Reason: $!)";
290
291  my $tests_this    = 0;
292  my $skipped_this  = 0;
293  my $passedALL     = 0;
294  my $seenSummary   = 0;
295  my $seenSanitized = 0;
296
297  my $curr_target        = undef;
298  my $last_error_message = undef;
299
300  my $unitName = 'unknownUnit';
301  if ($log =~ /\/([^\.\/]+)\.[^\/]+$/o) { $unitName = $1; }
302
303  my $dump_log = 0;
304  my $remove_donefile = 0;
305
306  my @testcases   = ();
307  my $case_ok     = 0;
308  my $case_failed = 0;
309
310  while ($_ = <LOG>) {
311    chomp;
312    if (/^UnitTester:/) {
313      my $rest = $';
314      if ($rest =~ /^\s+\*\s+([A-Za-z0-9_]+)\s+=\s+([A-Z]*)/o) {
315        my ($testname,$result) = ($1,$2);
316        my $err = undef;
317        if ($result ne 'OK') {
318          if (defined $last_error_message) {
319            $err = $last_error_message;
320          }
321          else {
322            $err = 'unknown failure reason';
323          }
324        }
325        # append to junit log
326        my $testcase = "  <testcase name=\"$testname\" classname=\"$unitName.noclass\"";
327        if (defined $err) {
328          $testcase .= ">\n";
329          $testcase .= "   <error message=\"$err\"/>\n";
330          $testcase .= "  </testcase>";
331          $case_failed++;
332        }
333        else {
334          $testcase .= '/>';
335          $case_ok++;
336        }
337        push @testcases, $testcase;
338        $last_error_message = undef;
339      }
340
341      if (/tests=([0-9]+)/)   { $tests_this += $1; $seenSummary=1; }
342      if (/skipped=([0-9]+)/) {
343        $skipped_this += $1;
344        if (shall_run_slow()) {
345          if ($WARN_LEVEL) {
346            $dump_log = 1;
347          }
348        }
349      }
350
351      if (/passed=([0-9]+)/)  { $passed += $1; }
352      if (/passed=ALL/)       { $passedALL = 1; }
353
354      if (/failed=([0-9]+)/)  { $failed += $1; $dump_log = 1; }
355      if (/warnings=([0-9]+)/)  { $warnings += $1; if ($failed==0) { $dump_log = 1; } }
356      if (/target=([^\s]+)/)  { $curr_target = $1; }
357      if (/time=([0-9.]+)/)   {
358        $elapsed += $1;
359        if (not defined $curr_target) { die "Don't know current target"; }
360        $duration{$curr_target} = $1;
361      }
362      if (/valgrind.*error/)  { $valgrind++; $dump_log = 1; $remove_donefile = 1; }
363      if (/coverage/)  { $dump_log = 1; }
364    }
365    elsif (/^[^\s:]+:[0-9]+:\s+Error:\s+/o) {
366      if (not /\(details\sabove\)/) {
367        $last_error_message = $';
368      }
369    }
370    elsif (/^-+\s+(ARB-backtrace.*):$/) {
371      $last_error_message = $1;
372    }
373    elsif (/ERROR:\s*(AddressSanitizer|LeakSanitizer):/o) {
374      $last_error_message = $';
375      $seenSanitized++;
376      $remove_donefile = 1;
377    }
378    elsif (/\s+runtime\s+error:\s+/o) {
379      $dump_log = 1;
380    }
381  }
382  close(LOG);
383
384  if ($remove_donefile == 1) {
385    removeDonefileFor($unitName);
386  }
387
388  # write whole suite to junit log
389  {
390    my $case_all = $case_ok + $case_failed;
391    # my $stamp    = localtime;
392    my $stamp    = `date "+%Y-%m-%dT%T.%N%:z"`;
393    chomp($stamp);
394    push @$junit_r, " <testsuite name=\"$unitName\" tests=\"$case_all\" failures=\"$case_failed\" timestamp=\"$stamp\">";
395    foreach (@testcases) { push @$junit_r, $_; }
396    push @$junit_r, " </testsuite>";
397  }
398
399  if (not $seenSummary) { $dump_log = 1; }
400  if ($seenSanitized>0) { $dump_log = 1; }
401
402  if ($dump_log==1) {
403    dump_log($log);
404  }
405
406  if (not $seenSummary) {
407    my $ARBHOME = $ENV{ARBHOME};
408    print "$ARBHOME/UNIT_TESTER/$log:1:0: Warning: No summary found in '$log' ";
409    if ($seenSanitized>0) {
410      $sanitized++;
411      print "(was aborted by Sanitizer)\n";
412    }
413    else {
414      $crashed++;
415      print "(maybe the test did not compile or crashed)\n";
416    }
417  }
418  else {
419    if ($seenSanitized>0) {
420      $sanitized++;
421      print "Detected Sanitizer warnings\n";
422    }
423  }
424
425  $tests   += $tests_this;
426  $skipped += $skipped_this;
427
428  if ($passedALL==1) { $passed += ($tests_this-$skipped_this); }
429}
430
431sub percent($$) {
432  my ($part,$all) = @_;
433  if ($all) {
434    my $percent = 100*$part/$all;
435    return sprintf("%5.1f%%", $percent);
436  }
437  else {
438    $part==0 || die;
439    return "  0.0%";
440  }
441}
442
443sub slow_note() {
444  return (shall_run_slow() ? "" : " (slow tests skipped)");
445}
446
447my $BigOk = <<EndOk;
448  __  __ _    _  _
449 /  \\(  / )  (_)( \\
450(  O ))  (    _  ) )
451 \\__/(__\\_)  (_)(_/
452EndOk
453
454my $BigFailed = <<EndFailed;
455 ____  __   __  __    ____  ____   _
456(  __)/ _\\ (  )(  )  (  __)(    \\ / \\
457 ) _)/    \\ )( / (_/\\ ) _)  ) D ( \\_/
458(__) \\_/\\_/(__)\\____/(____)(____/ (_)
459EndFailed
460
461
462sub readableDuration($) {
463  # result should not be longer than 9 characters! (5 chars value, space, 3 chars unit)
464  my ($ms) = @_;
465  if ($ms>5000) {
466    my $sec = $ms / 1000.0;
467    if ($sec>99) {
468      my $min = $sec / 60.0;
469      return sprintf("%5.2f min", $min);
470    }
471    return sprintf("%5.2f sec", $sec);
472  }
473  return sprintf("%5i ms ", $ms);
474}
475
476sub trimTail($) {
477  my ($str) = @_;
478  $str =~ s/\s+$//go;
479  $str;
480}
481
482sub print_summary($) {
483  my ($tests_failed) = @_;
484  print "\n-------------------- [ Unit-test summary ] --------------------\n";
485
486  my @summary = ();
487
488  push @summary, sprintf(" Tests   : %5i", $tests);
489  push @summary, sprintf(" Skipped : %5i =%s%s", $skipped, percent($skipped,$tests), slow_note());
490  push @summary, sprintf(" Passed  : %5i =%s", $passed, percent($passed,$tests));
491  push @summary, sprintf(" Failed  : %5i =%s", $failed, percent($failed,$tests));
492  push @summary, sprintf(" Sum.dur.: %9s", trimTail(readableDuration($elapsed)));
493  {
494    my @slowest = sort {
495      $duration{$b} <=> $duration{$a};
496    } map {
497      if ((defined $_) and ($_ ne '') and $duration{$_}>0) { $_; }
498      else { ; }
499    } keys %duration;
500
501    my $show = scalar(@slowest);
502    if ($show>3) { $show = 3; }
503    if ($show>0) {
504      for (my $s=0; $s<$show; ++$s) {
505        my $slowunit = $slowest[$s];
506        push @summary, sprintf("%s%9s (%s)", ($s==0 ? " Max.dur.: " : "           "), readableDuration($duration{$slowunit}), $slowunit);
507      }
508    }
509  }
510  if ($sanitized>0) {
511    push @summary, sprintf(" Sanitizd: %5i units", $sanitized);
512  }
513  push @summary, sprintf(" Crashed : %5i units", $crashed);
514  push @summary, sprintf(" Warnings: %5i", $warnings);
515  if ($valgrind>0) {
516    push @summary, sprintf(" Valgrind: %5i failures", $valgrind);
517  }
518
519  my @big;
520  my $Big = $tests_failed ? $BigFailed : $BigOk;
521  @big= split '\n', $Big;
522
523  my $vOffset = scalar(@summary) - scalar(@big);
524  if ($vOffset<0) { $vOffset = 0; }
525
526  my $col = 0;
527  for (my $i=0; $i<scalar(@big); $i++) {
528    my $j = $i+$vOffset;
529    my $len = length($summary[$j]);
530    if ($len>$col) { $col = $len; }
531  }
532
533  $col += 6; # add horizontal offset
534
535  for (my $i=0; $i<scalar(@big); $i++) {
536    my $j = $i+$vOffset;
537    my $padded = $summary[$j];
538    my $len = length($padded);
539    while ($len<$col) { $padded .= ' '; $len++; }
540    $summary[$j] = $padded.$big[$i];
541  }
542
543  foreach (@summary) { print $_."\n"; }
544}
545
546sub do_report() {
547  my @junit = ();
548  my @logs = get_existing_logs();
549  foreach (@logs) {
550    parse_log($_,@junit);
551  }
552
553  dump_junitlog(@junit);
554
555  my $tests_failed = (($failed>0) or ($crashed>0) or ($valgrind>0) or ($sanitized>0));
556  print_summary($tests_failed);
557  slow_cleanup($tests_failed);
558  if ($tests_failed) {
559    my $ARBHOME = $ENV{ARBHOME};
560    print "rake[0]: Entering directory `$ARBHOME/UNIT_TESTER'\n";
561    die "tests failed\n";
562  }
563  return undef;
564}
565
566sub check_obsolete_restricts() {
567  my $restrict = $ENV{CHECK_RESTRICT};
568  if (not defined $restrict) {
569    print "Can't check restriction (empty)\n";
570  }
571  else {
572    $restrict = ':'.$restrict.':';
573    if ($restrict =~ /:(WINDOW|ARBDB|AWT|CORE):/) {
574      my $lib = $1;
575      my $msl = 'Makefile.setup.local';
576
577      print "UNIT_TESTER/$msl:1: Error: Obsolete restriction '$lib' (should be 'lib$lib')\n";
578      my $grepcmd = "grep -n \'RESTRICT_LIB.*=.*$lib\' $msl";
579      open(GREP,$grepcmd.'|') || die "failed to fork '$grepcmd' (Reason: $!)";
580      foreach (<GREP>) {
581        print "UNIT_TESTER/$msl:$_";
582      }
583      die;
584    }
585  }
586}
587
588# --------------------------------------------------------------------------------
589
590sub main() {
591  my $error = undef;
592  my $cb    = undef;
593  {
594    my $args = scalar(@ARGV);
595    if ($args==3) {
596      my $command   = shift @ARGV;
597
598      if ($command eq 'init') { $cb = \&do_init; }
599      elsif ($command eq 'report') { $cb = \&do_report; }
600      else { $error = "Unknown command '$command'"; }
601
602      if (not $error) {
603        $logdirectory = shift @ARGV;
604        $slow_delay = shift @ARGV;
605      }
606    }
607    else {
608      $error = 'Wrong number of arguments';
609    }
610  }
611  if ($error) {
612    print "Usage: reporter.pl [init|report] logdirectory slow-delay\n";
613    print "       slow-delay    >0 => run slow tests only every slow-delay minutes\n";
614  }
615  else {
616    check_obsolete_restricts();
617    eval { $error = &$cb(); };
618    if ($@) { $error = $@; }
619  }
620  if ($error) { die "Error: ".$error; }
621}
622main();
Note: See TracBrowser for help on using the repository browser.