source: tags/ms_r16q2/UNIT_TESTER/sym2testcode.pl

Last change on this file was 14231, checked in by westram, 7 years ago
  • unTABify
  • Property svn:executable set to *
File size: 10.4 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)
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 "can't execute '$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);
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 filter($$) {
177  my ($expr_mod,$expr_fun) = @_;
178
179  my $reg_mod = qr/$expr_mod/;
180  my $reg_fun = qr/$expr_fun/;
181
182  my %del = ();
183  foreach my $symbol (keys %simple_test) {
184    my $loc = $location{$symbol};
185    if (defined $loc and not $loc =~ $reg_mod) { $del{$symbol} = 1; }
186    elsif (not $symbol =~ $reg_fun) { $del{$symbol} = 2; }
187    else { $del{$symbol} = 0; }
188  }
189
190  {
191    my $warned = 0;
192    foreach (sort keys %simple_test) {
193      my $del = $del{$_};
194      if (defined $del and $del==1) {
195        if ($warned==0) {
196          print "Skipped tests (restricting to modules matching '$expr_mod'):\n";
197          $warned = 1;
198        }
199        print '* '.$_."\n";
200      }
201    }
202    $warned = 0;
203    foreach (sort keys %simple_test) {
204      my $del = $del{$_};
205      if (defined $del and $del==2) {
206        if ($warned==0) {
207          print "Skipped tests (restricting to functions matching '$expr_fun'):\n";
208          $warned = 1;
209        }
210        print '* '.$_."\n";
211      }
212    }
213  }
214
215  %simple_test = map {
216    my $del = $del{$_};
217    if (not defined $del or $del==0) { $_ => $simple_test{$_}; }
218    else { ; }
219  } keys %simple_test;
220}
221
222# --------------------------------------------------------------------------------
223
224sub UT_type($) { my ($name) = @_; return 'UnitTest_'.$name; }
225sub UT_name($) { my ($name) = @_; return 'unitTest_'.$name; }
226
227sub prototype_simple($) {
228  my ($fun) = @_;
229  return 'void '.$fun.'();'."\n";
230}
231
232sub generate_table($$\%\&) {
233  my ($type,$name,$id_r,$prototyper_r) = @_;
234
235  if ($skip_slow) { skip_slow_tests(); }
236  calculate_priorities();
237
238  my @tests = sort {
239    my $prioa = $test_priority{$a};
240    my $priob = $test_priority{$b};
241
242    my $cmp = $prioa - $priob;
243
244    if ($cmp == 0) {
245      my $loca = $location{$a};
246      my $locb = $location{$b};
247      if (defined $loca) {
248        if (defined $locb) {
249          my ($fa,$la,$fb,$lb);
250          if ($loca =~ /^(.*):([0-9]+)$/) { ($fa,$la) = ($1,$2); } else { die "Invalid location '$loca'"; }
251          if ($locb =~ /^(.*):([0-9]+)$/) { ($fb,$lb) = ($1,$2); } else { die "Invalid location '$locb'"; }
252          $cmp = $fa cmp $fb;
253          if ($cmp==0) { $cmp = $la <=> $lb; }
254        }
255        else { $cmp = 1; }
256      }
257      else {
258        if (defined $locb) { $cmp = -1; }
259        else { $cmp = $a cmp $b; }
260      }
261    }
262    $cmp;
263  } keys %$id_r;
264
265  my $code = '';
266
267  # "prototypes"
268  foreach (@tests) {
269    $code .= &$prototyper_r($_);
270  }
271  $code .= "\n";
272
273  # table
274  $code .= 'static '.$type.' '.$name.'[] = {'."\n";
275  foreach (@tests) {
276    my $loc = $location{$_};
277    if (defined $loc)  { $loc = '"'.$loc.'"'; }
278    else { $loc = 'NULL'; }
279
280    $code .= '    { '.$_.', "'.$_.'", '.$loc.' },'."\n";
281  }
282  $code .= '    { NULL, NULL, NULL },'."\n";
283  $code .= '};'."\n";
284  $code .= "\n";
285
286  return $code;
287}
288
289sub create($$) {
290  my ($libname,$gen_cxx) = @_;
291  open(OUT, '>'.$gen_cxx) || die "can't write '$gen_cxx' (Reason: $!)";
292
293  my $HEAD = <<HEAD;
294#include <UnitTester.hxx>
295#include <cstdlib>
296HEAD
297
298  my $TABLES = generate_table(UT_type('simple'), UT_name('simple'), %simple_test, &prototype_simple);
299  $TABLES   .= generate_table(UT_type('simple'), UT_name('postcond'), %postcond, &prototype_simple);
300
301  my $skipped_count = scalar(keys %skipped_test);
302
303  # UnitTester is declared in UnitTester.cxx@InvokeUnitTester
304  my $UNIT_TESTER = 'UnitTester unitTester("'.$libname.'", ';
305  $UNIT_TESTER .= UT_name('simple');
306  $UNIT_TESTER .= ', '.$warn_level;
307  $UNIT_TESTER .= ', '.$skipped_count;
308  $UNIT_TESTER .= ', '.UT_name('postcond');
309  $UNIT_TESTER .= ');';
310
311  my $MAIN = '';
312  my $have_main = defined $exported{'main'};
313  if ($have_main==1) {
314    $MAIN .= "#error tested code uses main() - not possible. use ARB_main instead and link normal executable with arb_main.o\n";
315  }
316  $MAIN .= 'int main(void) {'."\n";
317  $MAIN .= '    '.$UNIT_TESTER."\n";
318  $MAIN .= '    return EXIT_SUCCESS;'."\n";
319  $MAIN .= '}'."\n";
320
321  print OUT $HEAD."\n";
322  print OUT $TABLES."\n";
323  print OUT $MAIN."\n";
324  close(OUT);
325}
326
327# --------------------------------------------------------------------------------
328
329sub main() {
330  my $args = scalar(@ARGV);
331  if ($args != 6) {
332    die("Usage: sym2testcode.pl libname restrict-mod restrict-fun nm-output gen-cxx warn-level\n".
333        "    libname        name of library to run tests for\n".
334        "    restrict-mod   regexpr to restrict to specific module in library\n".
335        "    restrict-fun   regexpr to restrict to matching test functions\n".
336        "    nm-output      output of nm\n".
337        "    gen_cxx        name of C++ file to generate\n".
338        "    warn-level     (0=quiet|1=noisy)\n".
339        "Error: Expected 5 arguments\n");
340  }
341
342  my $libname     = shift @ARGV;
343  my $restrictMod = shift @ARGV;
344  my $restrictFun = shift @ARGV;
345  my $nm_output   = shift @ARGV;
346  my $gen_cxx     = shift @ARGV;
347  $warn_level     = shift @ARGV;
348
349  parse($nm_output);
350  fail_if_no_tests_defined($libname); # comment out to disableErrorOnUnitsWithoutTests
351
352  filter($restrictMod,$restrictFun);
353  eval {
354    create($libname,$gen_cxx);
355  };
356  if ($@) {
357    my $err = "Error: Failed to generate '$gen_cxx' (Reason: $@)";
358    if (-f $gen_cxx) {
359      if (not unlink($gen_cxx)) {
360        $err .= "\nError: Failed to unlink '$gen_cxx' (Reason: $!)";
361      }
362    }
363    die $err;
364  }
365}
366main();
Note: See TracBrowser for help on using the repository browser.