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