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