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