• Home
  • Line#
  • Scopes#
  • Navigate#
  • Raw
  • Download
1#!/usr/bin/env perl
2
3#
4# Were we told where to find tcpdump?
5#
6if (!($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#
24use constant { true => 1, false => 0 };
25
26use File::Basename;
27use POSIX qw( WEXITSTATUS WIFEXITED);
28use Cwd qw(abs_path getcwd);
29use File::Path qw(mkpath);   # mkpath works with ancient perl, as well as newer perl
30use File::Spec;
31use Data::Dumper;            # for debugging.
32
33# these are created in the directory where we are run, which might be
34# a build directory.
35my $newdir = "tests/NEW";
36my $diffdir= "tests/DIFF";
37mkpath($newdir);
38mkpath($diffdir);
39my $origdir = getcwd();
40my $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#
52my $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);
58print "Running tests from ${testsdir}\n";
59print "with ${TCPDUMP}, version:\n";
60system "${TCPDUMP} --version";
61
62unshift(@INC, $testsdir);
63
64$passedcount = 0;
65$failedcount = 0;
66#
67my $failureoutput=$origdir . "/tests/failure-outputs.txt";
68
69# truncate the output file
70open(FAILUREOUTPUT, ">" . $failureoutput);
71close(FAILUREOUTPUT);
72
73$confighhash = undef;
74
75sub 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
89sub 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
338sub 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
375sub 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.
427sub 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
453sub 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
479if(scalar(@ARGV) == 0) {
480    runSimpleTests();
481    runComplexTests();
482} else {
483    runSimpleTests($ARGV[0]);
484}
485
486# exit with number of failing tests.
487print "------------------------------------------------\n";
488printf("%4u tests failed\n",$failedcount);
489printf("%4u tests passed\n",$passedcount);
490
491showfile(${failureoutput});
492exit $failedcount;
493