|
| 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; |
0 commit comments