| 1 | # |
| 2 | # t/test.pl - most of Test::More functionality without the fuss |
| 3 | |
| 4 | |
| 5 | # NOTE: |
| 6 | # |
| 7 | # Do not rely on features found only in more modern Perls here, as some CPAN |
| 8 | # distributions copy this file and must operate on older Perls. Similarly, keep |
| 9 | # things, simple as this may be run under fairly broken circumstances. For |
| 10 | # example, increment ($x++) has a certain amount of cleverness for things like |
| 11 | # |
| 12 | # $x = 'zz'; |
| 13 | # $x++; # $x eq 'aaa'; |
| 14 | # |
| 15 | # This stands more chance of breaking than just a simple |
| 16 | # |
| 17 | # $x = $x + 1 |
| 18 | # |
| 19 | # In this file, we use the latter "Baby Perl" approach, and increment |
| 20 | # will be worked over by t/op/inc.t |
| 21 | |
| 22 | $| = 1; |
| 23 | our $Level = 1; |
| 24 | my $test = 1; |
| 25 | my $planned; |
| 26 | my $noplan; |
| 27 | my $Perl; # Safer version of $^X set by which_perl() |
| 28 | |
| 29 | # This defines ASCII/UTF-8 vs EBCDIC/UTF-EBCDIC |
| 30 | $::IS_ASCII = ord 'A' == 65; |
| 31 | $::IS_EBCDIC = ord 'A' == 193; |
| 32 | |
| 33 | # This is 'our' to enable harness to account for TODO-ed tests in |
| 34 | # overall grade of PASS or FAIL |
| 35 | our $TODO = 0; |
| 36 | our $NO_ENDING = 0; |
| 37 | our $Tests_Are_Passing = 1; |
| 38 | |
| 39 | # Use this instead of print to avoid interference while testing globals. |
| 40 | sub _print { |
| 41 | local($\, $", $,) = (undef, ' ', ''); |
| 42 | print STDOUT @_; |
| 43 | } |
| 44 | |
| 45 | sub _print_stderr { |
| 46 | local($\, $", $,) = (undef, ' ', ''); |
| 47 | print STDERR @_; |
| 48 | } |
| 49 | |
| 50 | sub plan { |
| 51 | my $n; |
| 52 | if (@_ == 1) { |
| 53 | $n = shift; |
| 54 | if ($n eq 'no_plan') { |
| 55 | undef $n; |
| 56 | $noplan = 1; |
| 57 | } |
| 58 | } else { |
| 59 | my %plan = @_; |
| 60 | $plan{skip_all} and skip_all($plan{skip_all}); |
| 61 | $n = $plan{tests}; |
| 62 | } |
| 63 | _print "1..$n\n" unless $noplan; |
| 64 | $planned = $n; |
| 65 | } |
| 66 | |
| 67 | |
| 68 | # Set the plan at the end. See Test::More::done_testing. |
| 69 | sub done_testing { |
| 70 | my $n = $test - 1; |
| 71 | $n = shift if @_; |
| 72 | |
| 73 | _print "1..$n\n"; |
| 74 | $planned = $n; |
| 75 | } |
| 76 | |
| 77 | |
| 78 | END { |
| 79 | my $ran = $test - 1; |
| 80 | if (!$NO_ENDING) { |
| 81 | if (defined $planned && $planned != $ran) { |
| 82 | _print_stderr |
| 83 | "# Looks like you planned $planned tests but ran $ran.\n"; |
| 84 | } elsif ($noplan) { |
| 85 | _print "1..$ran\n"; |
| 86 | } |
| 87 | } |
| 88 | } |
| 89 | |
| 90 | sub _diag { |
| 91 | return unless @_; |
| 92 | my @mess = _comment(@_); |
| 93 | $TODO ? _print(@mess) : _print_stderr(@mess); |
| 94 | } |
| 95 | |
| 96 | # Use this instead of "print STDERR" when outputting failure diagnostic |
| 97 | # messages |
| 98 | sub diag { |
| 99 | _diag(@_); |
| 100 | } |
| 101 | |
| 102 | # Use this instead of "print" when outputting informational messages |
| 103 | sub note { |
| 104 | return unless @_; |
| 105 | _print( _comment(@_) ); |
| 106 | } |
| 107 | |
| 108 | sub is_miniperl { |
| 109 | return !defined &DynaLoader::boot_DynaLoader; |
| 110 | } |
| 111 | |
| 112 | sub set_up_inc { |
| 113 | # Don’t clobber @INC under miniperl |
| 114 | @INC = () unless is_miniperl; |
| 115 | unshift @INC, @_; |
| 116 | } |
| 117 | |
| 118 | sub _comment { |
| 119 | return map { /^#/ ? "$_\n" : "# $_\n" } |
| 120 | map { split /\n/ } @_; |
| 121 | } |
| 122 | |
| 123 | sub _have_dynamic_extension { |
| 124 | my $extension = shift; |
| 125 | unless (eval {require Config; 1}) { |
| 126 | warn "test.pl had problems loading Config: $@"; |
| 127 | return 1; |
| 128 | } |
| 129 | $extension =~ s!::!/!g; |
| 130 | return 1 if ($Config::Config{extensions} =~ /\b$extension\b/); |
| 131 | } |
| 132 | |
| 133 | sub skip_all { |
| 134 | if (@_) { |
| 135 | _print "1..0 # Skip @_\n"; |
| 136 | } else { |
| 137 | _print "1..0\n"; |
| 138 | } |
| 139 | exit(0); |
| 140 | } |
| 141 | |
| 142 | sub skip_all_if_miniperl { |
| 143 | skip_all(@_) if is_miniperl(); |
| 144 | } |
| 145 | |
| 146 | sub skip_all_without_dynamic_extension { |
| 147 | my ($extension) = @_; |
| 148 | skip_all("no dynamic loading on miniperl, no $extension") if is_miniperl(); |
| 149 | return if &_have_dynamic_extension; |
| 150 | skip_all("$extension was not built"); |
| 151 | } |
| 152 | |
| 153 | sub skip_all_without_perlio { |
| 154 | skip_all('no PerlIO') unless PerlIO::Layer->find('perlio'); |
| 155 | } |
| 156 | |
| 157 | sub skip_all_without_config { |
| 158 | unless (eval {require Config; 1}) { |
| 159 | warn "test.pl had problems loading Config: $@"; |
| 160 | return; |
| 161 | } |
| 162 | foreach (@_) { |
| 163 | next if $Config::Config{$_}; |
| 164 | my $key = $_; # Need to copy, before trying to modify. |
| 165 | $key =~ s/^use//; |
| 166 | $key =~ s/^d_//; |
| 167 | skip_all("no $key"); |
| 168 | } |
| 169 | } |
| 170 | |
| 171 | sub skip_all_without_unicode_tables { # (but only under miniperl) |
| 172 | if (is_miniperl()) { |
| 173 | skip_all_if_miniperl("Unicode tables not built yet") |
| 174 | unless eval 'require "unicore/UCD.pl"'; |
| 175 | } |
| 176 | } |
| 177 | |
| 178 | sub find_git_or_skip { |
| 179 | my ($source_dir, $reason); |
| 180 | |
| 181 | if ( $ENV{CONTINUOUS_INTEGRATION} && $ENV{WORKSPACE} ) { |
| 182 | $source_dir = $ENV{WORKSPACE}; |
| 183 | if ( -d "${source_dir}/.git" ) { |
| 184 | $ENV{GIT_DIR} = "${source_dir}/.git"; |
| 185 | return $source_dir; |
| 186 | } |
| 187 | } |
| 188 | |
| 189 | if (-d '.git') { |
| 190 | $source_dir = '.'; |
| 191 | } elsif (-l 'MANIFEST' && -l 'AUTHORS') { |
| 192 | my $where = readlink 'MANIFEST'; |
| 193 | die "Can't readlink MANIFEST: $!" unless defined $where; |
| 194 | die "Confusing symlink target for MANIFEST, '$where'" |
| 195 | unless $where =~ s!/MANIFEST\z!!; |
| 196 | if (-d "$where/.git") { |
| 197 | # Looks like we are in a symlink tree |
| 198 | if (exists $ENV{GIT_DIR}) { |
| 199 | diag("Found source tree at $where, but \$ENV{GIT_DIR} is $ENV{GIT_DIR}. Not changing it"); |
| 200 | } else { |
| 201 | note("Found source tree at $where, setting \$ENV{GIT_DIR}"); |
| 202 | $ENV{GIT_DIR} = "$where/.git"; |
| 203 | } |
| 204 | $source_dir = $where; |
| 205 | } |
| 206 | } elsif (exists $ENV{GIT_DIR} || -f '.git') { |
| 207 | my $commit = '8d063cd8450e59ea1c611a2f4f5a21059a2804f1'; |
| 208 | my $out = `git rev-parse --verify --quiet '$commit^{commit}'`; |
| 209 | chomp $out; |
| 210 | if($out eq $commit) { |
| 211 | $source_dir = '.' |
| 212 | } |
| 213 | } |
| 214 | if ($ENV{'PERL_BUILD_PACKAGING'}) { |
| 215 | $reason = 'PERL_BUILD_PACKAGING is set'; |
| 216 | } elsif ($source_dir) { |
| 217 | my $version_string = `git --version`; |
| 218 | if (defined $version_string |
| 219 | && $version_string =~ /\Agit version (\d+\.\d+\.\d+)(.*)/) { |
| 220 | return $source_dir if eval "v$1 ge v1.5.0"; |
| 221 | # If you have earlier than 1.5.0 and it works, change this test |
| 222 | $reason = "in git checkout, but git version '$1$2' too old"; |
| 223 | } else { |
| 224 | $reason = "in git checkout, but cannot run git"; |
| 225 | } |
| 226 | } else { |
| 227 | $reason = 'not being run from a git checkout'; |
| 228 | } |
| 229 | skip_all($reason) if $_[0] && $_[0] eq 'all'; |
| 230 | skip($reason, @_); |
| 231 | } |
| 232 | |
| 233 | sub BAIL_OUT { |
| 234 | my ($reason) = @_; |
| 235 | _print("Bail out! $reason\n"); |
| 236 | exit 255; |
| 237 | } |
| 238 | |
| 239 | sub _ok { |
| 240 | my ($pass, $where, $name, @mess) = @_; |
| 241 | # Do not try to microoptimize by factoring out the "not ". |
| 242 | # VMS will avenge. |
| 243 | my $out; |
| 244 | if ($name) { |
| 245 | # escape out '#' or it will interfere with '# skip' and such |
| 246 | $name =~ s/#/\\#/g; |
| 247 | $out = $pass ? "ok $test - $name" : "not ok $test - $name"; |
| 248 | } else { |
| 249 | $out = $pass ? "ok $test - [$where]" : "not ok $test - [$where]"; |
| 250 | } |
| 251 | |
| 252 | if ($TODO) { |
| 253 | $out = $out . " # TODO $TODO"; |
| 254 | } else { |
| 255 | $Tests_Are_Passing = 0 unless $pass; |
| 256 | } |
| 257 | |
| 258 | _print "$out\n"; |
| 259 | |
| 260 | if ($pass) { |
| 261 | note @mess; # Ensure that the message is properly escaped. |
| 262 | } |
| 263 | else { |
| 264 | my $msg = "# Failed test $test - "; |
| 265 | $msg.= "$name " if $name; |
| 266 | $msg .= "$where\n"; |
| 267 | _diag $msg; |
| 268 | _diag @mess; |
| 269 | } |
| 270 | |
| 271 | $test = $test + 1; # don't use ++ |
| 272 | |
| 273 | return $pass; |
| 274 | } |
| 275 | |
| 276 | sub _where { |
| 277 | my (undef, $filename, $lineno) = caller($Level); |
| 278 | return "at $filename line $lineno"; |
| 279 | } |
| 280 | |
| 281 | # DON'T use this for matches. Use like() instead. |
| 282 | sub ok ($@) { |
| 283 | my ($pass, $name, @mess) = @_; |
| 284 | _ok($pass, _where(), $name, @mess); |
| 285 | } |
| 286 | |
| 287 | sub _q { |
| 288 | my $x = shift; |
| 289 | return 'undef' unless defined $x; |
| 290 | my $q = $x; |
| 291 | $q =~ s/\\/\\\\/g; |
| 292 | $q =~ s/'/\\'/g; |
| 293 | return "'$q'"; |
| 294 | } |
| 295 | |
| 296 | sub _qq { |
| 297 | my $x = shift; |
| 298 | return defined $x ? '"' . display ($x) . '"' : 'undef'; |
| 299 | }; |
| 300 | |
| 301 | # Support pre-5.10 Perls, for the benefit of CPAN dists that copy this file. |
| 302 | # Note that chr(90) exists in both ASCII ("Z") and EBCDIC ("!"). |
| 303 | my $chars_template = defined(eval { pack "W*", 90 }) ? "W*" : "U*"; |
| 304 | eval 'sub re::is_regexp { ref($_[0]) eq "Regexp" }' |
| 305 | if !defined &re::is_regexp; |
| 306 | |
| 307 | # keys are the codes \n etc map to, values are 2 char strings such as \n |
| 308 | my %backslash_escape; |
| 309 | foreach my $x (split //, 'enrtfa\\\'"') { |
| 310 | $backslash_escape{ord eval "\"\\$x\""} = "\\$x"; |
| 311 | } |
| 312 | # A way to display scalars containing control characters and Unicode. |
| 313 | # Trying to avoid setting $_, or relying on local $_ to work. |
| 314 | sub display { |
| 315 | my @result; |
| 316 | foreach my $x (@_) { |
| 317 | if (defined $x and not ref $x) { |
| 318 | my $y = ''; |
| 319 | foreach my $c (unpack($chars_template, $x)) { |
| 320 | if ($c > 255) { |
| 321 | $y = $y . sprintf "\\x{%x}", $c; |
| 322 | } elsif ($backslash_escape{$c}) { |
| 323 | $y = $y . $backslash_escape{$c}; |
| 324 | } elsif ($c < ord " ") { |
| 325 | # Use octal for characters with small ordinals that are |
| 326 | # traditionally expressed as octal: the controls below |
| 327 | # space, which on EBCDIC are almost all the controls, but |
| 328 | # on ASCII don't include DEL nor the C1 controls. |
| 329 | $y = $y . sprintf "\\%03o", $c; |
| 330 | } elsif (chr $c =~ /[[:print:]]/a) { |
| 331 | $y = $y . chr $c; |
| 332 | } |
| 333 | else { |
| 334 | $y = $y . sprintf "\\x%02X", $c; |
| 335 | } |
| 336 | } |
| 337 | $x = $y; |
| 338 | } |
| 339 | return $x unless wantarray; |
| 340 | push @result, $x; |
| 341 | } |
| 342 | return @result; |
| 343 | } |
| 344 | |
| 345 | sub is ($$@) { |
| 346 | my ($got, $expected, $name, @mess) = @_; |
| 347 | |
| 348 | my $pass; |
| 349 | if( !defined $got || !defined $expected ) { |
| 350 | # undef only matches undef |
| 351 | $pass = !defined $got && !defined $expected; |
| 352 | } |
| 353 | else { |
| 354 | $pass = $got eq $expected; |
| 355 | } |
| 356 | |
| 357 | unless ($pass) { |
| 358 | unshift(@mess, "# got "._qq($got)."\n", |
| 359 | "# expected "._qq($expected)."\n"); |
| 360 | if (defined $got and defined $expected and |
| 361 | (length($got)>20 or length($expected)>20)) |
| 362 | { |
| 363 | my $p = 0; |
| 364 | $p++ while substr($got,$p,1) eq substr($expected,$p,1); |
| 365 | push @mess,"# diff at $p\n"; |
| 366 | push @mess,"# after "._qq(substr($got,$p < 40 ? 0 : $p - 40, |
| 367 | $p < 40 ? $p : 40)) . "\n"; |
| 368 | push @mess,"# have "._qq(substr($got,$p,40))."\n"; |
| 369 | push @mess,"# want "._qq(substr($expected,$p,40))."\n"; |
| 370 | } |
| 371 | } |
| 372 | _ok($pass, _where(), $name, @mess); |
| 373 | } |
| 374 | |
| 375 | sub isnt ($$@) { |
| 376 | my ($got, $isnt, $name, @mess) = @_; |
| 377 | |
| 378 | my $pass; |
| 379 | if( !defined $got || !defined $isnt ) { |
| 380 | # undef only matches undef |
| 381 | $pass = defined $got || defined $isnt; |
| 382 | } |
| 383 | else { |
| 384 | $pass = $got ne $isnt; |
| 385 | } |
| 386 | |
| 387 | unless( $pass ) { |
| 388 | unshift(@mess, "# it should not be "._qq($got)."\n", |
| 389 | "# but it is.\n"); |
| 390 | } |
| 391 | _ok($pass, _where(), $name, @mess); |
| 392 | } |
| 393 | |
| 394 | sub cmp_ok ($$$@) { |
| 395 | my($got, $type, $expected, $name, @mess) = @_; |
| 396 | |
| 397 | my $pass; |
| 398 | { |
| 399 | local $^W = 0; |
| 400 | local($@,$!); # don't interfere with $@ |
| 401 | # eval() sometimes resets $! |
| 402 | $pass = eval "\$got $type \$expected"; |
| 403 | } |
| 404 | unless ($pass) { |
| 405 | # It seems Irix long doubles can have 2147483648 and 2147483648 |
| 406 | # that stringify to the same thing but are actually numerically |
| 407 | # different. Display the numbers if $type isn't a string operator, |
| 408 | # and the numbers are stringwise the same. |
| 409 | # (all string operators have alphabetic names, so tr/a-z// is true) |
| 410 | # This will also show numbers for some unneeded cases, but will |
| 411 | # definitely be helpful for things such as == and <= that fail |
| 412 | if ($got eq $expected and $type !~ tr/a-z//) { |
| 413 | unshift @mess, "# $got - $expected = " . ($got - $expected) . "\n"; |
| 414 | } |
| 415 | unshift(@mess, "# got "._qq($got)."\n", |
| 416 | "# expected $type "._qq($expected)."\n"); |
| 417 | } |
| 418 | _ok($pass, _where(), $name, @mess); |
| 419 | } |
| 420 | |
| 421 | # Check that $got is within $range of $expected |
| 422 | # if $range is 0, then check it's exact |
| 423 | # else if $expected is 0, then $range is an absolute value |
| 424 | # otherwise $range is a fractional error. |
| 425 | # Here $range must be numeric, >= 0 |
| 426 | # Non numeric ranges might be a useful future extension. (eg %) |
| 427 | sub within ($$$@) { |
| 428 | my ($got, $expected, $range, $name, @mess) = @_; |
| 429 | my $pass; |
| 430 | if (!defined $got or !defined $expected or !defined $range) { |
| 431 | # This is a fail, but doesn't need extra diagnostics |
| 432 | } elsif ($got !~ tr/0-9// or $expected !~ tr/0-9// or $range !~ tr/0-9//) { |
| 433 | # This is a fail |
| 434 | unshift @mess, "# got, expected and range must be numeric\n"; |
| 435 | } elsif ($range < 0) { |
| 436 | # This is also a fail |
| 437 | unshift @mess, "# range must not be negative\n"; |
| 438 | } elsif ($range == 0) { |
| 439 | # Within 0 is == |
| 440 | $pass = $got == $expected; |
| 441 | } elsif ($expected == 0) { |
| 442 | # If expected is 0, treat range as absolute |
| 443 | $pass = ($got <= $range) && ($got >= - $range); |
| 444 | } else { |
| 445 | my $diff = $got - $expected; |
| 446 | $pass = abs ($diff / $expected) < $range; |
| 447 | } |
| 448 | unless ($pass) { |
| 449 | if ($got eq $expected) { |
| 450 | unshift @mess, "# $got - $expected = " . ($got - $expected) . "\n"; |
| 451 | } |
| 452 | unshift@mess, "# got "._qq($got)."\n", |
| 453 | "# expected "._qq($expected)." (within "._qq($range).")\n"; |
| 454 | } |
| 455 | _ok($pass, _where(), $name, @mess); |
| 456 | } |
| 457 | |
| 458 | # Note: this isn't quite as fancy as Test::More::like(). |
| 459 | |
| 460 | sub like ($$@) { like_yn (0,@_) }; # 0 for - |
| 461 | sub unlike ($$@) { like_yn (1,@_) }; # 1 for un- |
| 462 | |
| 463 | sub like_yn ($$$@) { |
| 464 | my ($flip, undef, $expected, $name, @mess) = @_; |
| 465 | |
| 466 | # We just accept like(..., qr/.../), not like(..., '...'), and |
| 467 | # definitely not like(..., '/.../') like |
| 468 | # Test::Builder::maybe_regex() does. |
| 469 | unless (re::is_regexp($expected)) { |
| 470 | die "PANIC: The value '$expected' isn't a regexp. The like() function needs a qr// pattern, not a string"; |
| 471 | } |
| 472 | |
| 473 | my $pass = ($flip) ? $_[1] !~ /$expected/ : $_[1] =~ /$expected/; |
| 474 | unless ($pass) { |
| 475 | my $display_got = display($_[1]); |
| 476 | my $display_expected = display($expected); |
| 477 | unshift(@mess, "# got '$display_got'\n", |
| 478 | $flip |
| 479 | ? "# expected !~ /$display_expected/\n" |
| 480 | : "# expected /$display_expected/\n"); |
| 481 | } |
| 482 | local $Level = $Level + 1; |
| 483 | _ok($pass, _where(), $name, @mess); |
| 484 | } |
| 485 | |
| 486 | sub refcount_is { |
| 487 | # Don't unpack first arg; access it directly via $_[0] to avoid creating |
| 488 | # another reference and upsetting the refcount |
| 489 | my (undef, $expected, $name, @mess) = @_; |
| 490 | my $got = &Internals::SvREFCNT($_[0]) + 1; # +1 to account for the & calling style |
| 491 | my $pass = $got == $expected; |
| 492 | unless ($pass) { |
| 493 | unshift @mess, "# got $got references\n" . |
| 494 | "# expected $expected\n"; |
| 495 | } |
| 496 | _ok($pass, _where(), $name, @mess); |
| 497 | } |
| 498 | |
| 499 | sub pass { |
| 500 | _ok(1, '', @_); |
| 501 | } |
| 502 | |
| 503 | sub fail { |
| 504 | _ok(0, _where(), @_); |
| 505 | } |
| 506 | |
| 507 | sub curr_test { |
| 508 | $test = shift if @_; |
| 509 | return $test; |
| 510 | } |
| 511 | |
| 512 | sub next_test { |
| 513 | my $retval = $test; |
| 514 | $test = $test + 1; # don't use ++ |
| 515 | $retval; |
| 516 | } |
| 517 | |
| 518 | # Note: can't pass multipart messages since we try to |
| 519 | # be compatible with Test::More::skip(). |
| 520 | sub skip { |
| 521 | my $why = shift; |
| 522 | my $n = @_ ? shift : 1; |
| 523 | my $bad_swap; |
| 524 | my $both_zero; |
| 525 | { |
| 526 | local $^W = 0; |
| 527 | $bad_swap = $why > 0 && $n == 0; |
| 528 | $both_zero = $why == 0 && $n == 0; |
| 529 | } |
| 530 | if ($bad_swap || $both_zero || @_) { |
| 531 | my $arg = "'$why', '$n'"; |
| 532 | if (@_) { |
| 533 | $arg .= join(", ", '', map { qq['$_'] } @_); |
| 534 | } |
| 535 | die qq[$0: expected skip(why, count), got skip($arg)\n]; |
| 536 | } |
| 537 | for (1..$n) { |
| 538 | _print "ok $test # skip $why\n"; |
| 539 | $test = $test + 1; |
| 540 | } |
| 541 | local $^W = 0; |
| 542 | last SKIP; |
| 543 | } |
| 544 | |
| 545 | sub skip_if_miniperl { |
| 546 | skip(@_) if is_miniperl(); |
| 547 | } |
| 548 | |
| 549 | sub skip_without_dynamic_extension { |
| 550 | my $extension = shift; |
| 551 | skip("no dynamic loading on miniperl, no extension $extension", @_) |
| 552 | if is_miniperl(); |
| 553 | return if &_have_dynamic_extension($extension); |
| 554 | skip("extension $extension was not built", @_); |
| 555 | } |
| 556 | |
| 557 | sub todo_skip { |
| 558 | my $why = shift; |
| 559 | my $n = @_ ? shift : 1; |
| 560 | |
| 561 | for (1..$n) { |
| 562 | _print "not ok $test # TODO & SKIP $why\n"; |
| 563 | $test = $test + 1; |
| 564 | } |
| 565 | local $^W = 0; |
| 566 | last TODO; |
| 567 | } |
| 568 | |
| 569 | sub eq_array { |
| 570 | my ($ra, $rb) = @_; |
| 571 | return 0 unless $#$ra == $#$rb; |
| 572 | for my $i (0..$#$ra) { |
| 573 | next if !defined $ra->[$i] && !defined $rb->[$i]; |
| 574 | return 0 if !defined $ra->[$i]; |
| 575 | return 0 if !defined $rb->[$i]; |
| 576 | return 0 unless $ra->[$i] eq $rb->[$i]; |
| 577 | } |
| 578 | return 1; |
| 579 | } |
| 580 | |
| 581 | sub eq_hash { |
| 582 | my ($orig, $suspect) = @_; |
| 583 | my $fail; |
| 584 | while (my ($key, $value) = each %$suspect) { |
| 585 | # Force a hash recompute if this perl's internals can cache the hash key. |
| 586 | $key = "" . $key; |
| 587 | if (exists $orig->{$key}) { |
| 588 | if ( |
| 589 | defined $orig->{$key} != defined $value |
| 590 | || (defined $value && $orig->{$key} ne $value) |
| 591 | ) { |
| 592 | _print "# key ", _qq($key), " was ", _qq($orig->{$key}), |
| 593 | " now ", _qq($value), "\n"; |
| 594 | $fail = 1; |
| 595 | } |
| 596 | } else { |
| 597 | _print "# key ", _qq($key), " is ", _qq($value), |
| 598 | ", not in original.\n"; |
| 599 | $fail = 1; |
| 600 | } |
| 601 | } |
| 602 | foreach (keys %$orig) { |
| 603 | # Force a hash recompute if this perl's internals can cache the hash key. |
| 604 | $_ = "" . $_; |
| 605 | next if (exists $suspect->{$_}); |
| 606 | _print "# key ", _qq($_), " was ", _qq($orig->{$_}), " now missing.\n"; |
| 607 | $fail = 1; |
| 608 | } |
| 609 | !$fail; |
| 610 | } |
| 611 | |
| 612 | # We only provide a subset of the Test::More functionality. |
| 613 | sub require_ok ($) { |
| 614 | my ($require) = @_; |
| 615 | if ($require =~ tr/[A-Za-z0-9:.]//c) { |
| 616 | fail("Invalid character in \"$require\", passed to require_ok"); |
| 617 | } else { |
| 618 | eval <<REQUIRE_OK; |
| 619 | require $require; |
| 620 | REQUIRE_OK |
| 621 | is($@, '', _where(), "require $require"); |
| 622 | } |
| 623 | } |
| 624 | |
| 625 | sub use_ok ($) { |
| 626 | my ($use) = @_; |
| 627 | if ($use =~ tr/[A-Za-z0-9:.]//c) { |
| 628 | fail("Invalid character in \"$use\", passed to use"); |
| 629 | } else { |
| 630 | eval <<USE_OK; |
| 631 | use $use; |
| 632 | USE_OK |
| 633 | is($@, '', _where(), "use $use"); |
| 634 | } |
| 635 | } |
| 636 | |
| 637 | # runperl, run_perl - Runs a separate perl interpreter and returns its output. |
| 638 | # Arguments : |
| 639 | # switches => [ command-line switches ] |
| 640 | # nolib => 1 # don't use -I../lib (included by default) |
| 641 | # non_portable => Don't warn if a one liner contains quotes |
| 642 | # prog => one-liner (avoid quotes) |
| 643 | # progs => [ multi-liner (avoid quotes) ] |
| 644 | # progfile => perl script |
| 645 | # stdin => string to feed the stdin (or undef to redirect from /dev/null) |
| 646 | # stderr => If 'devnull' suppresses stderr, if other TRUE value redirect |
| 647 | # stderr to stdout |
| 648 | # args => [ command-line arguments to the perl program ] |
| 649 | # verbose => print the command line |
| 650 | |
| 651 | my $is_mswin = $^O eq 'MSWin32'; |
| 652 | my $is_vms = $^O eq 'VMS'; |
| 653 | my $is_cygwin = $^O eq 'cygwin'; |
| 654 | |
| 655 | sub _quote_args { |
| 656 | my ($runperl, $args) = @_; |
| 657 | |
| 658 | foreach (@$args) { |
| 659 | # In VMS protect with doublequotes because otherwise |
| 660 | # DCL will lowercase -- unless already doublequoted. |
| 661 | $_ = q(").$_.q(") if $is_vms && !/^\"/ && length($_) > 0; |
| 662 | $runperl = $runperl . ' ' . $_; |
| 663 | } |
| 664 | return $runperl; |
| 665 | } |
| 666 | |
| 667 | sub _create_runperl { # Create the string to qx in runperl(). |
| 668 | my %args = @_; |
| 669 | my $runperl = which_perl(); |
| 670 | if ($runperl =~ m/\s/) { |
| 671 | $runperl = qq{"$runperl"}; |
| 672 | } |
| 673 | #- this allows, for example, to set PERL_RUNPERL_DEBUG=/usr/bin/valgrind |
| 674 | if ($ENV{PERL_RUNPERL_DEBUG}) { |
| 675 | $runperl = "$ENV{PERL_RUNPERL_DEBUG} $runperl"; |
| 676 | } |
| 677 | unless ($args{nolib}) { |
| 678 | $runperl = $runperl . ' "-I../lib" "-I." '; # doublequotes because of VMS |
| 679 | } |
| 680 | if ($args{switches}) { |
| 681 | local $Level = 2; |
| 682 | die "test.pl:runperl(): 'switches' must be an ARRAYREF " . _where() |
| 683 | unless ref $args{switches} eq "ARRAY"; |
| 684 | $runperl = _quote_args($runperl, $args{switches}); |
| 685 | } |
| 686 | if (defined $args{prog}) { |
| 687 | die "test.pl:runperl(): both 'prog' and 'progs' cannot be used " . _where() |
| 688 | if defined $args{progs}; |
| 689 | $args{progs} = [split /\n/, $args{prog}, -1] |
| 690 | } |
| 691 | if (defined $args{progs}) { |
| 692 | die "test.pl:runperl(): 'progs' must be an ARRAYREF " . _where() |
| 693 | unless ref $args{progs} eq "ARRAY"; |
| 694 | foreach my $prog (@{$args{progs}}) { |
| 695 | if (!$args{non_portable}) { |
| 696 | if ($prog =~ tr/'"//) { |
| 697 | warn "quotes in prog >>$prog<< are not portable"; |
| 698 | } |
| 699 | if ($prog =~ /^([<>|]|2>)/) { |
| 700 | warn "Initial $1 in prog >>$prog<< is not portable"; |
| 701 | } |
| 702 | if ($prog =~ /&\z/) { |
| 703 | warn "Trailing & in prog >>$prog<< is not portable"; |
| 704 | } |
| 705 | } |
| 706 | if ($is_mswin || $is_vms) { |
| 707 | $runperl = $runperl . qq ( -e "$prog" ); |
| 708 | } |
| 709 | else { |
| 710 | $runperl = $runperl . qq ( -e '$prog' ); |
| 711 | } |
| 712 | } |
| 713 | } elsif (defined $args{progfile}) { |
| 714 | $runperl = $runperl . qq( "$args{progfile}"); |
| 715 | } else { |
| 716 | # You probably didn't want to be sucking in from the upstream stdin |
| 717 | die "test.pl:runperl(): none of prog, progs, progfile, args, " |
| 718 | . " switches or stdin specified" |
| 719 | unless defined $args{args} or defined $args{switches} |
| 720 | or defined $args{stdin}; |
| 721 | } |
| 722 | if (defined $args{stdin}) { |
| 723 | # so we don't try to put literal newlines and crs onto the |
| 724 | # command line. |
| 725 | $args{stdin} =~ s/\n/\\n/g; |
| 726 | $args{stdin} =~ s/\r/\\r/g; |
| 727 | |
| 728 | if ($is_mswin || $is_vms) { |
| 729 | $runperl = qq{$Perl -e "print qq(} . |
| 730 | $args{stdin} . q{)" | } . $runperl; |
| 731 | } |
| 732 | else { |
| 733 | $runperl = qq{$Perl -e 'print qq(} . |
| 734 | $args{stdin} . q{)' | } . $runperl; |
| 735 | } |
| 736 | } elsif (exists $args{stdin}) { |
| 737 | # Using the pipe construction above can cause fun on systems which use |
| 738 | # ksh as /bin/sh, as ksh does pipes differently (with one less process) |
| 739 | # With sh, for the command line 'perl -e 'print qq()' | perl -e ...' |
| 740 | # the sh process forks two children, which use exec to start the two |
| 741 | # perl processes. The parent shell process persists for the duration of |
| 742 | # the pipeline, and the second perl process starts with no children. |
| 743 | # With ksh (and zsh), the shell saves a process by forking a child for |
| 744 | # just the first perl process, and execing itself to start the second. |
| 745 | # This means that the second perl process starts with one child which |
| 746 | # it didn't create. This causes "fun" when if the tests assume that |
| 747 | # wait (or waitpid) will only return information about processes |
| 748 | # started within the test. |
| 749 | # They also cause fun on VMS, where the pipe implementation returns |
| 750 | # the exit code of the process at the front of the pipeline, not the |
| 751 | # end. This messes up any test using OPTION FATAL. |
| 752 | # Hence it's useful to have a way to make STDIN be at eof without |
| 753 | # needing a pipeline, so that the fork tests have a sane environment |
| 754 | # without these surprises. |
| 755 | |
| 756 | # /dev/null appears to be surprisingly portable. |
| 757 | $runperl = $runperl . ($is_mswin ? ' <nul' : ' </dev/null'); |
| 758 | } |
| 759 | if (defined $args{args}) { |
| 760 | $runperl = _quote_args($runperl, $args{args}); |
| 761 | } |
| 762 | if (exists $args{stderr} && $args{stderr} eq 'devnull') { |
| 763 | $runperl = $runperl . ($is_mswin ? ' 2>nul' : ' 2>/dev/null'); |
| 764 | } |
| 765 | elsif ($args{stderr}) { |
| 766 | $runperl = $runperl . ' 2>&1'; |
| 767 | } |
| 768 | if ($args{verbose}) { |
| 769 | my $runperldisplay = $runperl; |
| 770 | $runperldisplay =~ s/\n/\n\#/g; |
| 771 | _print_stderr "# $runperldisplay\n"; |
| 772 | } |
| 773 | return $runperl; |
| 774 | } |
| 775 | |
| 776 | # usage: |
| 777 | # $ENV{PATH} =~ /(.*)/s; |
| 778 | # local $ENV{PATH} = untaint_path($1); |
| 779 | sub untaint_path { |
| 780 | my $path = shift; |
| 781 | my $sep; |
| 782 | |
| 783 | if (! eval {require Config; 1}) { |
| 784 | warn "test.pl had problems loading Config: $@"; |
| 785 | $sep = ':'; |
| 786 | } else { |
| 787 | $sep = $Config::Config{path_sep}; |
| 788 | } |
| 789 | |
| 790 | $path = |
| 791 | join $sep, grep { $_ ne "" and $_ ne "." and -d $_ and |
| 792 | ($is_mswin or $is_vms or !(stat && (stat _)[2]&0022)) } |
| 793 | split quotemeta ($sep), $1; |
| 794 | if ($is_cygwin) { # Must have /bin under Cygwin |
| 795 | if (length $path) { |
| 796 | $path = $path . $sep; |
| 797 | } |
| 798 | $path = $path . '/bin'; |
| 799 | } elsif (!$is_vms and !length $path) { |
| 800 | # empty PATH is the same as a path of "." on *nix so to prevent |
| 801 | # tests from dieing under taint we need to return something |
| 802 | # absolute. Perhaps "/" would be better? Anything absolute will do. |
| 803 | $path = "/usr/bin"; |
| 804 | } |
| 805 | |
| 806 | $path; |
| 807 | } |
| 808 | |
| 809 | # sub run_perl {} is alias to below |
| 810 | # Since this uses backticks to run, it is subject to the rules of the shell. |
| 811 | # Locale settings may pose a problem, depending on the program being run. |
| 812 | sub runperl { |
| 813 | die "test.pl:runperl() does not take a hashref" |
| 814 | if ref $_[0] and ref $_[0] eq 'HASH'; |
| 815 | my $runperl = &_create_runperl; |
| 816 | my $result; |
| 817 | |
| 818 | my $tainted = ${^TAINT}; |
| 819 | my %args = @_; |
| 820 | exists $args{switches} && grep m/^-T$/, @{$args{switches}} and $tainted = $tainted + 1; |
| 821 | |
| 822 | if ($tainted) { |
| 823 | # We will assume that if you're running under -T, you really mean to |
| 824 | # run a fresh perl, so we'll brute force launder everything for you |
| 825 | my @keys = grep {exists $ENV{$_}} qw(CDPATH IFS ENV BASH_ENV); |
| 826 | local @ENV{@keys} = (); |
| 827 | # Untaint, plus take out . and empty string: |
| 828 | local $ENV{'DCL$PATH'} = $1 if $is_vms && exists($ENV{'DCL$PATH'}) && ($ENV{'DCL$PATH'} =~ /(.*)/s); |
| 829 | $ENV{PATH} =~ /(.*)/s; |
| 830 | local $ENV{PATH} = untaint_path($1); |
| 831 | $runperl =~ /(.*)/s; |
| 832 | $runperl = $1; |
| 833 | |
| 834 | $result = `$runperl`; |
| 835 | } else { |
| 836 | $result = `$runperl`; |
| 837 | } |
| 838 | $result =~ s/\n\n/\n/g if $is_vms; # XXX pipes sometimes double these |
| 839 | return $result; |
| 840 | } |
| 841 | |
| 842 | # Nice alias |
| 843 | *run_perl = *run_perl = \&runperl; # shut up "used only once" warning |
| 844 | |
| 845 | # Run perl with specified environment and arguments, return (STDOUT, STDERR) |
| 846 | # set DEBUG_RUNENV=1 in the environment to debug. |
| 847 | sub runperl_and_capture { |
| 848 | my ($env, $args) = @_; |
| 849 | |
| 850 | my $STDOUT = tempfile(); |
| 851 | my $STDERR = tempfile(); |
| 852 | my $PERL = $^X; |
| 853 | my $FAILURE_CODE = 119; |
| 854 | |
| 855 | local %ENV = %ENV; |
| 856 | delete $ENV{PERLLIB}; |
| 857 | delete $ENV{PERL5LIB}; |
| 858 | delete $ENV{PERL5OPT}; |
| 859 | delete $ENV{PERL_USE_UNSAFE_INC}; |
| 860 | my $pid = fork; |
| 861 | return (0, "Couldn't fork: $!") unless defined $pid; # failure |
| 862 | if ($pid) { # parent |
| 863 | waitpid $pid,0; |
| 864 | my $exit_code = $? ? $? >> 8 : 0; |
| 865 | my ($out, $err)= ("", ""); |
| 866 | local $/; |
| 867 | if (open my $stdout, '<', $STDOUT) { |
| 868 | $out .= <$stdout>; |
| 869 | } else { |
| 870 | $err .= "Could not read STDOUT '$STDOUT' file: $!\n"; |
| 871 | } |
| 872 | if (open my $stderr, '<', $STDERR) { |
| 873 | $err .= <$stderr>; |
| 874 | } else { |
| 875 | $err .= "Could not read STDERR '$STDERR' file: $!\n"; |
| 876 | } |
| 877 | if ($exit_code == $FAILURE_CODE) { |
| 878 | $err .= "Something went wrong. Received FAILURE_CODE as exit code.\n"; |
| 879 | } |
| 880 | if ($ENV{DEBUG_RUNENV}) { |
| 881 | print "OUT: $out\n"; |
| 882 | print "ERR: $err\n"; |
| 883 | } |
| 884 | return ($out, $err); |
| 885 | } elsif (defined $pid) { # child |
| 886 | # Just in case the order we update the environment changes how |
| 887 | # the environment is set up we sort the keys here for consistency. |
| 888 | for my $k (sort keys %$env) { |
| 889 | $ENV{$k} = $env->{$k}; |
| 890 | } |
| 891 | if ($ENV{DEBUG_RUNENV}) { |
| 892 | print "Child Process $$ Executing:\n$PERL @$args\n"; |
| 893 | } |
| 894 | open STDOUT, '>', $STDOUT |
| 895 | or do { |
| 896 | print "Failed to dup STDOUT to '$STDOUT': $!"; |
| 897 | exit $FAILURE_CODE; |
| 898 | }; |
| 899 | open STDERR, '>', $STDERR |
| 900 | or do { |
| 901 | print "Failed to dup STDERR to '$STDERR': $!"; |
| 902 | exit $FAILURE_CODE; |
| 903 | }; |
| 904 | exec $PERL, @$args |
| 905 | or print STDERR "Failed to exec: ", |
| 906 | join(" ",map { "'$_'" } $^X, @$args), |
| 907 | ": $!\n"; |
| 908 | exit $FAILURE_CODE; |
| 909 | } |
| 910 | } |
| 911 | |
| 912 | sub DIE { |
| 913 | _print_stderr "# @_\n"; |
| 914 | exit 1; |
| 915 | } |
| 916 | |
| 917 | # A somewhat safer version of the sometimes wrong $^X. |
| 918 | sub which_perl { |
| 919 | unless (defined $Perl) { |
| 920 | $Perl = $^X; |
| 921 | |
| 922 | # VMS should have 'perl' aliased properly |
| 923 | return $Perl if $is_vms; |
| 924 | |
| 925 | my $exe; |
| 926 | if (! eval {require Config; 1}) { |
| 927 | warn "test.pl had problems loading Config: $@"; |
| 928 | $exe = ''; |
| 929 | } else { |
| 930 | $exe = $Config::Config{_exe}; |
| 931 | } |
| 932 | $exe = '' unless defined $exe; |
| 933 | |
| 934 | # This doesn't absolutize the path: beware of future chdirs(). |
| 935 | # We could do File::Spec->abs2rel() but that does getcwd()s, |
| 936 | # which is a bit heavyweight to do here. |
| 937 | |
| 938 | if ($Perl =~ /^perl\Q$exe\E$/i) { |
| 939 | my $perl = "perl$exe"; |
| 940 | if (! eval {require File::Spec; 1}) { |
| 941 | warn "test.pl had problems loading File::Spec: $@"; |
| 942 | $Perl = "./$perl"; |
| 943 | } else { |
| 944 | $Perl = File::Spec->catfile(File::Spec->curdir(), $perl); |
| 945 | } |
| 946 | } |
| 947 | |
| 948 | # Build up the name of the executable file from the name of |
| 949 | # the command. |
| 950 | |
| 951 | if ($Perl !~ /\Q$exe\E$/i) { |
| 952 | $Perl = $Perl . $exe; |
| 953 | } |
| 954 | |
| 955 | warn "which_perl: cannot find $Perl from $^X" unless -f $Perl; |
| 956 | |
| 957 | # For subcommands to use. |
| 958 | $ENV{PERLEXE} = $Perl; |
| 959 | } |
| 960 | return $Perl; |
| 961 | } |
| 962 | |
| 963 | sub unlink_all { |
| 964 | my $count = 0; |
| 965 | foreach my $file (@_) { |
| 966 | 1 while unlink $file; |
| 967 | if( -f $file ){ |
| 968 | _print_stderr "# Couldn't unlink '$file': $!\n"; |
| 969 | }else{ |
| 970 | $count = $count + 1; # don't use ++ |
| 971 | } |
| 972 | } |
| 973 | $count; |
| 974 | } |
| 975 | |
| 976 | # _num_to_alpha - Returns a string of letters representing a positive integer. |
| 977 | # Arguments : |
| 978 | # number to convert |
| 979 | # maximum number of letters |
| 980 | |
| 981 | # returns undef if the number is negative |
| 982 | # returns undef if the number of letters is greater than the maximum wanted |
| 983 | |
| 984 | # _num_to_alpha( 0) eq 'A'; |
| 985 | # _num_to_alpha( 1) eq 'B'; |
| 986 | # _num_to_alpha(25) eq 'Z'; |
| 987 | # _num_to_alpha(26) eq 'AA'; |
| 988 | # _num_to_alpha(27) eq 'AB'; |
| 989 | |
| 990 | my @letters = qw(A B C D E F G H I J K L M N O P Q R S T U V W X Y Z); |
| 991 | |
| 992 | # Avoid ++ -- ranges split negative numbers |
| 993 | sub _num_to_alpha { |
| 994 | my($num,$max_char) = @_; |
| 995 | return unless $num >= 0; |
| 996 | my $alpha = ''; |
| 997 | my $char_count = 0; |
| 998 | $max_char = 0 if !defined($max_char) or $max_char < 0; |
| 999 | |
| 1000 | while( 1 ){ |
| 1001 | $alpha = $letters[ $num % @letters ] . $alpha; |
| 1002 | $num = int( $num / @letters ); |
| 1003 | last if $num == 0; |
| 1004 | $num = $num - 1; |
| 1005 | |
| 1006 | # char limit |
| 1007 | next unless $max_char; |
| 1008 | $char_count = $char_count + 1; |
| 1009 | return if $char_count == $max_char; |
| 1010 | } |
| 1011 | return $alpha; |
| 1012 | } |
| 1013 | |
| 1014 | my %tmpfiles; |
| 1015 | sub unlink_tempfiles { |
| 1016 | unlink_all keys %tmpfiles; |
| 1017 | %tmpfiles = (); |
| 1018 | } |
| 1019 | |
| 1020 | END { unlink_tempfiles(); } |
| 1021 | |
| 1022 | |
| 1023 | # NOTE: tempfile() may be used as a module names in our tests |
| 1024 | # so the result must be restricted to only legal characters for a module |
| 1025 | # name. |
| 1026 | |
| 1027 | # A regexp that matches the tempfile names |
| 1028 | $::tempfile_regexp = 'tmp_[A-Z]+_[A-Z]+'; |
| 1029 | |
| 1030 | # Avoid ++, avoid ranges, avoid split // |
| 1031 | my $tempfile_count = 0; |
| 1032 | my $max_file_chars = 3; |
| 1033 | # Note that the max number of is NOT 26**3, it is 26**3 + 26**2 + 26, |
| 1034 | # as 3 character files are distinct from 2 character files, from 1 characters |
| 1035 | # files, etc. |
| 1036 | sub tempfile { |
| 1037 | # if you change the format returned by tempfile() you MUST change |
| 1038 | # the $::tempfile_regex define above. |
| 1039 | my $try_prefix = (-d "t" ? "t/" : "")."tmp_"._num_to_alpha($$); |
| 1040 | while (1) { |
| 1041 | my $alpha = _num_to_alpha($tempfile_count,$max_file_chars); |
| 1042 | last unless defined $alpha; |
| 1043 | my $try = $try_prefix . "_" . $alpha; |
| 1044 | $tempfile_count = $tempfile_count + 1; |
| 1045 | |
| 1046 | # Need to note all the file names we allocated, as a second request |
| 1047 | # may come before the first is created. Also we are avoiding ++ here |
| 1048 | # so we aren't using the normal idiom for this kind of test. |
| 1049 | if (!$tmpfiles{$try} && !-e $try) { |
| 1050 | # We have a winner |
| 1051 | $tmpfiles{$try} = 1; |
| 1052 | return $try; |
| 1053 | } |
| 1054 | } |
| 1055 | die sprintf |
| 1056 | 'panic: Too many tempfile()s with prefix "%s", limit of %d reached', |
| 1057 | $try_prefix, 26 ** $max_file_chars; |
| 1058 | } |
| 1059 | |
| 1060 | # register_tempfile - Adds a list of files to be removed at the end of the current test file |
| 1061 | # Arguments : |
| 1062 | # a list of files to be removed later |
| 1063 | |
| 1064 | # returns a count of how many file names were actually added |
| 1065 | |
| 1066 | # Reuses %tmpfiles so that tempfile() will also skip any files added here |
| 1067 | # even if the file doesn't exist yet. |
| 1068 | |
| 1069 | sub register_tempfile { |
| 1070 | my $count = 0; |
| 1071 | for( @_ ){ |
| 1072 | if( $tmpfiles{$_} ){ |
| 1073 | _print_stderr "# Temporary file '$_' already added\n"; |
| 1074 | }else{ |
| 1075 | $tmpfiles{$_} = 1; |
| 1076 | $count = $count + 1; |
| 1077 | } |
| 1078 | } |
| 1079 | return $count; |
| 1080 | } |
| 1081 | |
| 1082 | # This is the temporary file for fresh_perl |
| 1083 | my $tmpfile = tempfile(); |
| 1084 | |
| 1085 | sub fresh_perl { |
| 1086 | my($prog, $runperl_args) = @_; |
| 1087 | |
| 1088 | # Run 'runperl' with the complete perl program contained in '$prog', and |
| 1089 | # arguments in the hash referred to by '$runperl_args'. The results are |
| 1090 | # returned, with $? set to the exit code. Unless overridden, stderr is |
| 1091 | # redirected to stdout. |
| 1092 | # |
| 1093 | # Placing the program in a file bypasses various sh vagaries |
| 1094 | |
| 1095 | die sprintf "Second argument to fresh_perl_.* must be hashref of args to fresh_perl (or {})" |
| 1096 | unless !(defined $runperl_args) || ref($runperl_args) eq 'HASH'; |
| 1097 | |
| 1098 | # Given the choice of the mis-parsable {} |
| 1099 | # (we want an anon hash, but a borked lexer might think that it's a block) |
| 1100 | # or relying on taking a reference to a lexical |
| 1101 | # (\ might be mis-parsed, and the reference counting on the pad may go |
| 1102 | # awry) |
| 1103 | # it feels like the least-worse thing is to assume that auto-vivification |
| 1104 | # works. At least, this is only going to be a run-time failure, so won't |
| 1105 | # affect tests using this file but not this function. |
| 1106 | my $trim= delete $runperl_args->{rtrim_result}; # hide from runperl |
| 1107 | $runperl_args->{progfile} ||= $tmpfile; |
| 1108 | $runperl_args->{stderr} = 1 unless exists $runperl_args->{stderr}; |
| 1109 | |
| 1110 | open TEST, '>', $tmpfile or die "Cannot open $tmpfile: $!"; |
| 1111 | binmode TEST, ':utf8' if $runperl_args->{wide_chars}; |
| 1112 | print TEST $prog; |
| 1113 | close TEST or die "Cannot close $tmpfile: $!"; |
| 1114 | |
| 1115 | my $results = runperl(%$runperl_args); |
| 1116 | my $status = $?; # Not necessary to save this, but it makes it clear to |
| 1117 | # future maintainers. |
| 1118 | $results=~s/[ \t]+\n/\n/g if $trim; |
| 1119 | # Clean up the results into something a bit more predictable. |
| 1120 | $results =~ s/\n+$//; |
| 1121 | $results =~ s/at\s+$::tempfile_regexp\s+line/at - line/g; |
| 1122 | $results =~ s/of\s+$::tempfile_regexp\s+aborted/of - aborted/g; |
| 1123 | |
| 1124 | # bison says 'parse error' instead of 'syntax error', |
| 1125 | # various yaccs may or may not capitalize 'syntax'. |
| 1126 | $results =~ s/^(syntax|parse) error/syntax error/mig; |
| 1127 | |
| 1128 | if ($is_vms) { |
| 1129 | # some tests will trigger VMS messages that won't be expected |
| 1130 | $results =~ s/\n?%[A-Z]+-[SIWEF]-[A-Z]+,.*//; |
| 1131 | |
| 1132 | # pipes double these sometimes |
| 1133 | $results =~ s/\n\n/\n/g; |
| 1134 | } |
| 1135 | |
| 1136 | $? = $status; |
| 1137 | return $results; |
| 1138 | } |
| 1139 | |
| 1140 | |
| 1141 | sub _fresh_perl { |
| 1142 | my($prog, $action, $expect, $runperl_args, $name) = @_; |
| 1143 | |
| 1144 | local $Level = $Level + 1; |
| 1145 | |
| 1146 | # strip trailing whitespace if requested - makes some tests easier |
| 1147 | $expect=~s/[[:blank:]]+\n/\n/g if $runperl_args->{rtrim_result}; |
| 1148 | |
| 1149 | my $results = fresh_perl($prog, $runperl_args); |
| 1150 | my $status = $?; |
| 1151 | |
| 1152 | # Use the first line of the program as a name if none was given |
| 1153 | unless( $name ) { |
| 1154 | (my $first_line, $name) = $prog =~ /^((.{1,50}).*)/; |
| 1155 | $name = $name . '...' if length $first_line > length $name; |
| 1156 | } |
| 1157 | |
| 1158 | # Historically this was implemented using a closure, but then that means |
| 1159 | # that the tests for closures avoid using this code. Given that there |
| 1160 | # are exactly two callers, doing exactly two things, the simpler approach |
| 1161 | # feels like a better trade off. |
| 1162 | my $pass; |
| 1163 | if ($action eq 'eq') { |
| 1164 | $pass = is($results, $expect, $name); |
| 1165 | } elsif ($action eq '=~') { |
| 1166 | $pass = like($results, $expect, $name); |
| 1167 | } else { |
| 1168 | die "_fresh_perl can't process action '$action'"; |
| 1169 | } |
| 1170 | |
| 1171 | unless ($pass) { |
| 1172 | _diag "# PROG: \n$prog\n"; |
| 1173 | _diag "# STATUS: $status\n"; |
| 1174 | } |
| 1175 | |
| 1176 | return $pass; |
| 1177 | } |
| 1178 | |
| 1179 | # |
| 1180 | # fresh_perl_is |
| 1181 | # |
| 1182 | # Combination of run_perl() and is(). |
| 1183 | # |
| 1184 | |
| 1185 | sub fresh_perl_is { |
| 1186 | my($prog, $expected, $runperl_args, $name) = @_; |
| 1187 | |
| 1188 | # _fresh_perl() is going to clip the trailing newlines off the result. |
| 1189 | # This will make it so the test author doesn't have to know that. |
| 1190 | $expected =~ s/\n+$//; |
| 1191 | |
| 1192 | local $Level = $Level + 1; |
| 1193 | _fresh_perl($prog, 'eq', $expected, $runperl_args, $name); |
| 1194 | } |
| 1195 | |
| 1196 | # |
| 1197 | # fresh_perl_like |
| 1198 | # |
| 1199 | # Combination of run_perl() and like(). |
| 1200 | # |
| 1201 | |
| 1202 | sub fresh_perl_like { |
| 1203 | my($prog, $expected, $runperl_args, $name) = @_; |
| 1204 | local $Level = $Level + 1; |
| 1205 | _fresh_perl($prog, '=~', $expected, $runperl_args, $name); |
| 1206 | } |
| 1207 | |
| 1208 | # Many tests use the same format in __DATA__ or external files to specify a |
| 1209 | # sequence of (fresh) tests to run, extra files they may temporarily need, and |
| 1210 | # what the expected output is. Putting it here allows common code to serve |
| 1211 | # these multiple tests. |
| 1212 | # |
| 1213 | # Each program is source code to run followed by an "EXPECT" line, followed |
| 1214 | # by the expected output. |
| 1215 | # |
| 1216 | # The first line of the code to run may be a command line switch such as -wE |
| 1217 | # or -0777 (alphanumerics only; only one cluster, beginning with a minus is |
| 1218 | # allowed). Later lines may contain (note the '# ' on each): |
| 1219 | # # TODO reason for todo |
| 1220 | # # SKIP reason for skip |
| 1221 | # # SKIP ?code to test if this should be skipped |
| 1222 | # # NAME name of the test (as with ok($ok, $name)) |
| 1223 | # |
| 1224 | # The expected output may contain: |
| 1225 | # OPTION list of options |
| 1226 | # OPTIONS list of options |
| 1227 | # |
| 1228 | # The possible options for OPTION may be: |
| 1229 | # regex - the expected output is a regular expression |
| 1230 | # random - all lines match but in any order |
| 1231 | # fatal - the code will fail fatally (croak, die) |
| 1232 | # nonfatal - the code is not expected to fail fatally |
| 1233 | # |
| 1234 | # If the actual output contains a line "SKIPPED" the test will be |
| 1235 | # skipped. |
| 1236 | # |
| 1237 | # If the actual output contains a line "PREFIX", any output starting with that |
| 1238 | # line will be ignored when comparing with the expected output |
| 1239 | # |
| 1240 | # If the global variable $FATAL is true then OPTION fatal is the |
| 1241 | # default. |
| 1242 | |
| 1243 | our $FATAL; |
| 1244 | sub _setup_one_file { |
| 1245 | my $fh = shift; |
| 1246 | # Store the filename as a program that started at line 0. |
| 1247 | # Real files count lines starting at line 1. |
| 1248 | my @these = (0, shift); |
| 1249 | my ($lineno, $current); |
| 1250 | while (<$fh>) { |
| 1251 | if ($_ eq "########\n") { |
| 1252 | if (defined $current) { |
| 1253 | push @these, $lineno, $current; |
| 1254 | } |
| 1255 | undef $current; |
| 1256 | } else { |
| 1257 | if (!defined $current) { |
| 1258 | $lineno = $.; |
| 1259 | } |
| 1260 | $current .= $_; |
| 1261 | } |
| 1262 | } |
| 1263 | if (defined $current) { |
| 1264 | push @these, $lineno, $current; |
| 1265 | } |
| 1266 | ((scalar @these) / 2 - 1, @these); |
| 1267 | } |
| 1268 | |
| 1269 | sub setup_multiple_progs { |
| 1270 | my ($tests, @prgs); |
| 1271 | foreach my $file (@_) { |
| 1272 | next if $file =~ /(?:~|\.orig|,v)$/; |
| 1273 | next if $file =~ /perlio$/ && !PerlIO::Layer->find('perlio'); |
| 1274 | next if -d $file; |
| 1275 | |
| 1276 | open my $fh, '<', $file or die "Cannot open $file: $!\n" ; |
| 1277 | my $found; |
| 1278 | while (<$fh>) { |
| 1279 | if (/^__END__/) { |
| 1280 | $found = $found + 1; # don't use ++ |
| 1281 | last; |
| 1282 | } |
| 1283 | } |
| 1284 | # This is an internal error, and should never happen. All bar one of |
| 1285 | # the files had an __END__ marker to signal the end of their preamble, |
| 1286 | # although for some it wasn't technically necessary as they have no |
| 1287 | # tests. It might be possible to process files without an __END__ by |
| 1288 | # seeking back to the start and treating the whole file as tests, but |
| 1289 | # it's simpler and more reliable just to make the rule that all files |
| 1290 | # must have __END__ in. This should never fail - a file without an |
| 1291 | # __END__ should not have been checked in, because the regression tests |
| 1292 | # would not have passed. |
| 1293 | die "Could not find '__END__' in $file" |
| 1294 | unless $found; |
| 1295 | |
| 1296 | my ($t, @p) = _setup_one_file($fh, $file); |
| 1297 | $tests += $t; |
| 1298 | push @prgs, @p; |
| 1299 | |
| 1300 | close $fh |
| 1301 | or die "Cannot close $file: $!\n"; |
| 1302 | } |
| 1303 | return ($tests, @prgs); |
| 1304 | } |
| 1305 | |
| 1306 | sub run_multiple_progs { |
| 1307 | my $up = shift; |
| 1308 | my @prgs; |
| 1309 | if ($up) { |
| 1310 | # The tests in lib run in a temporary subdirectory of t, and always |
| 1311 | # pass in a list of "programs" to run |
| 1312 | @prgs = @_; |
| 1313 | } else { |
| 1314 | # The tests below t run in t and pass in a file handle. In theory we |
| 1315 | # can pass (caller)[1] as the second argument to report errors with |
| 1316 | # the filename of our caller, as the handle is always DATA. However, |
| 1317 | # line numbers in DATA count from the __END__ token, so will be wrong. |
| 1318 | # Which is more confusing than not providing line numbers. So, for now, |
| 1319 | # don't provide line numbers. No obvious clean solution - one hack |
| 1320 | # would be to seek DATA back to the start and read to the __END__ token, |
| 1321 | # but that feels almost like we should just open $0 instead. |
| 1322 | |
| 1323 | # Not going to rely on undef in list assignment. |
| 1324 | my $dummy; |
| 1325 | ($dummy, @prgs) = _setup_one_file(shift); |
| 1326 | } |
| 1327 | my $taint_disabled; |
| 1328 | if (! eval {require Config; 1}) { |
| 1329 | warn "test.pl had problems loading Config: $@"; |
| 1330 | $taint_disabled = ''; |
| 1331 | } else { |
| 1332 | $taint_disabled = $Config::Config{taint_disabled}; |
| 1333 | } |
| 1334 | |
| 1335 | my $tmpfile = tempfile(); |
| 1336 | |
| 1337 | my $count_failures = 0; |
| 1338 | my ($file, $line); |
| 1339 | PROGRAM: |
| 1340 | while (defined ($line = shift @prgs)) { |
| 1341 | $_ = shift @prgs; |
| 1342 | unless ($line) { |
| 1343 | $file = $_; |
| 1344 | if (defined $file) { |
| 1345 | print "# From $file\n"; |
| 1346 | } |
| 1347 | next; |
| 1348 | } |
| 1349 | my $switch = ""; |
| 1350 | my @temps ; |
| 1351 | my @temp_path; |
| 1352 | if (s/^(\s*-\w+)//) { |
| 1353 | $switch = $1; |
| 1354 | } |
| 1355 | |
| 1356 | s/^# NOTE.*\n//mg; # remove any NOTE comments in the content |
| 1357 | |
| 1358 | # unhide conflict markers - we hide them so that naive |
| 1359 | # conflict marker detection logic doesn't get upset with our |
| 1360 | # tests. |
| 1361 | s/([<=>])CONFLICT\1/$1 x 7/ge; |
| 1362 | |
| 1363 | my ($prog, $expected) = split(/\nEXPECT(?:\n|$)/, $_, 2); |
| 1364 | |
| 1365 | my %reason; |
| 1366 | foreach my $what (qw(skip todo)) { |
| 1367 | $prog =~ s/^#\s*\U$what\E\s*(.*)\n//m and $reason{$what} = $1; |
| 1368 | # If the SKIP reason starts ? then it's taken as a code snippet to |
| 1369 | # evaluate. This provides the flexibility to have conditional SKIPs |
| 1370 | if ($reason{$what} && $reason{$what} =~ s/^\?//) { |
| 1371 | my $temp = eval $reason{$what}; |
| 1372 | if ($@) { |
| 1373 | die "# In \U$what\E code reason:\n# $reason{$what}\n$@"; |
| 1374 | } |
| 1375 | $reason{$what} = $temp; |
| 1376 | } |
| 1377 | } |
| 1378 | |
| 1379 | my $name = ''; |
| 1380 | if ($prog =~ s/^#\s*NAME\s+(.+)\n//m) { |
| 1381 | $name = $1; |
| 1382 | } elsif (defined $file) { |
| 1383 | $name = "test from $file at line $line"; |
| 1384 | } |
| 1385 | |
| 1386 | if ($switch=~/[Tt]/ and $taint_disabled eq "define") { |
| 1387 | $reason{skip} ||= "This perl does not support taint"; |
| 1388 | } |
| 1389 | |
| 1390 | if ($reason{skip}) { |
| 1391 | SKIP: |
| 1392 | { |
| 1393 | skip($name ? "$name - $reason{skip}" : $reason{skip}, 1); |
| 1394 | } |
| 1395 | next PROGRAM; |
| 1396 | } |
| 1397 | |
| 1398 | if ($prog =~ /--FILE--/) { |
| 1399 | my @files = split(/\n?--FILE--\s*([^\s\n]*)\s*\n/, $prog) ; |
| 1400 | shift @files ; |
| 1401 | die "Internal error: test $_ didn't split into pairs, got " . |
| 1402 | scalar(@files) . "[" . join("%%%%", @files) ."]\n" |
| 1403 | if @files % 2; |
| 1404 | while (@files > 2) { |
| 1405 | my $filename = shift @files; |
| 1406 | my $code = shift @files; |
| 1407 | push @temps, $filename; |
| 1408 | if ($filename =~ m#(.*)/# && $filename !~ m#^\.\./#) { |
| 1409 | require File::Path; |
| 1410 | File::Path::mkpath($1); |
| 1411 | push(@temp_path, $1); |
| 1412 | } |
| 1413 | open my $fh, '>', $filename or die "Cannot open $filename: $!\n"; |
| 1414 | print $fh $code; |
| 1415 | close $fh or die "Cannot close $filename: $!\n"; |
| 1416 | } |
| 1417 | shift @files; |
| 1418 | $prog = shift @files; |
| 1419 | } |
| 1420 | |
| 1421 | open my $fh, '>', $tmpfile or die "Cannot open >$tmpfile: $!"; |
| 1422 | print $fh q{ |
| 1423 | BEGIN { |
| 1424 | push @INC, '.'; |
| 1425 | open STDERR, '>&', STDOUT |
| 1426 | or die "Can't dup STDOUT->STDERR: $!;"; |
| 1427 | } |
| 1428 | }; |
| 1429 | print $fh "\n#line 1\n"; # So the line numbers don't get messed up. |
| 1430 | print $fh $prog,"\n"; |
| 1431 | close $fh or die "Cannot close $tmpfile: $!"; |
| 1432 | my $results = runperl( stderr => 1, progfile => $tmpfile, |
| 1433 | stdin => undef, $up |
| 1434 | ? (switches => ["-I$up/lib", $switch], nolib => 1) |
| 1435 | : (switches => [$switch]) |
| 1436 | ); |
| 1437 | my $status = $?; |
| 1438 | $results =~ s/\n+$//; |
| 1439 | # allow expected output to be written as if $prog is on STDIN |
| 1440 | $results =~ s/$::tempfile_regexp/-/g; |
| 1441 | if ($^O eq 'VMS') { |
| 1442 | # some tests will trigger VMS messages that won't be expected |
| 1443 | $results =~ s/\n?%[A-Z]+-[SIWEF]-[A-Z]+,.*//; |
| 1444 | |
| 1445 | # pipes double these sometimes |
| 1446 | $results =~ s/\n\n/\n/g; |
| 1447 | } |
| 1448 | # bison says 'parse error' instead of 'syntax error', |
| 1449 | # various yaccs may or may not capitalize 'syntax'. |
| 1450 | $results =~ s/^(syntax|parse) error/syntax error/mig; |
| 1451 | # allow all tests to run when there are leaks |
| 1452 | $results =~ s/Scalars leaked: \d+\n//g; |
| 1453 | |
| 1454 | $expected =~ s/\n+$//; |
| 1455 | my $prefix = ($results =~ s#^PREFIX(\n|$)##) ; |
| 1456 | # any special options? (OPTIONS foo bar zap) |
| 1457 | my $option_regex = 0; |
| 1458 | my $option_random = 0; |
| 1459 | my $fatal = $FATAL; |
| 1460 | if ($expected =~ s/^OPTIONS? (.+)(?:\n|\Z)//) { |
| 1461 | foreach my $option (split(' ', $1)) { |
| 1462 | if ($option eq 'regex') { # allow regular expressions |
| 1463 | $option_regex = 1; |
| 1464 | } |
| 1465 | elsif ($option eq 'random') { # all lines match, but in any order |
| 1466 | $option_random = 1; |
| 1467 | } |
| 1468 | elsif ($option eq 'fatal') { # perl should fail |
| 1469 | $fatal = 1; |
| 1470 | } |
| 1471 | elsif ($option eq 'nonfatal') { |
| 1472 | # used to turn off default fatal |
| 1473 | $fatal = 0; |
| 1474 | } |
| 1475 | else { |
| 1476 | die "$0: Unknown OPTION '$option'\n"; |
| 1477 | } |
| 1478 | } |
| 1479 | } |
| 1480 | die "$0: can't have OPTION regex and random\n" |
| 1481 | if $option_regex + $option_random > 1; |
| 1482 | my $ok = 0; |
| 1483 | if ($results =~ s/^SKIPPED\n//) { |
| 1484 | print "$results\n" ; |
| 1485 | $ok = 1; |
| 1486 | } |
| 1487 | else { |
| 1488 | if ($option_random) { |
| 1489 | my @got = sort split "\n", $results; |
| 1490 | my @expected = sort split "\n", $expected; |
| 1491 | |
| 1492 | $ok = "@got" eq "@expected"; |
| 1493 | } |
| 1494 | elsif ($option_regex) { |
| 1495 | $ok = $results =~ /^$expected/; |
| 1496 | } |
| 1497 | elsif ($prefix) { |
| 1498 | $ok = $results =~ /^\Q$expected/; |
| 1499 | } |
| 1500 | else { |
| 1501 | $ok = $results eq $expected; |
| 1502 | } |
| 1503 | |
| 1504 | if ($ok && $fatal && !($status >> 8)) { |
| 1505 | $ok = 0; |
| 1506 | } |
| 1507 | } |
| 1508 | |
| 1509 | local $::TODO = $reason{todo}; |
| 1510 | |
| 1511 | unless ($ok) { |
| 1512 | my $err_line = ''; |
| 1513 | $err_line .= "FILE: $file ; line $line\n" if defined $file; |
| 1514 | $err_line .= "PROG: $switch\n$prog\n" . |
| 1515 | "EXPECTED:\n$expected\n"; |
| 1516 | $err_line .= "EXIT STATUS: != 0\n" if $fatal; |
| 1517 | $err_line .= "GOT:\n$results\n"; |
| 1518 | $err_line .= "EXIT STATUS: " . ($status >> 8) . "\n" if $fatal; |
| 1519 | if ($::TODO) { |
| 1520 | $err_line =~ s/^/# /mg; |
| 1521 | print $err_line; # Harness can't filter it out from STDERR. |
| 1522 | } |
| 1523 | else { |
| 1524 | print STDERR $err_line; |
| 1525 | ++$count_failures; |
| 1526 | die "PERL_TEST_ABORT_FIRST_FAILURE set Test Failure" |
| 1527 | if $ENV{PERL_TEST_ABORT_FIRST_FAILURE}; |
| 1528 | } |
| 1529 | } |
| 1530 | |
| 1531 | if (defined $file) { |
| 1532 | _ok($ok, "at $file line $line", $name); |
| 1533 | } else { |
| 1534 | # We don't have file and line number data for the test, so report |
| 1535 | # errors as coming from our caller. |
| 1536 | local $Level = $Level + 1; |
| 1537 | ok($ok, $name); |
| 1538 | } |
| 1539 | |
| 1540 | foreach (@temps) { |
| 1541 | unlink $_ if $_; |
| 1542 | } |
| 1543 | foreach (@temp_path) { |
| 1544 | File::Path::rmtree $_ if -d $_; |
| 1545 | } |
| 1546 | } |
| 1547 | |
| 1548 | if ( $count_failures ) { |
| 1549 | print STDERR <<'EOS'; |
| 1550 | # |
| 1551 | # Note: 'run_multiple_progs' run has one or more failures |
| 1552 | # you can consider setting the environment variable |
| 1553 | # PERL_TEST_ABORT_FIRST_FAILURE=1 before running the test |
| 1554 | # to stop on the first error. |
| 1555 | # |
| 1556 | EOS |
| 1557 | } |
| 1558 | |
| 1559 | |
| 1560 | return; |
| 1561 | } |
| 1562 | |
| 1563 | sub can_ok ($@) { |
| 1564 | my($proto, @methods) = @_; |
| 1565 | my $class = ref $proto || $proto; |
| 1566 | |
| 1567 | unless( @methods ) { |
| 1568 | return _ok( 0, _where(), "$class->can(...)" ); |
| 1569 | } |
| 1570 | |
| 1571 | my @nok = (); |
| 1572 | foreach my $method (@methods) { |
| 1573 | local($!, $@); # don't interfere with caller's $@ |
| 1574 | # eval sometimes resets $! |
| 1575 | eval { $proto->can($method) } || push @nok, $method; |
| 1576 | } |
| 1577 | |
| 1578 | my $name; |
| 1579 | $name = @methods == 1 ? "$class->can('$methods[0]')" |
| 1580 | : "$class->can(...)"; |
| 1581 | |
| 1582 | _ok( !@nok, _where(), $name ); |
| 1583 | } |
| 1584 | |
| 1585 | |
| 1586 | # Call $class->new( @$args ); and run the result through object_ok. |
| 1587 | # See Test::More::new_ok |
| 1588 | sub new_ok { |
| 1589 | my($class, $args, $obj_name) = @_; |
| 1590 | $args ||= []; |
| 1591 | $obj_name = "The object" unless defined $obj_name; |
| 1592 | |
| 1593 | local $Level = $Level + 1; |
| 1594 | |
| 1595 | my $obj; |
| 1596 | my $ok = eval { $obj = $class->new(@$args); 1 }; |
| 1597 | my $error = $@; |
| 1598 | |
| 1599 | if($ok) { |
| 1600 | object_ok($obj, $class, $obj_name); |
| 1601 | } |
| 1602 | else { |
| 1603 | ok( 0, "new() died" ); |
| 1604 | diag("Error was: $@"); |
| 1605 | } |
| 1606 | |
| 1607 | return $obj; |
| 1608 | |
| 1609 | } |
| 1610 | |
| 1611 | |
| 1612 | sub isa_ok ($$;$) { |
| 1613 | my($object, $class, $obj_name) = @_; |
| 1614 | |
| 1615 | my $diag; |
| 1616 | $obj_name = 'The object' unless defined $obj_name; |
| 1617 | my $name = "$obj_name isa $class"; |
| 1618 | if( !defined $object ) { |
| 1619 | $diag = "$obj_name isn't defined"; |
| 1620 | } |
| 1621 | else { |
| 1622 | my $whatami = ref $object ? 'object' : 'class'; |
| 1623 | |
| 1624 | # We can't use UNIVERSAL::isa because we want to honor isa() overrides |
| 1625 | local($@, $!); # eval sometimes resets $! |
| 1626 | my $rslt = eval { $object->isa($class) }; |
| 1627 | my $error = $@; # in case something else blows away $@ |
| 1628 | |
| 1629 | if( $error ) { |
| 1630 | if( $error =~ /^Can't call method "isa" on unblessed reference/ ) { |
| 1631 | # It's an unblessed reference |
| 1632 | $obj_name = 'The reference' unless defined $obj_name; |
| 1633 | if( !UNIVERSAL::isa($object, $class) ) { |
| 1634 | my $ref = ref $object; |
| 1635 | $diag = "$obj_name isn't a '$class' it's a '$ref'"; |
| 1636 | } |
| 1637 | } |
| 1638 | elsif( $error =~ /Can't call method "isa" without a package/ ) { |
| 1639 | # It's something that can't even be a class |
| 1640 | $obj_name = 'The thing' unless defined $obj_name; |
| 1641 | $diag = "$obj_name isn't a class or reference"; |
| 1642 | } |
| 1643 | else { |
| 1644 | die <<WHOA; |
| 1645 | WHOA! I tried to call ->isa on your object and got some weird error. |
| 1646 | This should never happen. Please contact the author immediately. |
| 1647 | Here's the error. |
| 1648 | $@ |
| 1649 | WHOA |
| 1650 | } |
| 1651 | } |
| 1652 | elsif( !$rslt ) { |
| 1653 | $obj_name = "The $whatami" unless defined $obj_name; |
| 1654 | my $ref = ref $object; |
| 1655 | $diag = "$obj_name isn't a '$class' it's a '$ref'"; |
| 1656 | } |
| 1657 | } |
| 1658 | |
| 1659 | _ok( !$diag, _where(), $name ); |
| 1660 | } |
| 1661 | |
| 1662 | |
| 1663 | sub class_ok { |
| 1664 | my($class, $isa, $class_name) = @_; |
| 1665 | |
| 1666 | # Written so as to count as one test |
| 1667 | local $Level = $Level + 1; |
| 1668 | if( ref $class ) { |
| 1669 | ok( 0, "$class is a reference, not a class name" ); |
| 1670 | } |
| 1671 | else { |
| 1672 | isa_ok($class, $isa, $class_name); |
| 1673 | } |
| 1674 | } |
| 1675 | |
| 1676 | |
| 1677 | sub object_ok { |
| 1678 | my($obj, $isa, $obj_name) = @_; |
| 1679 | |
| 1680 | local $Level = $Level + 1; |
| 1681 | if( !ref $obj ) { |
| 1682 | ok( 0, "$obj is not a reference" ); |
| 1683 | } |
| 1684 | else { |
| 1685 | isa_ok($obj, $isa, $obj_name); |
| 1686 | } |
| 1687 | } |
| 1688 | |
| 1689 | |
| 1690 | # Purposefully avoiding a closure. |
| 1691 | sub __capture { |
| 1692 | push @::__capture, join "", @_; |
| 1693 | } |
| 1694 | |
| 1695 | sub capture_warnings { |
| 1696 | my $code = shift; |
| 1697 | |
| 1698 | local @::__capture; |
| 1699 | local $SIG {__WARN__} = \&__capture; |
| 1700 | local $Level = 1; |
| 1701 | &$code; |
| 1702 | return @::__capture; |
| 1703 | } |
| 1704 | |
| 1705 | # This will generate a variable number of tests. |
| 1706 | # Use done_testing() instead of a fixed plan. |
| 1707 | sub warnings_like { |
| 1708 | my ($code, $expect, $name) = @_; |
| 1709 | local $Level = $Level + 1; |
| 1710 | |
| 1711 | my @w = capture_warnings($code); |
| 1712 | |
| 1713 | cmp_ok(scalar @w, '==', scalar @$expect, $name); |
| 1714 | foreach my $e (@$expect) { |
| 1715 | if (ref $e) { |
| 1716 | like(shift @w, $e, $name); |
| 1717 | } else { |
| 1718 | is(shift @w, $e, $name); |
| 1719 | } |
| 1720 | } |
| 1721 | if (@w) { |
| 1722 | diag("Saw these additional warnings:"); |
| 1723 | diag($_) foreach @w; |
| 1724 | } |
| 1725 | } |
| 1726 | |
| 1727 | sub _fail_excess_warnings { |
| 1728 | my($expect, $got, $name) = @_; |
| 1729 | local $Level = $Level + 1; |
| 1730 | # This will fail, and produce diagnostics |
| 1731 | is($expect, scalar @$got, $name); |
| 1732 | diag("Saw these warnings:"); |
| 1733 | diag($_) foreach @$got; |
| 1734 | } |
| 1735 | |
| 1736 | sub warning_is { |
| 1737 | my ($code, $expect, $name) = @_; |
| 1738 | die sprintf "Expect must be a string or undef, not a %s reference", ref $expect |
| 1739 | if ref $expect; |
| 1740 | local $Level = $Level + 1; |
| 1741 | my @w = capture_warnings($code); |
| 1742 | if (@w > 1) { |
| 1743 | _fail_excess_warnings(0 + defined $expect, \@w, $name); |
| 1744 | } else { |
| 1745 | is($w[0], $expect, $name); |
| 1746 | } |
| 1747 | } |
| 1748 | |
| 1749 | sub warning_like { |
| 1750 | my ($code, $expect, $name) = @_; |
| 1751 | die sprintf "Expect must be a regexp object" |
| 1752 | unless ref $expect eq 'Regexp'; |
| 1753 | local $Level = $Level + 1; |
| 1754 | my @w = capture_warnings($code); |
| 1755 | if (@w > 1) { |
| 1756 | _fail_excess_warnings(0 + defined $expect, \@w, $name); |
| 1757 | } else { |
| 1758 | like($w[0], $expect, $name); |
| 1759 | } |
| 1760 | } |
| 1761 | |
| 1762 | # Set or clear a watchdog timer. The input seconds is: |
| 1763 | # zero to clear; |
| 1764 | # non-zero to set |
| 1765 | # and is multiplied by $ENV{PERL_TEST_TIME_OUT_FACTOR} (default 1; minimum 1). |
| 1766 | # Set this variable in your profile for slow boxes, or use it to override the |
| 1767 | # timeout temporarily for debugging. |
| 1768 | # |
| 1769 | # This will figure out a suitable method to implement the timer, but you can |
| 1770 | # force it to use an alarm by setting the optional second parameter to |
| 1771 | # 'alarm', or to use a separate process (if available on this platform) by |
| 1772 | # setting that parameter to 'process'. |
| 1773 | # |
| 1774 | # It is good practice to CLEAR EVERY WATCHDOG timer. Otherwise the timer |
| 1775 | # applies to the entire rest of the file. Even if that works now, new tests |
| 1776 | # tend to get added to the end of the file, and people may not notice that |
| 1777 | # they are being timed. Those tests may all complete before the timer kills |
| 1778 | # them, but then more new tests get added, even further away from the timer |
| 1779 | # setting code, with less likelihood of noticing that. Those tests may also |
| 1780 | # generally work, but flap on heavily loaded smokers, leading to debugging |
| 1781 | # effort that wouldn't have had to be expended if the timer had been cancelled |
| 1782 | # in the first place |
| 1783 | # |
| 1784 | # NOTE: If the test file uses 'threads', then call the watchdog() function |
| 1785 | # _AFTER_ the 'threads' module is loaded. |
| 1786 | { # Closure |
| 1787 | my $watchdog; |
| 1788 | my $watchdog_thread; |
| 1789 | |
| 1790 | sub watchdog ($;$) |
| 1791 | { |
| 1792 | my $timeout = shift; |
| 1793 | |
| 1794 | # If cancelling, use the state variables to know which method was used to |
| 1795 | # create the watchdog. |
| 1796 | if ($timeout == 0) { |
| 1797 | if ($watchdog_thread) { |
| 1798 | $watchdog_thread->kill('KILL'); |
| 1799 | undef $watchdog_thread; |
| 1800 | } |
| 1801 | elsif ($watchdog) { |
| 1802 | kill('KILL', $watchdog); |
| 1803 | undef $watchdog; |
| 1804 | } |
| 1805 | else { |
| 1806 | alarm(0); |
| 1807 | } |
| 1808 | |
| 1809 | return; |
| 1810 | } |
| 1811 | |
| 1812 | # Make sure these aren't defined. |
| 1813 | undef $watchdog; |
| 1814 | undef $watchdog_thread; |
| 1815 | |
| 1816 | my $method = shift || ""; |
| 1817 | |
| 1818 | my $timeout_msg = 'Test process timed out - terminating'; |
| 1819 | |
| 1820 | # Accept either spelling |
| 1821 | my $timeout_factor = $ENV{PERL_TEST_TIME_OUT_FACTOR} |
| 1822 | || $ENV{PERL_TEST_TIMEOUT_FACTOR} |
| 1823 | || 1; |
| 1824 | $timeout_factor = 1 if $timeout_factor < 1; |
| 1825 | $timeout_factor = $1 if $timeout_factor =~ /^(\d+)$/; |
| 1826 | |
| 1827 | # Valgrind slows perl way down so give it more time before dying. |
| 1828 | $timeout_factor = 10 if $timeout_factor < 10 && $ENV{PERL_VALGRIND}; |
| 1829 | |
| 1830 | $timeout *= $timeout_factor; |
| 1831 | |
| 1832 | my $pid_to_kill = $$; # PID for this process |
| 1833 | |
| 1834 | if ($method eq "alarm") { |
| 1835 | goto WATCHDOG_VIA_ALARM; |
| 1836 | } |
| 1837 | |
| 1838 | # shut up use only once warning |
| 1839 | my $threads_on = $threads::threads && $threads::threads; |
| 1840 | |
| 1841 | # Don't use a watchdog process if 'threads' is loaded - |
| 1842 | # use a watchdog thread instead |
| 1843 | if (!$threads_on || $method eq "process") { |
| 1844 | |
| 1845 | # On Windows and VMS, try launching a watchdog process |
| 1846 | # using system(1, ...) (see perlport.pod). system() returns |
| 1847 | # immediately on these platforms with effectively a pid of the new |
| 1848 | # process |
| 1849 | if ($is_mswin || $is_vms) { |
| 1850 | # On Windows, try to get the 'real' PID |
| 1851 | if ($is_mswin) { |
| 1852 | eval { require Win32; }; |
| 1853 | if (defined(&Win32::GetCurrentProcessId)) { |
| 1854 | $pid_to_kill = Win32::GetCurrentProcessId(); |
| 1855 | } |
| 1856 | } |
| 1857 | |
| 1858 | # If we still have a fake PID, we can't use this method at all |
| 1859 | return if ($pid_to_kill <= 0); |
| 1860 | |
| 1861 | # Launch watchdog process |
| 1862 | undef $watchdog; |
| 1863 | eval { |
| 1864 | local $SIG{'__WARN__'} = sub { |
| 1865 | _diag("Watchdog warning: $_[0]"); |
| 1866 | }; |
| 1867 | my $sig = $is_vms ? 'TERM' : 'KILL'; |
| 1868 | my $prog = "sleep($timeout);" . |
| 1869 | "warn qq/# $timeout_msg" . '\n/;' . |
| 1870 | "kill(q/$sig/, $pid_to_kill);"; |
| 1871 | |
| 1872 | # If we're in taint mode PATH will be tainted |
| 1873 | $ENV{PATH} =~ /(.*)/s; |
| 1874 | local $ENV{PATH} = untaint_path($1); |
| 1875 | |
| 1876 | # On Windows use the indirect object plus LIST form to guarantee |
| 1877 | # that perl is launched directly rather than via the shell (see |
| 1878 | # perlfunc.pod), and ensure that the LIST has multiple elements |
| 1879 | # since the indirect object plus COMMANDSTRING form seems to |
| 1880 | # hang (see perl #121283). Don't do this on VMS, which doesn't |
| 1881 | # support the LIST form at all. |
| 1882 | if ($is_mswin) { |
| 1883 | my $runperl = which_perl(); |
| 1884 | $runperl =~ /(.*)/; |
| 1885 | $runperl = $1; |
| 1886 | if ($runperl =~ m/\s/) { |
| 1887 | $runperl = qq{"$runperl"}; |
| 1888 | } |
| 1889 | $watchdog = system({ $runperl } 1, $runperl, '-e', $prog); |
| 1890 | } |
| 1891 | else { |
| 1892 | my $cmd = _create_runperl(prog => $prog); |
| 1893 | $watchdog = system(1, $cmd); |
| 1894 | } |
| 1895 | }; |
| 1896 | if ($@ || ($watchdog <= 0)) { |
| 1897 | _diag('Failed to start watchdog'); |
| 1898 | _diag($@) if $@; |
| 1899 | undef($watchdog); |
| 1900 | return; |
| 1901 | } |
| 1902 | |
| 1903 | # Add END block to parent to terminate and |
| 1904 | # clean up watchdog process |
| 1905 | eval("END { local \$! = 0; local \$? = 0; |
| 1906 | wait() if kill('KILL', $watchdog); };"); |
| 1907 | return; |
| 1908 | } |
| 1909 | |
| 1910 | # Try using fork() to generate a watchdog process |
| 1911 | undef $watchdog; |
| 1912 | eval { $watchdog = fork() }; |
| 1913 | if (defined($watchdog)) { |
| 1914 | if ($watchdog) { # Parent process |
| 1915 | # Add END block to parent to terminate and |
| 1916 | # clean up watchdog process |
| 1917 | eval "END { local \$! = 0; local \$? = 0; |
| 1918 | wait() if kill('KILL', $watchdog); };"; |
| 1919 | return; |
| 1920 | } |
| 1921 | |
| 1922 | ### Watchdog process code |
| 1923 | |
| 1924 | # Load POSIX if available |
| 1925 | eval { require POSIX; }; |
| 1926 | |
| 1927 | # Execute the timeout |
| 1928 | sleep($timeout - 2) if ($timeout > 2); # Workaround for perlbug #49073 |
| 1929 | sleep(2); |
| 1930 | |
| 1931 | # Kill test process if still running |
| 1932 | if (kill(0, $pid_to_kill)) { |
| 1933 | _diag($timeout_msg); |
| 1934 | kill('KILL', $pid_to_kill); |
| 1935 | if ($is_cygwin) { |
| 1936 | # sometimes the above isn't enough on cygwin |
| 1937 | sleep 1; # wait a little, it might have worked after all |
| 1938 | system("/bin/kill -f $pid_to_kill") if kill(0, $pid_to_kill); |
| 1939 | } |
| 1940 | } |
| 1941 | |
| 1942 | # Don't execute END block (added at beginning of this file) |
| 1943 | $NO_ENDING = 1; |
| 1944 | |
| 1945 | # Terminate ourself (i.e., the watchdog) |
| 1946 | POSIX::_exit(1) if (defined(&POSIX::_exit)); |
| 1947 | exit(1); |
| 1948 | } |
| 1949 | |
| 1950 | # fork() failed - fall through and try using a thread |
| 1951 | } |
| 1952 | |
| 1953 | # Use a watchdog thread because either 'threads' is loaded, |
| 1954 | # or fork() failed |
| 1955 | if (eval {require threads; 1}) { |
| 1956 | $watchdog_thread = 'threads'->create(sub { |
| 1957 | # Load POSIX if available |
| 1958 | eval { require POSIX; }; |
| 1959 | |
| 1960 | $SIG{'KILL'} = sub { threads->exit(); }; |
| 1961 | |
| 1962 | # Detach after the signal handler is set up; the parent knows |
| 1963 | # not to signal until detached. |
| 1964 | 'threads'->detach(); |
| 1965 | |
| 1966 | # Execute the timeout |
| 1967 | my $time_left = $timeout; |
| 1968 | do { |
| 1969 | $time_left = $time_left - sleep($time_left); |
| 1970 | } while ($time_left > 0); |
| 1971 | |
| 1972 | # Kill the parent (and ourself) |
| 1973 | select(STDERR); $| = 1; |
| 1974 | _diag($timeout_msg); |
| 1975 | POSIX::_exit(1) if (defined(&POSIX::_exit)); |
| 1976 | my $sig = $is_vms ? 'TERM' : 'KILL'; |
| 1977 | kill($sig, $pid_to_kill); |
| 1978 | }); |
| 1979 | |
| 1980 | # Don't proceed until the watchdog has set up its signal handler. |
| 1981 | # (Otherwise there is a possibility that we will exit with threads |
| 1982 | # running.) The watchdog tells us that the handler is set by |
| 1983 | # detaching itself. (The 'is_running()' is a fail-safe.) |
| 1984 | while ( $watchdog_thread->is_running() |
| 1985 | && ! $watchdog_thread->is_detached()) |
| 1986 | { |
| 1987 | 'threads'->yield(); |
| 1988 | } |
| 1989 | |
| 1990 | return; |
| 1991 | } |
| 1992 | |
| 1993 | # If everything above fails, then just use an alarm timeout |
| 1994 | WATCHDOG_VIA_ALARM: |
| 1995 | if (eval { alarm($timeout); 1; }) { |
| 1996 | # Load POSIX if available |
| 1997 | eval { require POSIX; }; |
| 1998 | |
| 1999 | # Alarm handler will do the actual 'killing' |
| 2000 | $SIG{'ALRM'} = sub { |
| 2001 | select(STDERR); $| = 1; |
| 2002 | _diag($timeout_msg); |
| 2003 | POSIX::_exit(1) if (defined(&POSIX::_exit)); |
| 2004 | my $sig = $is_vms ? 'TERM' : 'KILL'; |
| 2005 | kill($sig, $pid_to_kill); |
| 2006 | }; |
| 2007 | } |
| 2008 | } |
| 2009 | } # End closure |
| 2010 | |
| 2011 | # Orphaned Docker or Linux containers do not necessarily attach to PID 1. They might attach to 0 instead. |
| 2012 | sub is_linux_container { |
| 2013 | |
| 2014 | if ($^O eq 'linux' && open my $fh, '<', '/proc/1/cgroup') { |
| 2015 | while(<$fh>) { |
| 2016 | if (m{^\d+:pids:(.*)} && $1 ne '/init.scope') { |
| 2017 | return 1; |
| 2018 | } |
| 2019 | } |
| 2020 | } |
| 2021 | |
| 2022 | return 0; |
| 2023 | } |
| 2024 | |
| 2025 | 1; |