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