The Tcpdump Group git mirrors - libpcap/blob - testprogs/TESTlib.pm

   1 require 5.8.4; # Solaris 10
   2 use strict;
   3 use warnings FATAL => qw(uninitialized);
   4 use Config;
   5 use File::Temp qw(tempdir);
   6 use List::Util qw(min max sum);
   7
   8 # TESTrun helper functions (common to all projects).
   9
  10 # TESTst.pm or TESTmt.pm
  11 use subs qw(
  12         get_next_result
  13         my_tmp_id
  14         start_tests
  15 );
  16
  17 # The characters are inspired by PHPUnit format, but are not exactly the same.
  18 use constant {
  19         CHAR_SKIPPED => 'S',
  20         CHAR_PASSED => '.',
  21         CHAR_FAILED => 'F',
  22         CHAR_TIMED_OUT => 'T',
  23 };
  24
  25 my %osnames = (
  26         aix => 'AIX',
  27         darwin => 'macOS',
  28         dragonfly => 'DragonFly BSD',
  29         freebsd => 'FreeBSD',
  30         gnu => 'Hurd',
  31         haiku => 'Haiku',
  32         hpux => 'HP-UX',
  33         linux => 'Linux',
  34         msys => 'Windows',
  35         netbsd => 'NetBSD',
  36         openbsd => 'OpenBSD',
  37         solaris => 'illumos/Solaris',
  38 );
  39
  40 my $results_to_print;
  41 my $results_printed;
  42 my $max_result_digits;
  43 my $max_results_per_line;
  44 my $flush_after_newline;
  45 my $tmpdir;
  46 my %config;
  47
  48 sub init_tmpdir {
  49         my $prefix = shift;
  50         # No File::Temp->newdir() in Perl 5.8.4.
  51         $tmpdir = tempdir (
  52                 "${prefix}_XXXXXXXX",
  53                 TMPDIR => 1,
  54                 CLEANUP => 1
  55         );
  56 }
  57
  58 sub mytmpfile {
  59         return sprintf '%s/%s-%s', $tmpdir, my_tmp_id, shift;
  60 }
  61
  62 sub get_njobs {
  63         my $njobs;
  64         if (! defined $ENV{TESTRUN_JOBS}) {
  65                 $njobs = 1;
  66         } elsif ($ENV{TESTRUN_JOBS} =~ /^\d+\z/) {
  67                 $njobs = int ($ENV{TESTRUN_JOBS});
  68         } else {
  69                 $njobs = 0;
  70         }
  71         die "ERROR: '$ENV{TESTRUN_JOBS}' is not a valid value for TESTRUN_JOBS" if ! $njobs;
  72         return $njobs;
  73 }
  74
  75 sub get_diff_flags {
  76         return defined $ENV{DIFF_FLAGS} ? $ENV{DIFF_FLAGS} :
  77         $^O eq 'hpux' ? '-c' :
  78         '-u';
  79 }
  80
  81 # Parse config.h into a hash for later use.
  82 sub read_config_h {
  83         my $config_h = shift;
  84         %config = ();
  85         open FH, '<', $config_h or die "failed opening '$config_h'";
  86         while (<FH>) {
  87                 $config{$1} = $2 if /^
  88                         [[:blank:]]*\#define
  89                         [[:blank:]]+([0-9_A-Z]+)
  90                         [[:blank:]]+([0-9]+|".*")
  91                         [\r\n]*$/xo;
  92         }
  93         close FH or die "failed closing '$config_h'";
  94         return %config;
  95 }
  96
  97 # This is a simpler version of the PHP function.
  98 sub file_put_contents {
  99         my ($filename, $contents) = @_;
 100         open FH, '>', $filename or die "failed opening '$filename'";
 101         print FH $contents;
 102         close FH or die "failed closing '$filename'";
 103 }
 104
 105 # Idem.
 106 sub file_get_contents {
 107         my $filename = shift;
 108         open FH, '<', $filename or die "failed opening '$filename'";
 109         my $ret = '';
 110         $ret .= $_ while (<FH>);
 111         close FH or die "failed closing '$filename'";
 112         return $ret;
 113 }
 114
 115 sub string_in_file {
 116         my ($string, $filename) = @_;
 117         my $ret = 0;
 118         open FH, '<', $filename or die "failed opening '$filename'";
 119         while (<FH>) {
 120                 if (-1 != index $_, $string) {
 121                         $ret = 1;
 122                         last;
 123                 }
 124         }
 125         close FH or die "failed closing '$filename'";
 126         return $ret;
 127 }
 128
 129 sub skip_os {
 130         my $name = shift;
 131         my $bettername = $osnames{$name} || $name;
 132         return $^O eq $name ? "is $bettername" : '';
 133 }
 134
 135 sub skip_os_not {
 136         my $name = shift;
 137         my $bettername = $osnames{$name} || $name;
 138         return $^O ne $name ? "is not $bettername" : '';
 139 }
 140
 141 sub skip_config_def1 {
 142         my $symbol = shift;
 143         return (defined $config{$symbol} && $config{$symbol} eq '1') ?
 144                 "$symbol==1" : '';
 145 }
 146
 147 sub skip_config_undef {
 148         my $symbol = shift;
 149         return (! defined $config{$symbol} || $config{$symbol} ne '1') ?
 150                 "${symbol}!=1" : '';
 151 }
 152
 153 sub skip_config_have_decl {
 154         my ($name, $value) = @_;
 155         $name = 'HAVE_DECL_' . $name;
 156         # "Unlike the other ‘AC_CHECK_*S’ macros, when a symbol is not declared,
 157         # HAVE_DECL_symbol is defined to ‘0’ instead of leaving HAVE_DECL_symbol
 158         # undeclared." -- GNU Autoconf manual.
 159         #
 160         # (This requires the CMake leg to do the same for the same symbol.)
 161         die "no $name in config.h" unless defined $config{$name};
 162         return int ($config{$name}) == $value ? "$name==$value" : '';
 163 }
 164
 165 sub result_skipped {
 166         return {
 167                 char => CHAR_SKIPPED,
 168                 skip => shift
 169         };
 170 }
 171
 172 sub result_passed {
 173         return {
 174                 char => CHAR_PASSED,
 175                 T => shift
 176         };
 177 }
 178
 179 sub result_failed {
 180         return {
 181                 char => CHAR_FAILED,
 182                 failure => {
 183                         reason => shift,
 184                         details => shift
 185                 }
 186         };
 187 }
 188
 189 sub result_timed_out {
 190         return {
 191                 char => CHAR_TIMED_OUT,
 192                 failure => {reason => shift}
 193         };
 194 }
 195
 196 sub run_skip_test {
 197         my $test = shift;
 198         return result_skipped $test->{skip};
 199 }
 200
 201 # <------------------------- $maxcols -------------------------->
 202 # ............................................ 0000 / 0000 (000%)
 203 #                          $max_result_digits >----< >----<
 204 # <--------- $max_results_per_line ---------->
 205 sub init_results_processing {
 206         my $maxcols = 80;
 207         $results_to_print = shift;
 208         if ($Config{useithreads}) {
 209                 # When using threads, STDOUT becomes line-buffered on TTYs, which is
 210                 # not good for interactive progress monitoring.
 211                 STDOUT->autoflush (1) if -t STDOUT;
 212                 $flush_after_newline = ! -t STDOUT;
 213         }
 214         $results_printed = 0;
 215         $max_result_digits = 1 + int (log ($results_to_print) / log (10));
 216         $max_results_per_line = $maxcols - 11 - 2 * $max_result_digits;
 217 }
 218
 219 # Produce a results map in PHPUnit output format.
 220 sub print_result_char {
 221         print shift;
 222         if (++$results_printed > $results_to_print) {
 223                 die "Internal error: unexpected results after 100%!";
 224         }
 225         my $results_dangling = $results_printed % $max_results_per_line;
 226         if ($results_dangling) {
 227                 return if $results_printed < $results_to_print;
 228                 # Complete the dangling line to keep the progress column aligned.
 229                 print ' ' x ($max_results_per_line - $results_dangling);
 230         }
 231         printf " %*u / %*u (%3u%%)\n",
 232                 $max_result_digits,
 233                 $results_printed,
 234                 $max_result_digits,
 235                 $results_to_print,
 236                 100 * $results_printed / $results_to_print;
 237         # When using threads, STDOUT becomes block-buffered on pipes, which is
 238         # not good for CI progress monitoring.
 239         STDOUT->flush if $flush_after_newline;
 240 }
 241
 242 sub print_result {
 243         printf "    %-40s: %s\n", @_;
 244 }
 245
 246 sub test_and_report {
 247         my @tests = @_;
 248
 249         my %seen_labels;
 250         foreach (@tests) {
 251                 my $label = $_->{label};
 252                 die "ERROR: Duplicate test label '$label'" if exists $seen_labels{$label};
 253                 $seen_labels{$label} = 1;
 254         }
 255         undef %seen_labels;
 256
 257         start_tests (@tests);
 258         init_results_processing scalar @tests;
 259         my $ret = 0;
 260         # key: test label, value: reason for skipping
 261         my %skipped;
 262         # key: test label, value: hash of
 263         # * reason (mandatory, string)
 264         # * details (optional, [multi-line] string)
 265         my %failed;
 266         my $passedcount = 0;
 267         my %passed; # May stay empty even if $passedcount > 0.
 268
 269         printf "INFO: %s = skipped, %s = passed, %s = failed, %s = timed out\n",
 270                 CHAR_SKIPPED, CHAR_PASSED, CHAR_FAILED, CHAR_TIMED_OUT;
 271
 272         # Ordering of the results is the same as ordering of the tests.  Print the
 273         # results map immediately and buffer any skipped/failed test details for the
 274         # post-map diagnostics.
 275         while (defined (my $result = get_next_result)) {
 276                 print_result_char ($result->{char});
 277                 if (defined $result->{skip}) {
 278                         $skipped{$result->{label}} = $result->{skip};
 279                 } elsif (defined $result->{failure}) {
 280                         $failed{$result->{label}} = $result->{failure};
 281                 } else {
 282                         $passedcount++;
 283                         $passed{$result->{label}} = $result->{T} if defined $result->{T};
 284                 }
 285         }
 286
 287         print "\n";
 288         if (%passed) {
 289                 print "Passed tests:\n";
 290                 print_result $_, sprintf ('T=%.06fs', $passed{$_}) foreach (sort keys %passed);
 291                 print "\n";
 292         }
 293         if (%skipped) {
 294                 print "Skipped tests:\n";
 295                 foreach (sort keys %skipped) {
 296                         print_result $_, $skipped{$_} if $skipped{$_} ne '';
 297                 }
 298                 print "\n";
 299         }
 300         if (%failed) {
 301                 $ret = 1;
 302                 print "Failed tests:\n";
 303                 foreach (sort keys %failed) {
 304                         print_result $_, $failed{$_}{reason};
 305                         print $failed{$_}{details} if defined $failed{$_}{details};
 306                 }
 307                 print "\n";
 308         }
 309
 310         # scalar (%hash) returns incorrect value on Perl 5.8.4.
 311         my $skippedcount = scalar keys %skipped;
 312         my $failedcount = scalar keys %failed;
 313         print "------------------------------------------------\n";
 314         printf "%4u tests skipped\n", $skippedcount;
 315         printf "%4u tests failed\n", $failedcount;
 316         if (! scalar keys %passed) {
 317                 # There isn't any test duration statistics.
 318                 printf "%4u tests passed\n", $passedcount;
 319         } elsif ($passedcount != scalar keys %passed) {
 320                 die sprintf ("Internal error: statistics bug (%u != %u)",
 321                         $passedcount,
 322                         scalar (keys %passed)
 323                 );
 324         } else {
 325                 printf "%4u tests passed: T min/avg/max = %.06f/%.06f/%.06fs\n",
 326                         scalar (keys %passed),
 327                         min (values %passed),
 328                         sum (values %passed) / scalar (keys %passed),
 329                         max (values %passed);
 330         }
 331
 332         if ($skippedcount + $failedcount + $passedcount != $results_to_print) {
 333                 printf STDERR "Internal error: statistics bug (%u + %u + %u != %u)\n",
 334                         $skippedcount,
 335                         $failedcount,
 336                         $passedcount,
 337                         $results_to_print;
 338                 $ret = 2;
 339         }
 340         return $ret;
 341 }
 342
 343 1;