source: trunk/UNIT_TESTER/sym2testcode.pl

Last change on this file was 18914, checked in by westram, 3 years ago
  • fix error handling for piped commands in perl
    • when forking piped commands
      • use error message ($!) instead of exitcode ($?).
      • use message 'failed to fork'.
    • when closing piped commands
      • show IPC errors and exitcode of command.
  • Property svn:executable set to *
File size: 11.0 KB
Line 
1#!/usr/bin/perl
2
3use strict;
4use warnings;
5
6# --------------------------------------------------------------------------------
7
8my %location      = (); # key=symbol, value=location
9my %exported      = (); # key=exported symbols
10my %simple_test   = (); # key=names of existing simple test functions; value=1
11my %postcond      = (); # key=names of existing post-condition tests; value=1
12my %skipped_test  = (); # like simple_test, but not performed (atm). values: 1=slow, 2=modfilt, 3=funfilt
13my %test_priority = (); # key=test value=priority
14
15# --------------------------------------------------------------------------------
16
17my $warn_level = undef;
18
19# when file exists, skip slow tests (see reporter.pl@SkipSlow)
20my $skip_slow  = (-e 'skipslow.stamp');
21
22# --------------------------------------------------------------------------------
23
24sub symbol_message($$$) {
25  my ($symbol,$message,$type) = @_;
26  my $loc = $location{$symbol};
27
28  if (defined $loc) {
29    print STDERR "$loc: $type: $message ($symbol)\n";
30  }
31  else {
32    print STDERR "sym2testcode.pl: Error: Location of '$symbol' is unknown\n";
33    print STDERR "sym2testcode.pl: $type: $message ($symbol)\n";
34  }
35}
36sub symbol_warning($$) { my($symbol, $message)= @_; $warn_level==0 || symbol_message($symbol, $message, "Warning"); }
37sub symbol_error($$)   { my($symbol, $message)= @_; symbol_message($symbol, $message, "Error");   }
38
39
40sub fail_if_no_tests_defined($) {
41  my ($libname) = @_;
42  my $skipped = scalar(keys %skipped_test);
43  my $active  = scalar(keys %simple_test);
44
45  if (($skipped+$active)==0) {
46    my $makefileDefiningTests = $ENV{ARBHOME}.'/Makefile';
47    # my $makefileDefiningTests = '../Makefile';
48    my $thisTest = $libname;
49
50    $thisTest =~ s/\.(a|o|so)/.test/o;
51    $thisTest =~ s/^lib//o;
52
53    my $cmd = "grep -Hn '$thisTest' $makefileDefiningTests";
54
55    open(GREP,$cmd.'|') || die "failed to fork '$cmd' (Reason: $!)";
56    my $lineCount = 0;
57    foreach (<GREP>) {
58      if (/^([^:]+:[0-9]+:)/o) {
59        my ($loc,$line) = ($1,$');
60        chomp($line);
61        print $1.' Error: No tests defined by '.$libname." (do not call this test!)\n";
62        $lineCount++;
63      }
64      else { print "unhandled grep out='$_'\n"; }
65    }
66    close(GREP) || die "failed to execute '$cmd' (Reason: $! exitcode=$?)";
67    if ($lineCount!=1) {
68      die "expected exactly one line from grep (got $lineCount)\n".
69        "grep-cmd was '$cmd'";
70    }
71    die "sym2testcode.pl: won't generate useless test code\n";
72  }
73
74  return $active; # return number of active tests
75}
76
77sub skip_slow_tests() {
78  foreach (keys %simple_test) {
79    if (/^TEST_SLOW_/) { $skipped_test{$_} = 1; }
80  }
81  foreach (keys %skipped_test) { delete $simple_test{$_}; }
82}
83
84sub calculate_priorities() {
85  foreach (keys %simple_test) {
86    if    (/^TEST_BASIC_/)      { $test_priority{$_} = 20; }
87    elsif (/^TEST_EARLY_/)      { $test_priority{$_} = 50; }
88    elsif (/^TEST_LATE_/)       { $test_priority{$_} = 200; }
89    elsif (/^TEST_SLOW_/)       { $test_priority{$_} = 900; }
90    elsif (/^TEST_AFTER_SLOW_/) { $test_priority{$_} = 910; }
91    elsif (/^TEST_([0-9]+)_/)   { $test_priority{$_} = $1; }
92    else                        { $test_priority{$_} = 100; }
93  }
94}
95
96sub parse($) {
97  my ($nm_output) = @_;
98  open(IN,'<'.$nm_output) || die "can't read '$nm_output' (Reason: $!)";
99
100  my $line;
101  my $lineNr=0;
102  eval {
103  LINE: while (defined ($line = <IN>)) {
104      $lineNr++;
105      chomp($line);
106      if ($line =~ /^(([0-9a-f]|\s)+) (.+?) (.*)$/o) {
107        my ($type,$rest) = ($3,$4);
108        my $symbol;
109        my $location = undef;
110        if ($rest =~ /\t/o) {
111          ($symbol,$location) = ($`,$');
112        }
113        else { # symbol w/o location
114          $symbol = $rest;
115        }
116
117        next LINE if ($symbol =~ /::/); # skip static variables and other scoped symbols
118        if ($symbol =~ /\(/o) { $symbol = $`; } # skip prototype
119        if (defined $location) { $location{$symbol} = $location; }
120
121        my $is_unit_test     = undef;
122        my $is_postcond      = undef;
123        my $is_disabled_test = undef;
124
125        if ($symbol =~ /^TEST_/o) {
126          $is_unit_test = 1;
127          if ($' =~ /^POSTCOND_/o) { $is_postcond = 1; }
128        }
129        elsif ($symbol =~ /TEST_/o) {
130          if (not $` =~  /publish/) { # skip publishers
131            $is_disabled_test = 1;
132          }
133        }
134
135        my $is_global_symbol = ($type eq 'T');
136
137        if ($is_global_symbol) { $exported{$symbol} = 1; }
138
139        if ($is_unit_test) {
140          if ($is_global_symbol) {
141            if ($is_postcond) {
142              $postcond{$symbol} = 1;
143            }
144            else {
145              $simple_test{$symbol} = 1;
146            }
147          }
148          else {
149            symbol_warning($symbol, "unit-tests need global scope (type='$type' symbol='$symbol')");
150          }
151        }
152        elsif ($is_disabled_test) {
153          if ($is_global_symbol) {
154            symbol_warning($symbol, "Test looks disabled");
155            $skipped_test{$symbol} = 1; # just note down for summary
156          }
157        }
158      }
159      elsif (($line ne "\n") and ($line ne '') and
160             not ($line =~ /^[A-Za-z0-9_]+\.o:$/) and
161             not ($line =~ /\([A-Za-z0-9_]+\.o\):$/)) {
162        die "can't parse line '$line'\n";
163      }
164    }
165  };
166  if ($@) {
167    print "$nm_output:$lineNr: $@\n";
168    die;
169  }
170
171  close(IN);
172}
173
174# --------------------------------------------------------------------------------
175
176sub inv_expr_match($$) {
177  my ($inv,$match_result) = @_;
178  return $inv ? (not $match_result) : $match_result;
179}
180
181sub filter($$) {
182  my ($expr_mod,$expr_fun) = @_;
183
184  my $inv_mod = 0;
185  my $inv_fun = 0;
186
187  if ($expr_mod =~ /^!/) { $inv_mod = 1; $expr_mod = $'; }
188  if ($expr_fun =~ /^!/) { $inv_fun = 1; $expr_fun = $'; }
189
190  my $reg_mod = qr/$expr_mod/i;
191  my $reg_fun = qr/$expr_fun/i;
192
193  my %del = ();
194  foreach my $symbol (keys %simple_test) {
195    my $loc = $location{$symbol};
196    if (defined $loc and not inv_expr_match($inv_mod, $loc =~ $reg_mod)) { $del{$symbol} = 1; }
197    elsif (not inv_expr_match($inv_fun, $symbol =~ $reg_fun)) { $del{$symbol} = 2; }
198    else { $del{$symbol} = 0; }
199  }
200
201  {
202    my $warned = 0;
203    foreach (sort keys %simple_test) {
204      my $del = $del{$_};
205      if (defined $del and $del==1) {
206        if ($warned==0) {
207          print 'Skipped tests (restricting to modules '.($inv_mod ? 'NOT ': '')."matching '$expr_mod'):\n";
208          $warned = 1;
209        }
210        print '* '.$_."\n";
211        $skipped_test{$_} = 2;
212      }
213    }
214    $warned = 0;
215    foreach (sort keys %simple_test) {
216      my $del = $del{$_};
217      if (defined $del and $del==2) {
218        if ($warned==0) {
219          print 'Skipped tests (restricting to functions '.($inv_fun ? 'NOT ': '')."matching '$expr_fun'):\n";
220          $warned = 1;
221        }
222        print '* '.$_."\n";
223        $skipped_test{$_} = 3;
224      }
225    }
226  }
227
228  %simple_test = map {
229    my $del = $del{$_};
230    if (not defined $del or $del==0) { $_ => $simple_test{$_}; }
231    else { ; }
232  } keys %simple_test;
233}
234
235# --------------------------------------------------------------------------------
236
237sub UT_type($) { my ($name) = @_; return 'UnitTest_'.$name; }
238sub UT_name($) { my ($name) = @_; return 'unitTest_'.$name; }
239
240sub prototype_simple($) {
241  my ($fun) = @_;
242  return 'void '.$fun.'();'."\n";
243}
244
245sub generate_table($$\%\&) {
246  my ($type,$name,$id_r,$prototyper_r) = @_;
247
248  if ($skip_slow) { skip_slow_tests(); }
249  calculate_priorities();
250
251  my @tests = sort {
252    my $prioa = $test_priority{$a};
253    my $priob = $test_priority{$b};
254
255    my $cmp = $prioa - $priob;
256
257    if ($cmp == 0) {
258      my $loca = $location{$a};
259      my $locb = $location{$b};
260      if (defined $loca) {
261        if (defined $locb) {
262          my ($fa,$la,$fb,$lb);
263          if ($loca =~ /^(.*):([0-9]+)$/) { ($fa,$la) = ($1,$2); } else { die "Invalid location '$loca'"; }
264          if ($locb =~ /^(.*):([0-9]+)$/) { ($fb,$lb) = ($1,$2); } else { die "Invalid location '$locb'"; }
265          $cmp = $fa cmp $fb;
266          if ($cmp==0) { $cmp = $la <=> $lb; }
267        }
268        else { $cmp = 1; }
269      }
270      else {
271        if (defined $locb) { $cmp = -1; }
272        else { $cmp = $a cmp $b; }
273      }
274    }
275    $cmp;
276  } keys %$id_r;
277
278  my $code = '';
279
280  # "prototypes"
281  foreach (@tests) {
282    $code .= &$prototyper_r($_);
283  }
284  $code .= "\n";
285
286  # table
287  $code .= 'static '.$type.' '.$name.'[] = {'."\n";
288  foreach (@tests) {
289    my $loc = $location{$_};
290    if (defined $loc)  { $loc = '"'.$loc.'"'; }
291    else { $loc = 'NULp'; }
292
293    $code .= '    { '.$_.', "'.$_.'", '.$loc.' },'."\n";
294  }
295  $code .= '    { NULp, NULp, NULp },'."\n";
296  $code .= '};'."\n";
297  $code .= "\n";
298
299  return $code;
300}
301
302sub create($$) {
303  my ($libname,$gen_cxx) = @_;
304  open(OUT, '>'.$gen_cxx) || die "can't write '$gen_cxx' (Reason: $!)";
305
306  my $HEAD = <<HEAD;
307#include <UnitTester.hxx>
308#include <cxxforward.h>
309#include <cstdlib>
310HEAD
311
312  my $TABLES = generate_table(UT_type('simple'), UT_name('simple'), %simple_test, &prototype_simple);
313  $TABLES   .= generate_table(UT_type('simple'), UT_name('postcond'), %postcond, &prototype_simple);
314
315  my $skipped_count = scalar(keys %skipped_test);
316
317  # UnitTester is declared in UnitTester.cxx@InvokeUnitTester
318  my $UNIT_TESTER = 'UnitTester unitTester("'.$libname.'", ';
319  $UNIT_TESTER .= UT_name('simple');
320  $UNIT_TESTER .= ', '.$warn_level;
321  $UNIT_TESTER .= ', '.$skipped_count;
322  $UNIT_TESTER .= ', '.UT_name('postcond');
323  $UNIT_TESTER .= ');';
324
325  my $MAIN = '';
326  my $have_main = defined $exported{'main'};
327  if ($have_main==1) {
328    $MAIN .= "#error tested code uses main() - not possible. use ARB_main instead and link normal executable with arb_main.o\n";
329  }
330  $MAIN .= 'int main(void) {'."\n";
331  $MAIN .= '    '.$UNIT_TESTER."\n";
332  $MAIN .= '    return EXIT_SUCCESS;'."\n";
333  $MAIN .= '}'."\n";
334
335  print OUT $HEAD."\n";
336  print OUT $TABLES."\n";
337  print OUT $MAIN."\n";
338  close(OUT);
339}
340
341# --------------------------------------------------------------------------------
342
343sub main() {
344  my $args = scalar(@ARGV);
345  if ($args != 6) {
346    die("Usage: sym2testcode.pl libname restrict-mod restrict-fun nm-output gen-cxx warn-level\n".
347        "    libname        name of library to run tests for\n".
348        "    restrict-mod   regexpr to restrict to specific modules in library (prefix with ! to invert)\n".
349        "    restrict-fun   regexpr to restrict to matching test functions (prefix with ! to invert)\n".
350        "    nm-output      output of nm\n".
351        "    gen_cxx        name of C++ file to generate\n".
352        "    warn-level     (0=quiet|1=noisy)\n".
353        "Error: Expected 5 arguments\n");
354  }
355
356  my $libname     = shift @ARGV;
357  my $restrictMod = shift @ARGV;
358  my $restrictFun = shift @ARGV;
359  my $nm_output   = shift @ARGV;
360  my $gen_cxx     = shift @ARGV;
361  $warn_level     = shift @ARGV;
362
363  parse($nm_output);
364  fail_if_no_tests_defined($libname);
365
366  filter($restrictMod,$restrictFun);
367  eval {
368    create($libname,$gen_cxx);
369  };
370  if ($@) {
371    my $err = "Error: Failed to generate '$gen_cxx' (Reason: $@)";
372    if (-f $gen_cxx) {
373      if (not unlink($gen_cxx)) {
374        $err .= "\nError: Failed to unlink '$gen_cxx' (Reason: $!)";
375      }
376    }
377    die $err;
378  }
379}
380main();
Note: See TracBrowser for help on using the repository browser.