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