path: root/tests/TESTrun

#!/usr/bin/env perl

#
# Were we told where to find tcpdump?
#
if (!($TCPDUMP = $ENV{TCPDUMP_BIN})) {
    #
    # No.  Use the appropriate path.
    #
    if ($^O eq 'MSWin32') {
        #
        # XXX - assume, for now, a Visual Studio debug build, so that
        # tcpdump is in the Debug subdirectory.
        #
        $TCPDUMP = "Debug\\tcpdump.exe"
    } else {
        $TCPDUMP = "./tcpdump"
    }
}

#
# Make true and false work as Booleans.
#
use constant true => 1;
use constant false => 0;

use File::Basename;
use POSIX qw( WEXITSTATUS WIFEXITED);
use Cwd qw(abs_path getcwd);
use File::Path qw(mkpath);   # mkpath works with ancient perl, as well as newer perl
use File::Spec;
use Data::Dumper;            # for debugging.

# these are created in the directory where we are run, which might be
# a build directory.
my $newdir = "tests/NEW";
my $diffdir= "tests/DIFF";
mkpath($newdir);
mkpath($diffdir);
my $origdir = getcwd();
my $srcdir  = $ENV{'srcdir'} || ".";
# Default to unified diff and allow to fall back to basic diff if necessary.
my $diff_flags = defined $ENV{'DIFF_FLAGS'} ? $ENV{'DIFF_FLAGS'} : '-u';

#
# Force UTC, so time stamps are printed in a standard time zone, and
# tests don't have to be run in the time zone in which the output
# file was generated.
#
$ENV{'TZ'}='GMT0';

#
# Get the tests directory from $0.
#
my $testsdir = dirname($0);

#
# Convert it to an absolute path, so it works even after we do a cd.
#
$testsdir = abs_path($testsdir);
print "Running tests from ${testsdir}\n";
print "with ${TCPDUMP}, version:\n";
system "${TCPDUMP} --version";

unshift(@INC, $testsdir);

$passedcount = 0;
$failedcount = 0;
$skippedcount = 0;
#
my $failureoutput=$origdir . "/tests/failure-outputs.txt";

# truncate the output file
open(FAILUREOUTPUT, ">" . $failureoutput);
close(FAILUREOUTPUT);

$confighhash = undef;

sub showfile {
    local($path) = @_;

    #
    # XXX - just do this directly in Perl?
    #
    if ($^O eq 'MSWin32') {
        my $winpath = File::Spec->canonpath($path);
        system "type $winpath";
    } else {
        system "cat $path";
    }
}

sub runtest {
    local($name, $input, $output, $options) = @_;
    my $r;

    $outputbase = basename($output);
    my $coredump = false;
    my $status = 0;
    my $linecount = 0;
    my $rawstderrlog = "${newdir}/${outputbase}.raw.stderr";
    my $stderrlog = "${newdir}/${outputbase}.stderr";
    my $diffstat = 0;
    my $errdiffstat = 0;

    # we used to do this as a nice pipeline, but the problem is that $r fails to
    # to be set properly if the tcpdump core dumps.
    #
    # Furthermore, on Windows, fc can't read the standard input, so we
    # can't do it as a pipeline in any case.
    if (index($options, "SPECIAL_t") != -1) {
        # Hack to keep specific time options for tcp-handshake-micro-t, etc.
        # -t, -tt, etc.
        $options =~ s/ SPECIAL_t//;
    } else {
        # No specific time option, use -tttt
        $options .= " -tttt";
    }
    $r = system "$TCPDUMP -# -n -r $input $options >${newdir}/${outputbase} 2>${rawstderrlog}";

    if($r != 0) {
        #
        # Something other than "tcpdump opened the file, read it, and
        # dissected all the packets".  What happened?
        #
        # We write out an exit status after whatever the subprocess
        # wrote out, so it shows up when we diff the expected output
        # with it.
        #
        open(OUTPUT, ">>"."${newdir}/$outputbase") || die "fail to open $outputbase\n";
        if($r == -1) {
            # failed to start due to error.
            $status = $!;
            printf OUTPUT "FAILED TO RUN: status: %d\n", $status;
        } else {
            if ($^O eq 'MSWin32' or $^O eq 'msys') {
                #
                # On Windows, the return value of system is the lower 8
                # bits of the exit status of the process, shifted left
                # 8 bits.
                #
                # If the process crashed, rather than exiting, the
                # exit status will be one of the EXCEPTION_ values
                # listed in the documentation for the GetExceptionCode()
                # macro.
                #
                # Those are defined as STATUS_ values, which should have
                # 0xC in the topmost 4 bits (being fatal error
                # statuses); some of them have a value that fits in
                # the lower 8 bits.  We could, I guess, assume that
                # any value that 1) isn't returned by tcpdump and 2)
                # corresponds to the lower 8 bits of a STATUS_ value
                # used as an EXCEPTION_ value indicates that tcpdump
                # exited with that exception.
                #
                # However, as we're running tcpdump with system, which
                # runs the command through cmd.exe, and as cmd.exe
                # doesn't map the command's exit code to its own exit
                # code in any straightforward manner, we can't get
                # that information in any case, so there's no point
                # in trying to interpret it in that fashion.
                #
                $status = $r >> 8;
            } else {
                #
                # On UN*Xes, the return status is a POSIX as filled in
                # by wait() or waitpid().
                #
                # POSIX offers some calls for analyzing it, such as
                # WIFSIGNALED() to test whether it indicates that the
                # process was terminated by a signal, WTERMSIG() to
                # get the signal number from it, WIFEXITED() to test
                # whether it indicates that the process exited normally,
                # and WEXITSTATUS() to get the exit status from it.
                #
                # POSIX doesn't standardize core dumps, so the POSIX
                # calls can't test whether a core dump occurred.
                # However, all the UN*Xes we are likely to encounter
                # follow Research UNIX in this regard, with the exit
                # status containing either 0 or a signal number in
                # the lower 7 bits, with 0 meaning "exited rather
                # than being terminated by a signal", the "core dumped"
                # flag in the 0x80 bit, and, if the signal number is
                # 0, the exit status in the next 8 bits up.
                #
                # This should be cleaned up to use the POSIX calls
                # from the Perl library - and to define an additional
                # WCOREDUMP() call to test the "core dumped" bit and
                # use that.
                #
                # But note also that, as we're running tcpdump with
                # system, which runs the command through a shell, if
                # tcpdump crashes, we'll only know that if the shell
                # maps the signal indication and uses that as its
                # exit status.
                #
                # The good news is that the Bourne shell, and compatible
                # shells, have traditionally done that.  If the process
                # for which the shell reports the exit status terminates
                # with a signal, it adds 128 to the signal number and
                # returns that as its exit status.  (This is why the
                # "this is now working right" behavior described in a
                # comment below is occurring.)
                #
                # As tcpdump itself never returns with an exit status
                # >= 128, we can try checking for an exit status with
                # the 0x80 bit set and, if we have one, get the signal
                # number from the lower 7 bits of the exit status.  We
                # can't get the "core dumped" indication from the
                # shell's exit status; all we can do is check whether
                # there's a core file.
                #
                if( $r & 128 ) {
                    $coredump = $r & 127;
                }
                if( WIFEXITED($r)) {
                    $status = WEXITSTATUS($r);
                }
            }

            if($coredump || $status) {
                printf OUTPUT "EXIT CODE %08x: dump:%d code: %d\n", $r, $coredump, $status;
            } else {
                printf OUTPUT "EXIT CODE %08x\n", $r;
            }
            $r = 0;
        }
        close(OUTPUT);
    }
    if($r == 0) {
        #
        # Compare tcpdump's output with what we think it should be.
        # If tcpdump failed to produce output, we've produced our own
        # "output" above, with the exit status.
        #
        if ($^O eq 'MSWin32') {
            my $winoutput = File::Spec->canonpath($output);
            my $winnewdir = File::Spec->canonpath($newdir);
            my $windiffdir = File::Spec->canonpath($diffdir);
            $r = system "fc /lb1000 /t /1 $winoutput ${winnewdir}\\$outputbase >${windiffdir}\\$outputbase.diff";
            $diffstat = $r >> 8;
        } else {
            $r = system "diff $diff_flags $output ${newdir}/$outputbase >${diffdir}/$outputbase.diff";
            $diffstat = WEXITSTATUS($r);
        }
    }

    # process the standard error file, sanitize "reading from" line,
    # and count lines
    $linecount = 0;
    open(ERRORRAW, "<" . $rawstderrlog);
    open(ERROROUT, ">" . $stderrlog);
    while(<ERRORRAW>) {
        next if /^$/;  # blank lines are boring
        if(/^(reading from file )(.*)(,.*)$/) {
            my $filename = basename($2);
            print ERROROUT "${1}${filename}${3}\n";
            next;
        }
        print ERROROUT;
        $linecount++;
    }
    close(ERROROUT);
    close(ERRORRAW);

    if ( -f "$output.stderr" ) {
        #
        # Compare the standard error with what we think it should be.
        #
        if ($^O eq 'MSWin32') {
            my $winoutput = File::Spec->canonpath($output);
            my $windiffdir = File::Spec->canonpath($diffdir);
            my $canonstderrlog = File::Spec->canonpath($stderrlog);
            $nr = system "fc /lb1000 /t /1 $winoutput.stderr $canonstderrlog >${windiffdir}\\$outputbase.stderr.diff";
            $errdiffstat = $nr >> 8;
        } else {
            $nr = system "diff $output.stderr $stderrlog >${diffdir}/$outputbase.stderr.diff";
            $errdiffstat = WEXITSTATUS($nr);
        }
        if($r == 0) {
            $r = $nr;
        }
    }

    if($r == 0) {
        if($linecount == 0 && $status == 0) {
            unlink($stderrlog);
        } else {
            $errdiffstat = 1;
        }
    }

    #print sprintf("END: %08x\n", $r);

    if($r == 0) {
        if($linecount == 0) {
            printf "    %-40s: passed\n", $name;
        } else {
            printf "    %-40s: passed with error messages:\n", $name;
            showfile($stderrlog);
        }
        unlink "${diffdir}/$outputbase.diff";
        return 0;
    }
    # must have failed!
    printf "    %-40s: TEST FAILED(exit core=%d/diffstat=%d,%d/r=%d)", $name, $coredump, $diffstat, $errdiffstat, $r;
    open FOUT, '>>tests/failure-outputs.txt';
    printf FOUT "\nFailed test: $name\n\n";
    close FOUT;
    if(-f "${diffdir}/$outputbase.diff") {
        #
        # XXX - just do this directly in Perl?
        #
        if ($^O eq 'MSWin32') {
            my $windiffdir = File::Spec->canonpath($diffdir);
            system "type ${windiffdir}\\$outputbase.diff >> tests\\failure-outputs.txt";
        } else {
            system "cat ${diffdir}/$outputbase.diff >> tests/failure-outputs.txt";
        }
    }

    if($r == -1) {
        print " (failed to execute: $!)\n";
        return(30);
    }

    # this is not working right, $r == 0x8b00 when there is a core dump.
    # clearly, we need some platform specific perl magic to take this apart, so look for "core"
    # too.
    # In particular, on Solaris 10 SPARC an alignment problem results in SIGILL,
    # a core dump and $r set to 0x00008a00 ($? == 138 in the shell).
    if($r & 127 || -f "core") {
        my $with = ($r & 128) ? 'with' : 'without';
        if(-f "core") {
            $with = "with";
        }
        printf " (terminated with signal %u, %s coredump)", ($r & 127), $with;
        if($linecount == 0) {
            print "\n";
        } else {
            print " with error messages:\n";
            showfile($stderrlog);
        }
        return(($r & 128) ? 10 : 20);
    }
    if($linecount == 0) {
        print "\n";
    } else {
        print " with error messages:\n";
        showfile($stderrlog);
    }
    return(5);
}

sub loadconfighash {
    if(defined($confighhash)) {
        return $confighhash;
    }

    $main::confighhash = {};

    # this could be loaded once perhaps.
    open(CONFIG_H, "config.h") || die "Can not open config.h: $!\n";
    while(<CONFIG_H>) {
        chomp;
        if(/^\#define (.*) 1/) {
            #print "Setting $1\n";
            $main::confighhash->{$1} = 1;
        }
    }
    close(CONFIG_H);
    #print Dumper($main::confighhash);

    # also run tcpdump --fp-type to get the type of floating-point
    # arithmetic we're doing, setting a HAVE_{fptype} key based
    # on the value it prints
    open(FPTYPE_PIPE, "$TCPDUMP --fp-type |") or die("piping tcpdump --fp-type failed\n");
    my $fptype_val = <FPTYPE_PIPE>;
    close(FPTYPE_PIPE);
    my $have_fptype;
    if($fptype_val == "9877.895") {
        $have_fptype = "HAVE_FPTYPE1";
    } else {
        $have_fptype = "HAVE_FPTYPE2";
    }
    printf "$TCPDUMP --fp-type => %s\n", $have_fptype;
    $main::confighhash->{$have_fptype} = 1;

    # and check whether this is OpenBSD, as one test fails in OpenBSD
    # due to the sad hellscape of low-numbered DLT_ values, due to
    # 12 meaning "OpenBSD loopback" rather than "raw IP" on OpenBSD
    if($^O eq "openbsd") {
        $main::confighhash->{"IS_OPENBSD"} = 1;
    }

    return $main::confighhash;
}


sub runOneComplexTest {
    local($testconfig) = @_;

    my $output = $testconfig->{output};
    my $input  = $testconfig->{input};
    my $name   = $testconfig->{name};
    my $options= $testconfig->{args};
    my $foundit = 1;
    my $unfoundit=1;

    my $configset = $testconfig->{config_set};
    my $configunset = $testconfig->{config_unset};
    my $ch = loadconfighash();
    #print Dumper($ch);

    if(defined($configset)) {
        $foundit = ($ch->{$configset} == 1);
    }
    if(defined($configunset)) {
        $unfoundit=($ch->{$configunset} != 1);
    }

    if(!$foundit) {
        printf "    %-40s: skipped (%s not set)\n", $name, $configset;
        $skippedcount++;
        return 0;
    }

    if(!$unfoundit) {
        printf "    %-40s: skipped (%s set)\n", $name, $configunset;
        $skippedcount++;
        return 0;
    }

    #use Data::Dumper;
    #print Dumper($testconfig);

    # EXPAND any occurrences of @TESTDIR@ to $testsdir
    $options =~ s/\@TESTDIR\@/$testsdir/;

    my $result = runtest($name,
                         $testsdir . "/" . $input,
                         $testsdir . "/" . $output,
                         $options);

    if($result == 0) {
        $passedcount++;
    } else {
        $failedcount++;
    }
}

# *.tests files are PERL hash definitions.  They should create an array of hashes
# one per test, and place it into the variable @testlist.
sub runComplexTests {
    my @files = glob( $testsdir . '/*.tests' );
    foreach $file (@files) {
        my @testlist = undef;
        my $definitions;
        print "FILE: ${file}\n";
        open(FILE, "<".$file) || die "can not open $file: $!";
        {
            local $/ = undef;
            $definitions = <FILE>;
        }
        close(FILE);
        #print "STUFF: ${definitions}\n";
        eval $definitions;
        if(defined($testlist)) {
            #use Data::Dumper;
            #print Dumper($testlist);
            foreach $test (@$testlist) {
                runOneComplexTest($test);
            }
        } else {
            warn "File: ${file} could not be loaded as PERL: $!";
        }
    }
}

sub runSimpleTests {

    local($only)=@_;

    open(TESTLIST, "<" . "${testsdir}/TESTLIST") || die "no ${testsdir}/TESTFILE: $!\n";
    while(<TESTLIST>) {
        next if /^\#/;
        next if /^$/;

        unlink("core");
        ($name, $input, $output, @options) = split;
        #print "processing ${only} vs ${name}\n";
        next if(defined($only) && $only ne $name);

        my $options = join(" ", @options);
        #print "@{options} becomes ${options}\n";

        my $hash = { name => $name,
                     input=> $input,
                     output=>$output,
                     args => $options };

        runOneComplexTest($hash);
    }
}

if(scalar(@ARGV) == 0) {
    runSimpleTests();
    runComplexTests();
} else {
    runSimpleTests($ARGV[0]);
}

# exit with number of failing tests.
print "------------------------------------------------\n";
printf("%4u tests skipped\n",$skippedcount);
printf("%4u tests failed\n",$failedcount);
printf("%4u tests passed\n",$passedcount);

showfile(${failureoutput});
exit $failedcount;