The Tcpdump Group git mirrors - tcpdump/blob - tests/TESTrun

   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"
  16     } else {
  17         $TCPDUMP = "./tcpdump"
  18     }
  19 }
  20
  21 #
  22 # Make true and false work as Booleans.
  23 #
  24 use constant { true => 1, false => 0 };
  25
  26 use File::Basename;
  27 use POSIX qw( WEXITSTATUS WIFEXITED);
  28 use Cwd qw(abs_path getcwd);
  29 use File::Path qw(mkpath);   # mkpath works with ancient perl, as well as newer perl
  30 use File::Spec;
  31 use Data::Dumper;            # for debugging.
  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
  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 #
  52 my $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);
  58 print "Running tests from ${testsdir}\n";
  59 print "with ${TCPDUMP}, version:\n";
  60 system "${TCPDUMP} --version";
  61
  62 unshift(@INC, $testsdir);
  63
  64 $passedcount = 0;
  65 $failedcount = 0;
  66 #
  67 my $failureoutput=$origdir . "/tests/failure-outputs.txt";
  68
  69 # truncate the output file
  70 open(FAILUREOUTPUT, ">" . $failureoutput);
  71 close(FAILUREOUTPUT);
  72
  73 $confighhash = undef;
  74
  75 sub 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
  89 sub 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
 338 sub 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
 375 sub 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.
 427 sub 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
 453 sub 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
 479 if(scalar(@ARGV) == 0) {
 480     runSimpleTests();
 481     runComplexTests();
 482 } else {
 483     runSimpleTests($ARGV[0]);
 484 }
 485
 486 # exit with number of failing tests.
 487 print "------------------------------------------------\n";
 488 printf("%4u tests failed\n",$failedcount);
 489 printf("%4u tests passed\n",$passedcount);
 490
 491 showfile(${failureoutput});
 492 exit $failedcount;