| 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 | |
|---|
| 40 | sub 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 | |
|---|
| 77 | sub 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 | |
|---|
| 84 | sub 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 | |
|---|
| 96 | sub 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 | |
|---|
| 176 | sub inv_expr_match($$) { |
|---|
| 177 | my ($inv,$match_result) = @_; |
|---|
| 178 | return $inv ? (not $match_result) : $match_result; |
|---|
| 179 | } |
|---|
| 180 | |
|---|
| 181 | sub 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 | |
|---|
| 237 | sub UT_type($) { my ($name) = @_; return 'UnitTest_'.$name; } |
|---|
| 238 | sub UT_name($) { my ($name) = @_; return 'unitTest_'.$name; } |
|---|
| 239 | |
|---|
| 240 | sub prototype_simple($) { |
|---|
| 241 | my ($fun) = @_; |
|---|
| 242 | return 'void '.$fun.'();'."\n"; |
|---|
| 243 | } |
|---|
| 244 | |
|---|
| 245 | sub 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 | |
|---|
| 302 | sub 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> |
|---|
| 310 | HEAD |
|---|
| 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 | |
|---|
| 343 | sub 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 | } |
|---|
| 380 | main(); |
|---|
