1#!/usr/bin/env perl 2 3# 4# Were we told where to find tcpdump? 5# 6if (!($TCPDUMP = $ENV{TCPDUMP_BIN})) { 7 # 8 # No. Use the appropriate path. 9 # 10 if ($^O eq 'MSWin32') { 11 # 12 # XXX - assume, for now, a Visual Studio debug build, so that 13 # tcpdump is in the Debug subdirectory. 14 # 15 $TCPDUMP = "Debug\\tcpdump" 16 } else { 17 $TCPDUMP = "./tcpdump" 18 } 19} 20 21# 22# Make true and false work as Booleans. 23# 24use constant { true => 1, false => 0 }; 25 26use File::Basename; 27use POSIX qw( WEXITSTATUS WIFEXITED); 28use Cwd qw(abs_path getcwd); 29use File::Path qw(mkpath); # mkpath works with ancient perl, as well as newer perl 30use File::Spec; 31use Data::Dumper; # for debugging. 32 33# these are created in the directory where we are run, which might be 34# a build directory. 35my $newdir = "tests/NEW"; 36my $diffdir= "tests/DIFF"; 37mkpath($newdir); 38mkpath($diffdir); 39my $origdir = getcwd(); 40my $srcdir = $ENV{'srcdir'} || "."; 41 42# 43# Force UTC, so time stamps are printed in a standard time zone, and 44# tests don't have to be run in the time zone in which the output 45# file was generated. 46# 47$ENV{'TZ'}='GMT0'; 48 49# 50# Get the tests directory from $0. 51# 52my $testsdir = dirname($0); 53 54# 55# Convert it to an absolute path, so it works even after we do a cd. 56# 57$testsdir = abs_path($testsdir); 58print "Running tests from ${testsdir}\n"; 59print "with ${TCPDUMP}, version:\n"; 60system "${TCPDUMP} --version"; 61 62unshift(@INC, $testsdir); 63 64$passedcount = 0; 65$failedcount = 0; 66# 67my $failureoutput=$origdir . "/tests/failure-outputs.txt"; 68 69# truncate the output file 70open(FAILUREOUTPUT, ">" . $failureoutput); 71close(FAILUREOUTPUT); 72 73$confighhash = undef; 74 75sub showfile { 76 local($path) = @_; 77 78 # 79 # XXX - just do this directly in Perl? 80 # 81 if ($^O eq 'MSWin32') { 82 my $winpath = File::Spec->canonpath($path); 83 system "type $winpath"; 84 } else { 85 system "cat $path"; 86 } 87} 88 89sub runtest { 90 local($name, $input, $output, $options) = @_; 91 my $r; 92 93 $outputbase = basename($output); 94 my $coredump = false; 95 my $status = 0; 96 my $linecount = 0; 97 my $rawstderrlog = "tests/NEW/${outputbase}.raw.stderr"; 98 my $stderrlog = "tests/NEW/${outputbase}.stderr"; 99 my $diffstat = 0; 100 my $errdiffstat = 0; 101 102 # we used to do this as a nice pipeline, but the problem is that $r fails to 103 # to be set properly if the tcpdump core dumps. 104 # 105 # Furthermore, on Windows, fc can't read the standard input, so we 106 # can't do it as a pipeline in any case. 107 $r = system "$TCPDUMP -# -n -r $input $options >tests/NEW/${outputbase} 2>${rawstderrlog}"; 108 if($r != 0) { 109 # 110 # Something other than "tcpdump opened the file, read it, and 111 # dissected all the packets". What happened? 112 # 113 # We write out an exit status after whatever the subprocess 114 # wrote out, so it shows up when we diff the expected output 115 # with it. 116 # 117 open(OUTPUT, ">>"."tests/NEW/$outputbase") || die "fail to open $outputbase\n"; 118 if($r == -1) { 119 # failed to start due to error. 120 $status = $!; 121 printf OUTPUT "FAILED TO RUN: status: %d\n", $status; 122 } else { 123 if ($^O eq 'MSWin32') { 124 # 125 # On Windows, the return value of system is the lower 8 126 # bits of the exit status of the process, shifted left 127 # 8 bits. 128 # 129 # If the process crashed, rather than exiting, the 130 # exit status will be one of the EXCEPTION_ values 131 # listed in the documentation for the GetExceptionCode() 132 # macro. 133 # 134 # Those are defined as STATUS_ values, which should have 135 # 0xC in the topmost 4 bits (being fatal error 136 # statuses); some of them have a value that fits in 137 # the lower 8 bits. We could, I guess, assume that 138 # any value that 1) isn't returned by tcpdump and 2) 139 # corresponds to the lower 8 bits of a STATUS_ value 140 # used as an EXCEPTION_ value indicates that tcpdump 141 # exited with that exception. 142 # 143 # However, as we're running tcpdump with system, which 144 # runs the command through cmd.exe, and as cmd.exe 145 # doesn't map the command's exit code to its own exit 146 # code in any straightforward manner, we can't get 147 # that information in any case, so there's no point 148 # in trying to interpret it in that fashion. 149 # 150 $status = $r >> 8; 151 } else { 152 # 153 # On UN*Xes, the return status is a POSIX as filled in 154 # by wait() or waitpid(). 155 # 156 # POSIX offers some calls for analyzing it, such as 157 # WIFSIGNALED() to test whether it indicates that the 158 # process was terminated by a signal, WTERMSIG() to 159 # get the signal number from it, WIFEXITED() to test 160 # whether it indicates that the process exited normally, 161 # and WEXITSTATUS() to get the exit status from it. 162 # 163 # POSIX doesn't standardize core dumps, so the POSIX 164 # calls can't test whether a core dump occurred. 165 # However, all the UN*Xes we are likely to encounter 166 # follow Research UNIX in this regard, with the exit 167 # status containing either 0 or a signal number in 168 # the lower 7 bits, with 0 meaning "exited rather 169 # than being terminated by a signal", the "core dumped" 170 # flag in the 0x80 bit, and, if the signal number is 171 # 0, the exit status in the next 8 bits up. 172 # 173 # This should be cleaned up to use the POSIX calls 174 # from the Perl library - and to define an additional 175 # WCOREDUMP() call to test the "core dumped" bit and 176 # use that. 177 # 178 # But note also that, as we're running tcpdump with 179 # system, which runs the command through a shell, if 180 # tcpdump crashes, we'll only know that if the shell 181 # maps the signal indication and uses that as its 182 # exit status. 183 # 184 # The good news is that the Bourne shell, and compatible 185 # shells, have traditionally done that. If the process 186 # for which the shell reports the exit status terminates 187 # with a signal, it adds 128 to the signal number and 188 # returns that as its exit status. (This is why the 189 # "this is now working right" behavior described in a 190 # comment below is occurring.) 191 # 192 # As tcpdump itself never returns with an exit status 193 # >= 128, we can try checking for an exit status with 194 # the 0x80 bit set and, if we have one, get the signal 195 # number from the lower 7 bits of the exit status. We 196 # can't get the "core dumped" indication from the 197 # shell's exit status; all we can do is check whether 198 # there's a core file. 199 # 200 if( $r & 128 ) { 201 $coredump = $r & 127; 202 } 203 if( WIFEXITED($r)) { 204 $status = WEXITSTATUS($r); 205 } 206 } 207 208 if($coredump || $status) { 209 printf OUTPUT "EXIT CODE %08x: dump:%d code: %d\n", $r, $coredump, $status; 210 } else { 211 printf OUTPUT "EXIT CODE %08x\n", $r; 212 } 213 $r = 0; 214 } 215 close(OUTPUT); 216 } 217 if($r == 0) { 218 # 219 # Compare tcpdump's output with what we think it should be. 220 # If tcpdump failed to produce output, we've produced our own 221 # "output" above, with the exit status. 222 # 223 if ($^O eq 'MSWin32') { 224 my $winoutput = File::Spec->canonpath($output); 225 $r = system "fc /lb1000 /t /1 $winoutput tests\\NEW\\$outputbase >tests\\DIFF\\$outputbase.diff"; 226 $diffstat = $r >> 8; 227 } else { 228 $r = system "diff $output tests/NEW/$outputbase >tests/DIFF/$outputbase.diff"; 229 $diffstat = WEXITSTATUS($r); 230 } 231 } 232 233 # process the standard error file, sanitize "reading from" line, 234 # and count lines 235 $linecount = 0; 236 open(ERRORRAW, "<" . $rawstderrlog); 237 open(ERROROUT, ">" . $stderrlog); 238 while(<ERRORRAW>) { 239 next if /^$/; # blank lines are boring 240 if(/^(reading from file )(.*)(,.*)$/) { 241 my $filename = basename($2); 242 print ERROROUT "${1}${filename}${3}\n"; 243 next; 244 } 245 print ERROROUT; 246 $linecount++; 247 } 248 close(ERROROUT); 249 close(ERRORRAW); 250 251 if ( -f "$output.stderr" ) { 252 # 253 # Compare the standard error with what we think it should be. 254 # 255 if ($^O eq 'MSWin32') { 256 my $winoutput = File::Spec->canonpath($output); 257 my $canonstderrlog = File::Spec->canonpath($stderrlog); 258 $nr = system "fc /lb1000 /t /1 $winoutput.stderr $canonstderrlog >tests\DIFF\$outputbase.stderr.diff"; 259 $errdiffstat = $nr >> 8; 260 } else { 261 $nr = system "diff $output.stderr $stderrlog >tests/DIFF/$outputbase.stderr.diff"; 262 $errdiffstat = WEXITSTATUS($nr); 263 } 264 if($r == 0) { 265 $r = $nr; 266 } 267 } 268 269 if($r == 0) { 270 if($linecount == 0 && $status == 0) { 271 unlink($stderrlog); 272 } else { 273 $errdiffstat = 1; 274 } 275 } 276 277 #print sprintf("END: %08x\n", $r); 278 279 if($r == 0) { 280 if($linecount == 0) { 281 printf " %-40s: passed\n", $name; 282 } else { 283 printf " %-40s: passed with error messages:\n", $name; 284 showfile($stderrlog); 285 } 286 unlink "tests/DIFF/$outputbase.diff"; 287 return 0; 288 } 289 # must have failed! 290 printf " %-40s: TEST FAILED(exit core=%d/diffstat=%d,%d/r=%d)", $name, $coredump, $diffstat, $errdiffstat, $r; 291 open FOUT, '>>tests/failure-outputs.txt'; 292 printf FOUT "\nFailed test: $name\n\n"; 293 close FOUT; 294 if(-f "tests/DIFF/$outputbase.diff") { 295 # 296 # XXX - just do this directly in Perl? 297 # 298 if ($^O eq 'MSWin32') { 299 system "type tests\\DIFF\\$outputbase.diff >> tests\\failure-outputs.txt"; 300 } else { 301 system "cat tests/DIFF/$outputbase.diff >> tests/failure-outputs.txt"; 302 } 303 } 304 305 if($r == -1) { 306 print " (failed to execute: $!)\n"; 307 return(30); 308 } 309 310 # this is not working right, $r == 0x8b00 when there is a core dump. 311 # clearly, we need some platform specific perl magic to take this apart, so look for "core" 312 # too. 313 # In particular, on Solaris 10 SPARC an alignment problem results in SIGILL, 314 # a core dump and $r set to 0x00008a00 ($? == 138 in the shell). 315 if($r & 127 || -f "core") { 316 my $with = ($r & 128) ? 'with' : 'without'; 317 if(-f "core") { 318 $with = "with"; 319 } 320 printf " (terminated with signal %u, %s coredump)", ($r & 127), $with; 321 if($linecount == 0) { 322 print "\n"; 323 } else { 324 print " with error messages:\n"; 325 showfile($stderrlog); 326 } 327 return(($r & 128) ? 10 : 20); 328 } 329 if($linecount == 0) { 330 print "\n"; 331 } else { 332 print " with error messages:\n"; 333 showfile($stderrlog); 334 } 335 return(5); 336} 337 338sub loadconfighash { 339 if(defined($confighhash)) { 340 return $confighhash; 341 } 342 343 $main::confighhash = {}; 344 345 # this could be loaded once perhaps. 346 open(CONFIG_H, "config.h") || die "Can not open config.h: $!\n"; 347 while(<CONFIG_H>) { 348 chomp; 349 if(/^\#define (.*) 1/) { 350 #print "Setting $1\n"; 351 $main::confighhash->{$1} = 1; 352 } 353 } 354 close(CONFIG_H); 355 #print Dumper($main::confighhash); 356 357 # also run tcpdump --fp-type to get the type of floating-point 358 # arithmetic we're doing, setting a HAVE_{fptype} key based 359 # on the value it prints 360 open(FPTYPE_PIPE, "$TCPDUMP --fp-type |") or die("piping tcpdump --fp-type failed\n"); 361 my $fptype_val = <FPTYPE_PIPE>; 362 close(FPTYPE_PIPE); 363 my $have_fptype; 364 if($fptype_val == "9877.895") { 365 $have_fptype = "HAVE_FPTYPE1"; 366 } else { 367 $have_fptype = "HAVE_FPTYPE2"; 368 } 369 $main::confighhash->{$have_fptype} = 1; 370 371 return $main::confighhash; 372} 373 374 375sub runOneComplexTest { 376 local($testconfig) = @_; 377 378 my $output = $testconfig->{output}; 379 my $input = $testconfig->{input}; 380 my $name = $testconfig->{name}; 381 my $options= $testconfig->{args}; 382 my $foundit = 1; 383 my $unfoundit=1; 384 385 my $configset = $testconfig->{config_set}; 386 my $configunset = $testconfig->{config_unset}; 387 my $ch = loadconfighash(); 388 #print Dumper($ch); 389 390 if(defined($configset)) { 391 $foundit = ($ch->{$configset} == 1); 392 } 393 if(defined($configunset)) { 394 $unfoundit=($ch->{$configunset} != 1); 395 } 396 397 if(!$foundit) { 398 printf " %-40s: skipped (%s not set)\n", $name, $configset; 399 return 0; 400 } 401 402 if(!$unfoundit) { 403 printf " %-40s: skipped (%s set)\n", $name, $configunset; 404 return 0; 405 } 406 407 #use Data::Dumper; 408 #print Dumper($testconfig); 409 410 # EXPAND any occurrences of @TESTDIR@ to $testsdir 411 $options =~ s/\@TESTDIR\@/$testsdir/; 412 413 my $result = runtest($name, 414 $testsdir . "/" . $input, 415 $testsdir . "/" . $output, 416 $options); 417 418 if($result == 0) { 419 $passedcount++; 420 } else { 421 $failedcount++; 422 } 423} 424 425# *.tests files are PERL hash definitions. They should create an array of hashes 426# one per test, and place it into the variable @testlist. 427sub runComplexTests { 428 my @files = glob( $testsdir . '/*.tests' ); 429 foreach $file (@files) { 430 my @testlist = undef; 431 my $definitions; 432 print "FILE: ${file}\n"; 433 open(FILE, "<".$file) || die "can not open $file: $!"; 434 { 435 local $/ = undef; 436 $definitions = <FILE>; 437 } 438 close(FILE); 439 #print "STUFF: ${definitions}\n"; 440 eval $definitions; 441 if(defined($testlist)) { 442 #use Data::Dumper; 443 #print Dumper($testlist); 444 foreach $test (@$testlist) { 445 runOneComplexTest($test); 446 } 447 } else { 448 warn "File: ${file} could not be loaded as PERL: $!"; 449 } 450 } 451} 452 453sub runSimpleTests { 454 455 local($only)=@_; 456 457 open(TESTLIST, "<" . "${testsdir}/TESTLIST") || die "no ${testsdir}/TESTFILE: $!\n"; 458 while(<TESTLIST>) { 459 next if /^\#/; 460 next if /^$/; 461 462 unlink("core"); 463 ($name, $input, $output, @options) = split; 464 #print "processing ${only} vs ${name}\n"; 465 next if(defined($only) && $only ne $name); 466 467 my $options = join(" ", @options); 468 #print "@{options} becomes ${options}\n"; 469 470 my $hash = { name => $name, 471 input=> $input, 472 output=>$output, 473 args => $options }; 474 475 runOneComplexTest($hash); 476 } 477} 478 479if(scalar(@ARGV) == 0) { 480 runSimpleTests(); 481 runComplexTests(); 482} else { 483 runSimpleTests($ARGV[0]); 484} 485 486# exit with number of failing tests. 487print "------------------------------------------------\n"; 488printf("%4u tests failed\n",$failedcount); 489printf("%4u tests passed\n",$passedcount); 490 491showfile(${failureoutput}); 492exit $failedcount; 493