diff --git a/.gitignore b/.gitignore index c9a37c1b4..f5848a7af 100644 --- a/.gitignore +++ b/.gitignore @@ -28,9 +28,6 @@ perl5/ # Ignore the t/ directory (Perl test suite copied from perl5/t/) # These should be synced from perl5 repo, not committed here t/ -# But keep our own t/README.md documentation -!t/README.md -!t/test.pl # Ignore perl5_t/ directory (module tests from perl5/lib/*.t) # These are synced from perl5 repo via sync.pl, not committed here diff --git a/docs/TESTING.md b/docs/TESTING.md index 3f5abffc8..e8bfed4b6 100644 --- a/docs/TESTING.md +++ b/docs/TESTING.md @@ -284,6 +284,40 @@ Check for infinite loops, use timeout command: timeout 30s ./jperl problematic_test.t ``` +## Importing Perl5 Test Suite + +PerlOnJava can import and run tests from the official Perl5 repository to verify compatibility and behavior. + +### Setup + +To import Perl test files and verify their behavior under PerlOnJava: + +1. Clone the Perl5 repository (if not already done): + ```bash + rm -rf perl5 # if it exists + git clone https://github.com/Perl/perl5.git + ``` + +2. Run the import script to copy tests and apply patches: + ```bash + perl dev/import-perl5/sync.pl + ``` + +This will copy all files from `perl5/t/` to `t/` and apply any necessary patches for PerlOnJava compatibility. + +### Running Imported Tests + +To run the imported Perl5 tests: + +```bash +perl dev/tools/perl_test_runner.pl --output out.json t +``` + +See `dev/import-perl5/README.md` for more details on: +- The import system architecture +- How to add patches for PerlOnJava compatibility +- Managing test expectations + ## See Also - [Build Guide](BUILD.md) - Building PerlOnJava diff --git a/src/main/java/org/perlonjava/operators/ModuleOperators.java b/src/main/java/org/perlonjava/operators/ModuleOperators.java index c702f5665..ef4b47157 100644 --- a/src/main/java/org/perlonjava/operators/ModuleOperators.java +++ b/src/main/java/org/perlonjava/operators/ModuleOperators.java @@ -13,7 +13,6 @@ import java.nio.file.Files; import java.nio.file.Path; import java.nio.file.Paths; -import java.util.List; import static org.perlonjava.perlmodule.Feature.featureManager; import static org.perlonjava.runtime.ExceptionFormatter.findInnermostCause; @@ -304,8 +303,11 @@ else if (runtimeScalar.type == RuntimeScalarType.GLOB || runtimeScalar.type == R else if (code == null) { // Check if the filename is an absolute path or starts with ./ or ../ + // and if it exists on the filesystem Path filePath = Paths.get(fileName); - if (filePath.isAbsolute() || fileName.startsWith("./") || fileName.startsWith("../")) { + boolean tryDirectPath = filePath.isAbsolute() || fileName.startsWith("./") || fileName.startsWith("../"); + + if (tryDirectPath) { // For absolute or explicit relative paths, resolve using RuntimeIO.getPath filePath = RuntimeIO.resolvePath(fileName); if (Files.exists(filePath)) { @@ -317,42 +319,77 @@ else if (code == null) { fullName = filePath; actualFileName = fullName.toString(); } - } else { - // Otherwise, search in INC directories - List inc = GlobalVariable.getGlobalArray("main::INC").elements; + } + + // If we haven't found the file yet, search in INC directories + // This handles: + // 1. Relative module names (e.g., Foo::Bar) + // 2. Absolute/relative paths that don't exist on filesystem (try @INC hooks only) + if (fullName == null) { + // Search in INC directories + RuntimeArray incArray = GlobalVariable.getGlobalArray("main::INC"); // Make sure the jar files are in @INC - the Perl test files can remove it boolean seen = false; - for (RuntimeBase dir : inc) { + int incSize = incArray.size(); + for (int i = 0; i < incSize; i++) { + RuntimeScalar dir = incArray.get(i); + // Handle tied scalars + if (dir.type == RuntimeScalarType.TIED_SCALAR) { + dir = dir.tiedFetch(); + } if (dir.toString().equals(GlobalContext.JAR_PERLLIB)) { seen = true; break; } } if (!seen) { - inc.add(new RuntimeScalar(GlobalContext.JAR_PERLLIB)); + incArray.push(new RuntimeScalar(GlobalContext.JAR_PERLLIB)); } - for (RuntimeBase dir : inc) { - RuntimeScalar dirScalar = dir.scalar(); + // Iterate using indexed access to properly handle tied arrays + incSize = incArray.size(); + for (int i = 0; i < incSize; i++) { + RuntimeScalar dirScalar = incArray.get(i); + + // If this is a tied scalar, fetch the actual value + if (dirScalar.type == RuntimeScalarType.TIED_SCALAR) { + dirScalar = dirScalar.tiedFetch(); + } + + // For absolute/relative paths (starting with /, ./, ../), only try hooks + // Regular directory entries should be skipped for such paths + boolean isHook = dirScalar.type == RuntimeScalarType.CODE || + dirScalar.type == RuntimeScalarType.REFERENCE || + dirScalar.type == RuntimeScalarType.ARRAYREFERENCE || + dirScalar.type == RuntimeScalarType.HASHREFERENCE; + + if (tryDirectPath && !isHook) { + // Skip regular directory entries for absolute/relative paths + continue; + } // Check if this @INC entry is a CODE reference, ARRAY reference, or blessed object - if (dirScalar.type == RuntimeScalarType.CODE || - dirScalar.type == RuntimeScalarType.REFERENCE || - dirScalar.type == RuntimeScalarType.ARRAYREFERENCE || - dirScalar.type == RuntimeScalarType.HASHREFERENCE) { + if (isHook) { RuntimeBase hookResult = tryIncHook(dirScalar, fileName); if (hookResult != null) { // Hook returned something useful RuntimeScalar hookResultScalar = hookResult.scalar(); - // Check if it's a filehandle (GLOB) or array ref with filehandle + // Check if it's a filehandle (GLOB), array ref with filehandle, or scalar ref with code RuntimeScalar filehandle = null; if (hookResultScalar.type == RuntimeScalarType.GLOB || hookResultScalar.type == RuntimeScalarType.GLOBREFERENCE) { filehandle = hookResultScalar; + } else if (hookResultScalar.type == RuntimeScalarType.REFERENCE) { + // Hook returned a scalar reference - treat the dereferenced value as code + RuntimeScalar derefValue = hookResultScalar.scalarDeref(); + code = derefValue.toString(); + actualFileName = fileName; + incHookRef = dirScalar; + break; } else if (hookResultScalar.type == RuntimeScalarType.ARRAYREFERENCE && hookResultScalar.value instanceof RuntimeArray) { RuntimeArray resultArray = (RuntimeArray) hookResultScalar.value; @@ -382,7 +419,7 @@ else if (code == null) { } // Original string handling for directory paths - String dirName = dir.toString(); + String dirName = dirScalar.toString(); if (dirName.equals(GlobalContext.JAR_PERLLIB)) { // Try to find in jar at "src/main/perl/lib" String resourcePath = "/lib/" + fileName; diff --git a/src/main/java/org/perlonjava/runtime/RuntimeArray.java b/src/main/java/org/perlonjava/runtime/RuntimeArray.java index d124e2296..2ac4c6922 100644 --- a/src/main/java/org/perlonjava/runtime/RuntimeArray.java +++ b/src/main/java/org/perlonjava/runtime/RuntimeArray.java @@ -876,13 +876,23 @@ public void dynamicSaveState() { // Create a new RuntimeArray to save the current state RuntimeArray currentState = new RuntimeArray(); // Copy the current elements to the new state - currentState.elements = new ArrayList<>(this.elements); + // For tied arrays, preserve the TieArray object + if (this.type == TIED_ARRAY) { + currentState.elements = this.elements; // Keep the TieArray reference + currentState.type = TIED_ARRAY; + } else { + currentState.elements = new ArrayList<>(this.elements); + } // Copy the current blessId to the new state currentState.blessId = this.blessId; // Push the current state onto the stack dynamicStateStack.push(currentState); - // Clear the array elements - this.elements.clear(); + // Clear the array elements (for tied arrays, this calls CLEAR) + if (this.type == TIED_ARRAY) { + TieArray.tiedClear(this); + } else { + this.elements.clear(); + } // Reset the blessId this.blessId = 0; } @@ -900,6 +910,8 @@ public void dynamicRestoreState() { RuntimeArray previousState = dynamicStateStack.pop(); // Restore the elements from the saved state this.elements = previousState.elements; + // Restore the type from the saved state (important for tied arrays) + this.type = previousState.type; // Restore the blessId from the saved state this.blessId = previousState.blessId; } diff --git a/t/README.md b/t/README.md deleted file mode 100644 index ca6c78559..000000000 --- a/t/README.md +++ /dev/null @@ -1,29 +0,0 @@ -`t/` - -This directory is a placeholder for the original Perl test suite. - -## Setup - -To import Perl test files and verify their behavior under PerlOnJava: - -1. Clone the Perl5 repository (if not already done): - ```bash - rm -rf perl5 # if it exists - git clone https://github.com/Perl/perl5.git - ``` - -2. Run the import script to copy tests and apply patches: - ```bash - perl dev/import-perl5/sync.pl - ``` - -This will copy all files from `perl5/t/` to `t/` and apply any necessary patches for PerlOnJava compatibility. - -See `dev/import-perl5/README.md` for more details on the import system and how to add patches. - -## Running Tests - -To run the tests, use the following commands: - - perl dev/tools/perl_test_runner.pl --output out.json t - diff --git a/t/test.pl b/t/test.pl deleted file mode 100644 index cbc9791fc..000000000 --- a/t/test.pl +++ /dev/null @@ -1,2126 +0,0 @@ -# -------------------------------------------- -# Modified t/test.pl for running Perl test suite with PerlOnJava: -# -# - added subroutine `skip_internal` to workaround the use of non-local goto (`last SKIP`). -# - no other changes. -# -------------------------------------------- - -# -# t/test.pl - most of Test::More functionality without the fuss - -# NOTE: -# -# Do not rely on features found only in more modern Perls here, as some CPAN -# distributions copy this file and must operate on older Perls. Similarly, keep -# things, simple as this may be run under fairly broken circumstances. For -# example, increment ($x++) has a certain amount of cleverness for things like -# -# $x = 'zz'; -# $x++; # $x eq 'aaa'; -# -# This stands more chance of breaking than just a simple -# -# $x = $x + 1 -# -# In this file, we use the latter "Baby Perl" approach, and increment -# will be worked over by t/op/inc.t -# -# see t/test_pl.pod for documentation - -# This file sets for its caller $::IS_ASCII and $::IS_EBCDIC appropriately; -# and $::devnull to be the string to use to specify /dev/null on this -# platform. - -$| = 1; -our $Level = 1; -my $test = 1; -my $planned; -my $noplan; -my $Perl; # Safer version of $^X set by which_perl() - -# This defines ASCII/UTF-8 vs EBCDIC/UTF-EBCDIC -$::IS_ASCII = ord 'A' == 65; -$::IS_EBCDIC = ord 'A' == 193; - -# This is 'our' to enable harness to account for TODO-ed tests in -# overall grade of PASS or FAIL -our $TODO = 0; -our $NO_ENDING = 0; -our $Tests_Are_Passing = 1; - -# Use this instead of print to avoid interference while testing globals. -sub _print { - local($\, $", $,) = (undef, ' ', ''); - print STDOUT @_; -} - -sub _print_stderr { - local($\, $", $,) = (undef, ' ', ''); - print STDERR @_; -} - -sub plan { - my $n; - if (@_ == 1) { - $n = shift; - if ($n eq 'no_plan') { - undef $n; - $noplan = 1; - } - } else { - my %plan = @_; - $plan{skip_all} and skip_all($plan{skip_all}); - $n = $plan{tests}; - } - _print "1..$n\n" unless $noplan; - $planned = $n; -} - - -# Set the plan at the end. See Test::More::done_testing. -sub done_testing { - my $n = $test - 1; - $n = shift if @_; - - _print "1..$n\n"; - $planned = $n; -} - - -END { - my $ran = $test - 1; - if (!$NO_ENDING) { - if (defined $planned && $planned != $ran) { - _print_stderr - "# Looks like you planned $planned tests but ran $ran.\n"; - } elsif ($noplan) { - _print "1..$ran\n"; - } - } -} - -sub _diag { - return unless @_; - my @mess = _comment(@_); - $TODO ? _print(@mess) : _print_stderr(@mess); -} - -# Use this instead of "print STDERR" when outputting failure diagnostic -# messages -sub diag { - _diag(@_); -} - -# Use this instead of "print" when outputting informational messages -sub note { - return unless @_; - _print( _comment(@_) ); -} - -sub is_miniperl { - return !defined &DynaLoader::boot_DynaLoader; -} - -sub set_up_inc { - # Don't clobber @INC under miniperl - @INC = () unless is_miniperl; - unshift @INC, @_; -} - -sub _comment { - return map { /^#/ ? "$_\n" : "# $_\n" } - map { split /\n/ } @_; -} - -sub _have_dynamic_extension { - my $extension = shift; - unless (eval {require Config; 1}) { - warn "test.pl had problems loading Config: $@"; - return 1; - } - $extension =~ s!::!/!g; - return 1 if ($Config::Config{extensions} =~ /\b$extension\b/); -} - -sub skip_all { - if (@_) { - _print "1..0 # Skip @_\n"; - } else { - _print "1..0\n"; - } - exit(0); -} - -sub skip_all_if_miniperl { - skip_all(@_) if is_miniperl(); -} - -sub skip_all_without_dynamic_extension { - my ($extension) = @_; - skip_all("no dynamic loading on miniperl, no $extension") if is_miniperl(); - return if &_have_dynamic_extension; - skip_all("$extension was not built"); -} - -sub skip_all_without_perlio { - skip_all('no PerlIO') unless PerlIO::Layer->find('perlio'); -} - -sub skip_all_without_config { - unless (eval {require Config; 1}) { - warn "test.pl had problems loading Config: $@"; - return; - } - foreach (@_) { - next if $Config::Config{$_}; - my $key = $_; # Need to copy, before trying to modify. - $key =~ s/^use//; - $key =~ s/^d_//; - skip_all("no $key"); - } -} - -sub skip_all_without_unicode_tables { # (but only under miniperl) - if (is_miniperl()) { - skip_all_if_miniperl("Unicode tables not built yet") - unless eval 'require "unicore/UCD.pl"'; - } -} - -sub find_git_or_skip { - my ($source_dir, $reason); - - if ( $ENV{CONTINUOUS_INTEGRATION} && $ENV{WORKSPACE} ) { - $source_dir = $ENV{WORKSPACE}; - if ( -d "${source_dir}/.git" ) { - $ENV{GIT_DIR} = "${source_dir}/.git"; - return $source_dir; - } - } - - if (-d '.git') { - $source_dir = '.'; - } elsif (-l 'MANIFEST' && -l 'AUTHORS') { - my $where = readlink 'MANIFEST'; - die "Can't readlink MANIFEST: $!" unless defined $where; - die "Confusing symlink target for MANIFEST, '$where'" - unless $where =~ s!/MANIFEST\z!!; - if (-d "$where/.git") { - # Looks like we are in a symlink tree - if (exists $ENV{GIT_DIR}) { - diag("Found source tree at $where, but \$ENV{GIT_DIR} is $ENV{GIT_DIR}. Not changing it"); - } else { - note("Found source tree at $where, setting \$ENV{GIT_DIR}"); - $ENV{GIT_DIR} = "$where/.git"; - } - $source_dir = $where; - } - } elsif (exists $ENV{GIT_DIR} || -f '.git') { - my $commit = '8d063cd8450e59ea1c611a2f4f5a21059a2804f1'; - my $out = `git rev-parse --verify --quiet '$commit^{commit}'`; - chomp $out; - if($out eq $commit) { - $source_dir = '.' - } - } - if ($ENV{'PERL_BUILD_PACKAGING'}) { - $reason = 'PERL_BUILD_PACKAGING is set'; - } elsif ($source_dir) { - my $version_string = `git --version`; - if (defined $version_string - && $version_string =~ /\Agit version (\d+\.\d+\.\d+)(.*)/) { - return $source_dir if eval "v$1 ge v1.5.0"; - # If you have earlier than 1.5.0 and it works, change this test - $reason = "in git checkout, but git version '$1$2' too old"; - } else { - $reason = "in git checkout, but cannot run git"; - } - } else { - $reason = 'not being run from a git checkout'; - } - skip_all($reason) if $_[0] && $_[0] eq 'all'; - skip($reason, @_); -} - -sub BAIL_OUT { - my ($reason) = @_; - _print("Bail out! $reason\n"); - exit 255; -} - -sub _ok { - my ($pass, $where, $name, @mess) = @_; - # Do not try to microoptimize by factoring out the "not ". - # VMS will avenge. - my $out; - if ($name) { - # escape out '#' or it will interfere with '# skip' and such - $name =~ s/#/\\#/g; - $out = $pass ? "ok $test - $name" : "not ok $test - $name"; - } else { - $out = $pass ? "ok $test - [$where]" : "not ok $test - [$where]"; - } - - if ($TODO) { - $out = $out . " # TODO $TODO"; - } else { - $Tests_Are_Passing = 0 unless $pass; - } - - _print "$out\n"; - - if ($pass) { - note @mess; # Ensure that the message is properly escaped. - } - else { - my $msg = "# Failed test $test - "; - $msg.= "$name " if $name; - $msg .= "$where\n"; - _diag $msg; - _diag @mess; - } - - $test = $test + 1; # don't use ++ - - return $pass; -} - -sub _where { - my (undef, $filename, $lineno) = caller($Level); - return "at $filename line $lineno"; -} - -# DON'T use this for matches. Use like() instead. -sub ok ($@) { - my ($pass, $name, @mess) = @_; - _ok($pass, _where(), $name, @mess); -} - -sub _q { - my $x = shift; - return 'undef' unless defined $x; - my $q = $x; - $q =~ s/\\/\\\\/g; - $q =~ s/'/\\'/g; - return "'$q'"; -} - -sub _qq { - my $x = shift; - return defined $x ? '"' . display ($x) . '"' : 'undef'; -}; - -# Support pre-5.10 Perls, for the benefit of CPAN dists that copy this file. -# Note that chr(90) exists in both ASCII ("Z") and EBCDIC ("!"). -my $chars_template = defined(eval { pack "W*", 90 }) ? "W*" : "U*"; -eval 'sub re::is_regexp { ref($_[0]) eq "Regexp" }' - if !defined &re::is_regexp; - -# keys are the codes \n etc map to, values are 2 char strings such as \n -my %backslash_escape; -foreach my $x (split //, 'enrtfa\\\'"') { - $backslash_escape{ord eval "\"\\$x\""} = "\\$x"; -} -# A way to display scalars containing control characters and Unicode. -# Trying to avoid setting $_, or relying on local $_ to work. -sub display { - my @result; - foreach my $element (@_) { - my $x = $element; # Make a copy in case @_ contains unmodifiable elements - if (defined $x and not ref $x) { - my $y = ''; - foreach my $c (unpack($chars_template, $x)) { - if ($c > 255) { - $y = $y . sprintf "\\x{%x}", $c; - } elsif ($backslash_escape{$c}) { - $y = $y . $backslash_escape{$c}; - } elsif ($c < ord " ") { - # Use octal for characters with small ordinals that are - # traditionally expressed as octal: the controls below - # space, which on EBCDIC are almost all the controls, but - # on ASCII don't include DEL nor the C1 controls. - $y = $y . sprintf "\\%03o", $c; - } elsif (chr $c =~ /[[:print:]]/a) { - $y = $y . chr $c; - } - else { - $y = $y . sprintf "\\x%02X", $c; - } - } - $x = $y; - } - return $x unless wantarray; - push @result, $x; - } - return @result; -} - - -# Escape a string in a similar (but not identical) fashion to how the -# regex debugger does, using "x" style escapes in the form -# "%x{01+bc+02+cd}" to show the codepoint of the escaped values. Like -# the regex debugger we use percentage instead of backslash so that it -# is trivial to distinguish backslash based sequences that are commonly -# found in regex patterns from escaped octets that are in the pattern. -# To reduce the output length and improve clarity if there are multiple -# escaped codepoints in a row we bundle them together into one "%x{...}" -# structure. -# -# Implementation note: This code should work fine on all platforms as we -# use utf8::native_to_unicode() to map native codepoints to unicode -# (thanks Karl!) and back again, also we deliberately avoid using the -# regex engine to do the escaping as this function is intended for cases -# where we are testing the regex engine. -# -# WARNING: This function should only be used for diagnostic purposes, it -# does not output valid code! - -sub display_rx { - my ($str) = @_; - my $escaped = ""; - my @cp; # codepoints - for my $i (0 .. length($str)-1) { - my $char = substr($str,$i,1); - push @cp, utf8::native_to_unicode(ord($char)); - } - while (@cp) { - my $ord = shift @cp; - if (32 <= $ord <= 126 and $ord != 37) { - $escaped .= chr(utf8::unicode_to_native($ord)); - } - else { - my @cp_hex = sprintf "%02x", $ord; - while (@cp and $cp[0] != 37 and ($cp[0]<32 or $cp[0]>126)) { - push @cp_hex, sprintf "%02x", shift @cp; - } - $escaped .= sprintf "%%x{%s}", join "+", @cp_hex; - } - } - return $escaped; -} - -sub is ($$@) { - my ($got, $expected, $name, @mess) = @_; - - my $pass; - if( !defined $got || !defined $expected ) { - # undef only matches undef - $pass = !defined $got && !defined $expected; - } - else { - $pass = $got eq $expected; - } - - unless ($pass) { - unshift(@mess, "# got "._qq($got)."\n", - "# expected "._qq($expected)."\n"); - if (defined $got and defined $expected and - (length($got)>20 or length($expected)>20)) - { - my $p = 0; - $p++ while substr($got,$p,1) eq substr($expected,$p,1); - push @mess,"# diff at $p\n"; - push @mess,"# after "._qq(substr($got,$p < 40 ? 0 : $p - 40, - $p < 40 ? $p : 40)) . "\n"; - push @mess,"# have "._qq(substr($got,$p,40))."\n"; - push @mess,"# want "._qq(substr($expected,$p,40))."\n"; - } - } - _ok($pass, _where(), $name, @mess); -} - -sub isnt ($$@) { - my ($got, $isnt, $name, @mess) = @_; - - my $pass; - if( !defined $got || !defined $isnt ) { - # undef only matches undef - $pass = defined $got || defined $isnt; - } - else { - $pass = $got ne $isnt; - } - - unless( $pass ) { - unshift(@mess, "# it should not be "._qq($got)."\n", - "# but it is.\n"); - } - _ok($pass, _where(), $name, @mess); -} - -sub cmp_ok ($$$@) { - my($got, $type, $expected, $name, @mess) = @_; - - my $pass; - { - local $^W = 0; - local($@,$!); # don't interfere with $@ - # eval() sometimes resets $! - $pass = eval "\$got $type \$expected"; - } - unless ($pass) { - # It seems Irix long doubles can have 2147483648 and 2147483648 - # that stringify to the same thing but are actually numerically - # different. Display the numbers if $type isn't a string operator, - # and the numbers are stringwise the same. - # (all string operators have alphabetic names, so tr/a-z// is true) - # This will also show numbers for some unneeded cases, but will - # definitely be helpful for things such as == and <= that fail - if ($got eq $expected and $type !~ tr/a-z//) { - unshift @mess, "# $got - $expected = " . ($got - $expected) . "\n"; - } - unshift(@mess, "# got "._qq($got)."\n", - "# expected $type "._qq($expected)."\n"); - } - _ok($pass, _where(), $name, @mess); -} - -# Check that $got is within $range of $expected -# if $range is 0, then check it's exact -# else if $expected is 0, then $range is an absolute value -# otherwise $range is a fractional error. -# Here $range must be numeric, >= 0 -# Non numeric ranges might be a useful future extension. (eg %) -sub within ($$$@) { - my ($got, $expected, $range, $name, @mess) = @_; - my $pass; - if (!defined $got or !defined $expected or !defined $range) { - # This is a fail, but doesn't need extra diagnostics - } elsif ($got !~ tr/0-9// or $expected !~ tr/0-9// or $range !~ tr/0-9//) { - # This is a fail - unshift @mess, "# got, expected and range must be numeric\n"; - } elsif ($range < 0) { - # This is also a fail - unshift @mess, "# range must not be negative\n"; - } elsif ($range == 0) { - # Within 0 is == - $pass = $got == $expected; - } elsif ($expected == 0) { - # If expected is 0, treat range as absolute - $pass = ($got <= $range) && ($got >= - $range); - } else { - my $diff = $got - $expected; - $pass = abs ($diff / $expected) < $range; - } - unless ($pass) { - if ($got eq $expected) { - unshift @mess, "# $got - $expected = " . ($got - $expected) . "\n"; - } - unshift@mess, "# got "._qq($got)."\n", - "# expected "._qq($expected)." (within "._qq($range).")\n"; - } - _ok($pass, _where(), $name, @mess); -} - -# Note: this isn't quite as fancy as Test::More::like(). - -sub like ($$@) { like_yn (0,@_) }; # 0 for - -sub unlike ($$@) { like_yn (1,@_) }; # 1 for un- - -sub like_yn ($$$@) { - my ($flip, undef, $expected, $name, @mess) = @_; - - # We just accept like(..., qr/.../), not like(..., '...'), and - # definitely not like(..., '/.../') like - # Test::Builder::maybe_regex() does. - unless (re::is_regexp($expected)) { - die "PANIC: The value '$expected' isn't a regexp. The like() function needs a qr// pattern, not a string"; - } - - my $pass = ($flip) ? $_[1] !~ /$expected/ : $_[1] =~ /$expected/; - unless ($pass) { - my $display_got = display($_[1]); - my $display_expected = display($expected); - unshift(@mess, "# got '$display_got'\n", - $flip - ? "# expected !~ /$display_expected/\n" - : "# expected /$display_expected/\n"); - } - local $Level = $Level + 1; - _ok($pass, _where(), $name, @mess); -} - -sub refcount_is { - # Don't unpack first arg; access it directly via $_[0] to avoid creating - # another reference and upsetting the refcount - my (undef, $expected, $name, @mess) = @_; - my $got = &Internals::SvREFCNT($_[0]) + 1; # +1 to account for the & calling style - my $pass = $got == $expected; - unless ($pass) { - unshift @mess, "# got $got references\n" . - "# expected $expected\n"; - } - _ok($pass, _where(), $name, @mess); -} - -sub pass { - _ok(1, '', @_); -} - -sub fail { - _ok(0, _where(), @_); -} - -sub curr_test { - $test = shift if @_; - return $test; -} - -sub next_test { - my $retval = $test; - $test = $test + 1; # don't use ++ - $retval; -} - -# Note: can't pass multipart messages since we try to -# be compatible with Test::More::skip(). -sub skip { - my $why = shift; - my $n = @_ ? shift : 1; - my $bad_swap; - my $both_zero; - { - local $^W = 0; - $bad_swap = $why > 0 && $n == 0; - $both_zero = $why == 0 && $n == 0; - } - if ($bad_swap || $both_zero || @_) { - my $arg = "'$why', '$n'"; - if (@_) { - $arg .= join(", ", '', map { qq['$_'] } @_); - } - die qq[$0: expected skip(why, count), got skip($arg)\n]; - } - for (1..$n) { - _print "ok $test # skip $why\n"; - $test = $test + 1; - } - local $^W = 0; - last SKIP; -} - -sub skip_internal { - my $why = shift; - my $n = @_ ? shift : 1; - my $bad_swap; - my $both_zero; - { - local $^W = 0; - $bad_swap = $why > 0 && $n == 0; - $both_zero = $why == 0 && $n == 0; - } - if ($bad_swap || $both_zero || @_) { - my $arg = "'$why', '$n'"; - if (@_) { - $arg .= join(", ", '', map { qq['$_'] } @_); - } - die qq[$0: expected skip(why, count), got skip($arg)\n]; - } - for (1..$n) { - _print "ok $test # skip $why\n"; - $test = $test + 1; - } - local $^W = 0; - # last SKIP; - 1; -} - -sub skip_if_miniperl { - ## PerlOnJava is not miniperl - # skip(@_) if is_miniperl(); -} - -sub skip_without_dynamic_extension { - ## PerlOnJava has dynamic extension - # my $extension = shift; - # skip("no dynamic loading on miniperl, no extension $extension", @_) - # if is_miniperl(); - # return if &_have_dynamic_extension($extension); - # skip("extension $extension was not built", @_); -} - -sub todo_skip { - my $why = shift; - my $n = @_ ? shift : 1; - - for (1..$n) { - _print "not ok $test # TODO & SKIP $why\n"; - $test = $test + 1; - } - local $^W = 0; - last TODO; -} - -sub eq_array { - my ($ra, $rb) = @_; - return 0 unless $#$ra == $#$rb; - for my $i (0..$#$ra) { - next if !defined $ra->[$i] && !defined $rb->[$i]; - return 0 if !defined $ra->[$i]; - return 0 if !defined $rb->[$i]; - return 0 unless $ra->[$i] eq $rb->[$i]; - } - return 1; -} - -sub eq_hash { - my ($orig, $suspect) = @_; - my $fail; - while (my ($key, $value) = each %$suspect) { - # Force a hash recompute if this perl's internals can cache the hash key. - $key = "" . $key; - if (exists $orig->{$key}) { - if ( - defined $orig->{$key} != defined $value - || (defined $value && $orig->{$key} ne $value) - ) { - _print "# key ", _qq($key), " was ", _qq($orig->{$key}), - " now ", _qq($value), "\n"; - $fail = 1; - } - } else { - _print "# key ", _qq($key), " is ", _qq($value), - ", not in original.\n"; - $fail = 1; - } - } - foreach (keys %$orig) { - # Force a hash recompute if this perl's internals can cache the hash key. - $_ = "" . $_; - next if (exists $suspect->{$_}); - _print "# key ", _qq($_), " was ", _qq($orig->{$_}), " now missing.\n"; - $fail = 1; - } - !$fail; -} - -# We only provide a subset of the Test::More functionality. -sub require_ok ($) { - my ($require) = @_; - if ($require =~ tr/[A-Za-z0-9:.]//c) { - fail("Invalid character in \"$require\", passed to require_ok"); - } else { - eval < [ command-line switches ] -# nolib => 1 # don't use -I../lib (included by default) -# non_portable => Don't warn if a one liner contains quotes -# prog => one-liner (avoid quotes) -# progs => [ multi-liner (avoid quotes) ] -# progfile => perl script -# stdin => string to feed the stdin (or undef to redirect from /dev/null) -# stderr => If 'devnull' suppresses stderr, if other TRUE value redirect -# stderr to stdout -# args => [ command-line arguments to the perl program ] -# verbose => print the command line - -my $is_mswin = $^O eq 'MSWin32'; -my $is_vms = $^O eq 'VMS'; -my $is_cygwin = $^O eq 'cygwin'; - -# /dev/null appears to be surprisingly portable. -$::devnull = ($is_mswin ? 'nul' : '/dev/null'); - -sub _quote_args { - my ($runperl, $args) = @_; - - foreach (@$args) { - # In VMS protect with doublequotes because otherwise - # DCL will lowercase -- unless already doublequoted. - $_ = q(").$_.q(") if $is_vms && !/^\"/ && length($_) > 0; - $runperl = $runperl . ' ' . $_; - } - return $runperl; -} - -sub _create_runperl { # Create the string to qx in runperl(). - my %args = @_; - my $runperl = which_perl(); - if ($runperl =~ m/\s/) { - $runperl = qq{"$runperl"}; - } - #- this allows, for example, to set PERL_RUNPERL_DEBUG=/usr/bin/valgrind - if ($ENV{PERL_RUNPERL_DEBUG}) { - $runperl = "$ENV{PERL_RUNPERL_DEBUG} $runperl"; - } - unless ($args{nolib}) { - $runperl = $runperl . ' "-I../lib" "-I." '; # doublequotes because of VMS - } - if ($args{switches}) { - local $Level = 2; - die "test.pl:runperl(): 'switches' must be an ARRAYREF " . _where() - unless ref $args{switches} eq "ARRAY"; - $runperl = _quote_args($runperl, $args{switches}); - } - if (defined $args{prog}) { - die "test.pl:runperl(): both 'prog' and 'progs' cannot be used " . _where() - if defined $args{progs}; - $args{progs} = [split /\n/, $args{prog}, -1] - } - if (defined $args{progs}) { - die "test.pl:runperl(): 'progs' must be an ARRAYREF " . _where() - unless ref $args{progs} eq "ARRAY"; - foreach my $prog (@{$args{progs}}) { - if (!$args{non_portable}) { - if ($prog =~ tr/'"//) { - warn "quotes in prog >>$prog<< are not portable"; - } - if ($prog =~ /^([<>|]|2>)/) { - warn "Initial $1 in prog >>$prog<< is not portable"; - } - if ($prog =~ /&\z/) { - warn "Trailing & in prog >>$prog<< is not portable"; - } - } - if ($is_mswin || $is_vms) { - $runperl = $runperl . qq ( -e "$prog" ); - } - else { - $runperl = $runperl . qq ( -e '$prog' ); - } - } - } elsif (defined $args{progfile}) { - $runperl = $runperl . qq( "$args{progfile}"); - } else { - # You probably didn't want to be sucking in from the upstream stdin - die "test.pl:runperl(): none of prog, progs, progfile, args, " - . " switches or stdin specified" - unless defined $args{args} or defined $args{switches} - or defined $args{stdin}; - } - if (defined $args{stdin}) { - # so we don't try to put literal newlines and crs onto the - # command line. - $args{stdin} =~ s/\n/\\n/g; - $args{stdin} =~ s/\r/\\r/g; - - if ($is_mswin || $is_vms) { - $runperl = qq{$Perl -e "print qq(} . - $args{stdin} . q{)" | } . $runperl; - } - else { - $runperl = qq{$Perl -e 'print qq(} . - $args{stdin} . q{)' | } . $runperl; - } - } elsif (exists $args{stdin}) { - # Using the pipe construction above can cause fun on systems which use - # ksh as /bin/sh, as ksh does pipes differently (with one less process) - # With sh, for the command line 'perl -e 'print qq()' | perl -e ...' - # the sh process forks two children, which use exec to start the two - # perl processes. The parent shell process persists for the duration of - # the pipeline, and the second perl process starts with no children. - # With ksh (and zsh), the shell saves a process by forking a child for - # just the first perl process, and execing itself to start the second. - # This means that the second perl process starts with one child which - # it didn't create. This causes "fun" when if the tests assume that - # wait (or waitpid) will only return information about processes - # started within the test. - # They also cause fun on VMS, where the pipe implementation returns - # the exit code of the process at the front of the pipeline, not the - # end. This messes up any test using OPTION FATAL. - # Hence it's useful to have a way to make STDIN be at eof without - # needing a pipeline, so that the fork tests have a sane environment - # without these surprises. - - $runperl = "$runperl <$::devnull"; - } - if (defined $args{args}) { - $runperl = _quote_args($runperl, $args{args}); - } - if (exists $args{stderr} && $args{stderr} eq 'devnull') { - $runperl = "$runperl 2>$::devnull"; - } - elsif ($args{stderr}) { - $runperl = $runperl . ' 2>&1'; - } - if ($args{verbose}) { - my $runperldisplay = $runperl; - $runperldisplay =~ s/\n/\n\#/g; - _print_stderr "# $runperldisplay\n"; - } - return $runperl; -} - -# usage: -# $ENV{PATH} =~ /(.*)/s; -# local $ENV{PATH} = untaint_path($1); -sub untaint_path { - my $path = shift; - my $sep; - - if (! eval {require Config; 1}) { - warn "test.pl had problems loading Config: $@"; - $sep = ':'; - } else { - $sep = $Config::Config{path_sep}; - } - - $path = - join $sep, grep { $_ ne "" and $_ ne "." and -d $_ and - ($is_mswin or $is_vms or !(stat && (stat _)[2]&0022)) } - split quotemeta ($sep), $1; - if ($is_cygwin) { # Must have /bin under Cygwin - if (length $path) { - $path = $path . $sep; - } - $path = $path . '/bin'; - } elsif (!$is_vms and !length $path) { - # empty PATH is the same as a path of "." on *nix so to prevent - # tests from dieing under taint we need to return something - # absolute. Perhaps "/" would be better? Anything absolute will do. - $path = "/usr/bin"; - } - - $path; -} - -# sub run_perl {} is alias to below -# Since this uses backticks to run, it is subject to the rules of the shell. -# Locale settings may pose a problem, depending on the program being run. -sub runperl { - die "test.pl:runperl() does not take a hashref" - if ref $_[0] and ref $_[0] eq 'HASH'; - my $runperl = &_create_runperl; - my $result; - - my $tainted = ${^TAINT}; - my %args = @_; - exists $args{switches} && grep m/^-T$/, @{$args{switches}} and $tainted = $tainted + 1; - - if ($tainted) { - # We will assume that if you're running under -T, you really mean to - # run a fresh perl, so we'll brute force launder everything for you - my @keys = grep {exists $ENV{$_}} qw(CDPATH IFS ENV BASH_ENV); - local @ENV{@keys} = (); - # Untaint, plus take out . and empty string: - local $ENV{'DCL$PATH'} = $1 if $is_vms && exists($ENV{'DCL$PATH'}) && ($ENV{'DCL$PATH'} =~ /(.*)/s); - $ENV{PATH} =~ /(.*)/s; - local $ENV{PATH} = untaint_path($1); - $runperl =~ /(.*)/s; - $runperl = $1; - - $result = `$runperl`; - } else { - $result = `$runperl`; - } - $result =~ s/\n\n/\n/g if $is_vms; # XXX pipes sometimes double these - return $result; -} - -# Nice alias -*run_perl = *run_perl = \&runperl; # shut up "used only once" warning - -# Run perl with specified environment and arguments, return (STDOUT, STDERR) -# set DEBUG_RUNENV=1 in the environment to debug. -sub runperl_and_capture { - my ($env, $args) = @_; - - my $STDOUT = tempfile(); - my $STDERR = tempfile(); - my $PERL = $^X; - my $FAILURE_CODE = 119; - - local %ENV = %ENV; - delete $ENV{PERLLIB}; - delete $ENV{PERL5LIB}; - delete $ENV{PERL5OPT}; - delete $ENV{PERL_USE_UNSAFE_INC}; - my $pid = fork; - return (0, "Couldn't fork: $!") unless defined $pid; # failure - if ($pid) { # parent - waitpid $pid,0; - my $exit_code = $? ? $? >> 8 : 0; - my ($out, $err)= ("", ""); - local $/; - if (open my $stdout, '<', $STDOUT) { - $out .= <$stdout>; - } else { - $err .= "Could not read STDOUT '$STDOUT' file: $!\n"; - } - if (open my $stderr, '<', $STDERR) { - $err .= <$stderr>; - } else { - $err .= "Could not read STDERR '$STDERR' file: $!\n"; - } - if ($exit_code == $FAILURE_CODE) { - $err .= "Something went wrong. Received FAILURE_CODE as exit code.\n"; - } - if ($ENV{DEBUG_RUNENV}) { - print "OUT: $out\n"; - print "ERR: $err\n"; - } - return ($out, $err); - } elsif (defined $pid) { # child - # Just in case the order we update the environment changes how - # the environment is set up we sort the keys here for consistency. - for my $k (sort keys %$env) { - $ENV{$k} = $env->{$k}; - } - if ($ENV{DEBUG_RUNENV}) { - print "Child Process $$ Executing:\n$PERL @$args\n"; - } - open STDOUT, '>', $STDOUT - or do { - print "Failed to dup STDOUT to '$STDOUT': $!"; - exit $FAILURE_CODE; - }; - open STDERR, '>', $STDERR - or do { - print "Failed to dup STDERR to '$STDERR': $!"; - exit $FAILURE_CODE; - }; - exec $PERL, @$args - or print STDERR "Failed to exec: ", - join(" ",map { "'$_'" } $^X, @$args), - ": $!\n"; - exit $FAILURE_CODE; - } -} - -sub DIE { - _print_stderr "# @_\n"; - exit 1; -} - -# A somewhat safer version of the sometimes wrong $^X. -sub which_perl { - unless (defined $Perl) { - $Perl = $^X; - - # VMS should have 'perl' aliased properly - return $Perl if $is_vms; - - my $exe; - if (! eval {require Config; 1}) { - warn "test.pl had problems loading Config: $@"; - $exe = ''; - } else { - $exe = $Config::Config{_exe}; - } - $exe = '' unless defined $exe; - - # This doesn't absolutize the path: beware of future chdirs(). - # We could do File::Spec->abs2rel() but that does getcwd()s, - # which is a bit heavyweight to do here. - - if ($Perl =~ /^perl\Q$exe\E$/i) { - my $perl = "perl$exe"; - if (! eval {require File::Spec; 1}) { - warn "test.pl had problems loading File::Spec: $@"; - $Perl = "./$perl"; - } else { - $Perl = File::Spec->catfile(File::Spec->curdir(), $perl); - } - } - - # Build up the name of the executable file from the name of - # the command. - - if ($Perl !~ /\Q$exe\E$/i) { - $Perl = $Perl . $exe; - } - - warn "which_perl: cannot find $Perl from $^X" unless -f $Perl; - - # For subcommands to use. - $ENV{PERLEXE} = $Perl; - } - return $Perl; -} - -sub unlink_all { - my $count = 0; - foreach my $file (@_) { - 1 while unlink $file; - if( -f $file ){ - _print_stderr "# Couldn't unlink '$file': $!\n"; - }else{ - $count = $count + 1; # don't use ++ - } - } - $count; -} - -# _num_to_alpha - Returns a string of letters representing a positive integer. -# Arguments : -# number to convert -# maximum number of letters - -# returns undef if the number is negative -# returns undef if the number of letters is greater than the maximum wanted - -# _num_to_alpha( 0) eq 'A'; -# _num_to_alpha( 1) eq 'B'; -# _num_to_alpha(25) eq 'Z'; -# _num_to_alpha(26) eq 'AA'; -# _num_to_alpha(27) eq 'AB'; - -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); - -# Avoid ++ -- ranges split negative numbers -sub _num_to_alpha { - my($num,$max_char) = @_; - return unless $num >= 0; - my $alpha = ''; - my $char_count = 0; - $max_char = 0 if !defined($max_char) or $max_char < 0; - - while( 1 ){ - $alpha = $letters[ $num % @letters ] . $alpha; - $num = int( $num / @letters ); - last if $num == 0; - $num = $num - 1; - - # char limit - next unless $max_char; - $char_count = $char_count + 1; - return if $char_count == $max_char; - } - return $alpha; -} - -my %tmpfiles; -sub unlink_tempfiles { - unlink_all keys %tmpfiles; - %tmpfiles = (); -} - -END { unlink_tempfiles(); } - - -# NOTE: tempfile() may be used as a module names in our tests -# so the result must be restricted to only legal characters for a module -# name. - -# A regexp that matches the tempfile names -$::tempfile_regexp = 'tmp_[A-Z]+_[A-Z]+'; - -# Avoid ++, avoid ranges, avoid split // -my $tempfile_count = 0; -my $max_file_chars = 3; -# Note that the max number of is NOT 26**3, it is 26**3 + 26**2 + 26, -# as 3 character files are distinct from 2 character files, from 1 characters -# files, etc. -sub tempfile { - # if you change the format returned by tempfile() you MUST change - # the $::tempfile_regex define above. - my $try_prefix = (-d "t" ? "t/" : "")."tmp_"._num_to_alpha($$); - while (1) { - my $alpha = _num_to_alpha($tempfile_count,$max_file_chars); - last unless defined $alpha; - my $try = $try_prefix . "_" . $alpha; - $tempfile_count = $tempfile_count + 1; - - # Need to note all the file names we allocated, as a second request - # may come before the first is created. Also we are avoiding ++ here - # so we aren't using the normal idiom for this kind of test. - if (!$tmpfiles{$try} && !-e $try) { - # We have a winner - $tmpfiles{$try} = 1; - return $try; - } - } - die sprintf - 'panic: Too many tempfile()s with prefix "%s", limit of %d reached', - $try_prefix, 26 ** $max_file_chars; -} - -# register_tempfile - Adds a list of files to be removed at the end of the current test file -# Arguments : -# a list of files to be removed later - -# returns a count of how many file names were actually added - -# Reuses %tmpfiles so that tempfile() will also skip any files added here -# even if the file doesn't exist yet. - -sub register_tempfile { - my $count = 0; - for( @_ ){ - if( $tmpfiles{$_} ){ - _print_stderr "# Temporary file '$_' already added\n"; - }else{ - $tmpfiles{$_} = 1; - $count = $count + 1; - } - } - return $count; -} - -# This is the temporary file for fresh_perl -my $tmpfile = tempfile(); - -sub fresh_perl { - my($prog, $runperl_args) = @_; - - # Run 'runperl' with the complete perl program contained in '$prog', and - # arguments in the hash referred to by '$runperl_args'. The results are - # returned, with $? set to the exit code. Unless overridden, stderr is - # redirected to stdout. - # - # Placing the program in a file bypasses various sh vagaries - - die sprintf "Second argument to fresh_perl_.* must be hashref of args to fresh_perl (or {})" - unless !(defined $runperl_args) || ref($runperl_args) eq 'HASH'; - - # Given the choice of the mis-parsable {} - # (we want an anon hash, but a borked lexer might think that it's a block) - # or relying on taking a reference to a lexical - # (\ might be mis-parsed, and the reference counting on the pad may go - # awry) - # it feels like the least-worse thing is to assume that auto-vivification - # works. At least, this is only going to be a run-time failure, so won't - # affect tests using this file but not this function. - my $trim= delete $runperl_args->{rtrim_result}; # hide from runperl - $runperl_args->{progfile} ||= $tmpfile; - $runperl_args->{stderr} = 1 unless exists $runperl_args->{stderr}; - - open TEST, '>', $tmpfile or die "Cannot open $tmpfile: $!"; - binmode TEST, ':utf8' if $runperl_args->{wide_chars}; - print TEST $prog; - close TEST or die "Cannot close $tmpfile: $!"; - - my $results = runperl(%$runperl_args); - my $status = $?; # Not necessary to save this, but it makes it clear to - # future maintainers. - $results=~s/[ \t]+\n/\n/g if $trim; - # Clean up the results into something a bit more predictable. - $results =~ s/\n+$//; - $results =~ s/at\s+$::tempfile_regexp\s+line/at - line/g; - $results =~ s/of\s+$::tempfile_regexp\s+aborted/of - aborted/g; - - # bison says 'parse error' instead of 'syntax error', - # various yaccs may or may not capitalize 'syntax'. - $results =~ s/^(syntax|parse) error/syntax error/mig; - - if ($is_vms) { - # some tests will trigger VMS messages that won't be expected - $results =~ s/\n?%[A-Z]+-[SIWEF]-[A-Z]+,.*//; - - # pipes double these sometimes - $results =~ s/\n\n/\n/g; - } - - $? = $status; - return $results; -} - - -sub _fresh_perl { - my($prog, $action, $expect, $runperl_args, $name) = @_; - - local $Level = $Level + 1; - - # strip trailing whitespace if requested - makes some tests easier - $expect=~s/[[:blank:]]+\n/\n/g if $runperl_args->{rtrim_result}; - - my $results = fresh_perl($prog, $runperl_args); - my $status = $?; - - # Use the first line of the program as a name if none was given - unless( $name ) { - (my $first_line, $name) = $prog =~ /^((.{1,50}).*)/; - $name = $name . '...' if length $first_line > length $name; - } - - # Historically this was implemented using a closure, but then that means - # that the tests for closures avoid using this code. Given that there - # are exactly two callers, doing exactly two things, the simpler approach - # feels like a better trade off. - my $pass; - if ($action eq 'eq') { - $pass = is($results, $expect, $name); - } elsif ($action eq '=~') { - $pass = like($results, $expect, $name); - } else { - die "_fresh_perl can't process action '$action'"; - } - - unless ($pass) { - _diag "# PROG: \n$prog\n"; - _diag "# STATUS: $status\n"; - } - - return $pass; -} - -# -# fresh_perl_is -# -# Combination of run_perl() and is(). -# - -sub fresh_perl_is { - my($prog, $expected, $runperl_args, $name) = @_; - - # _fresh_perl() is going to clip the trailing newlines off the result. - # This will make it so the test author doesn't have to know that. - $expected =~ s/\n+$//; - - local $Level = $Level + 1; - _fresh_perl($prog, 'eq', $expected, $runperl_args, $name); -} - -# -# fresh_perl_like -# -# Combination of run_perl() and like(). -# - -sub fresh_perl_like { - my($prog, $expected, $runperl_args, $name) = @_; - local $Level = $Level + 1; - _fresh_perl($prog, '=~', $expected, $runperl_args, $name); -} - -# Many tests use the same format in __DATA__ or external files to specify a -# sequence of (fresh) tests to run, extra files they may temporarily need, and -# what the expected output is. Putting it here allows common code to serve -# these multiple tests. -# -# Each program is source code to run followed by an "EXPECT" line, followed -# by the expected output. -# -# The first line of the code to run may be a command line switch such as -wE -# or -0777 (alphanumerics only; only one cluster, beginning with a minus is -# allowed). Later lines may contain (note the '# ' on each): -# # TODO reason for todo -# # SKIP reason for skip -# # SKIP ?code to test if this should be skipped -# # NAME name of the test (as with ok($ok, $name)) -# -# The expected output may contain: -# OPTION list of options -# OPTIONS list of options -# -# The possible options for OPTION may be: -# regex - the expected output is a regular expression -# random - all lines match but in any order -# fatal - the code will fail fatally (croak, die) -# nonfatal - the code is not expected to fail fatally -# -# If the actual output contains a line "SKIPPED" the test will be -# skipped. -# -# If the actual output contains a line "PREFIX", any output starting with that -# line will be ignored when comparing with the expected output -# -# If the global variable $FATAL is true then OPTION fatal is the -# default. - -our $FATAL; -sub _setup_one_file { - my $fh = shift; - # Store the filename as a program that started at line 0. - # Real files count lines starting at line 1. - my @these = (0, shift); - my ($lineno, $current); - while (<$fh>) { - if ($_ eq "########\n") { - if (defined $current) { - push @these, $lineno, $current; - } - undef $current; - } else { - if (!defined $current) { - $lineno = $.; - } - $current .= $_; - } - } - if (defined $current) { - push @these, $lineno, $current; - } - ((scalar @these) / 2 - 1, @these); -} - -sub setup_multiple_progs { - my ($tests, @prgs); - foreach my $file (@_) { - next if $file =~ /(?:~|\.orig|,v)$/; - next if $file =~ /perlio$/ && !PerlIO::Layer->find('perlio'); - next if -d $file; - - open my $fh, '<', $file or die "Cannot open $file: $!\n" ; - my $found; - my $preamble = ""; - while (<$fh>) { - if (/^__END__/) { - $found = $found + 1; # don't use ++ - last; - } - if (/^#\s+PREAMBLE\s+(.*)$/) { - $preamble .= "$1\n"; - } - } - # This is an internal error, and should never happen. All bar one of - # the files had an __END__ marker to signal the end of their preamble, - # although for some it wasn't technically necessary as they have no - # tests. It might be possible to process files without an __END__ by - # seeking back to the start and treating the whole file as tests, but - # it's simpler and more reliable just to make the rule that all files - # must have __END__ in. This should never fail - a file without an - # __END__ should not have been checked in, because the regression tests - # would not have passed. - die "Could not find '__END__' in $file" - unless $found; - - my ($t, @p) = _setup_one_file($fh, $file); - if (length $preamble) { - # @p consists of ($linenumber, $source) pairs, so we only want - # to prepend the preamble to the odd numbered elements. - # Additionally, the first two elements are (0, $filename). - $_ = $preamble . $_ for @p[ grep { $_ % 2 } 2 .. $#p ]; - } - $tests += $t; - push @prgs, @p; - - close $fh - or die "Cannot close $file: $!\n"; - } - return ($tests, @prgs); -} - -sub run_multiple_progs { - my $up = shift; - my @prgs; - if ($up) { - # The tests in lib run in a temporary subdirectory of t, and always - # pass in a list of "programs" to run - @prgs = @_; - } - else { - # The tests below t run in t and pass in a file handle. In theory we - # can pass (caller)[1] as the second argument to report errors with - # the filename of our caller, as the handle is always DATA. However, - # line numbers in DATA count from the __END__ token, so will be wrong. - # Which is more confusing than not providing line numbers. So, for now, - # don't provide line numbers. No obvious clean solution - one hack - # would be to seek DATA back to the start and read to the __END__ token, - # but that feels almost like we should just open $0 instead. - - # Not going to rely on undef in list assignment. - my $dummy; - ($dummy, @prgs) = _setup_one_file(shift); - } - my $taint_disabled; - if (! eval {require Config; 1}) { - warn "test.pl had problems loading Config: $@"; - $taint_disabled = ''; - } - else { - $taint_disabled = $Config::Config{taint_disabled}; - } - - my $tmpfile = tempfile(); - - my $count_failures = 0; - my ($file, $line); - - PROGRAM: - while (defined ($line = shift @prgs)) { - $_ = shift @prgs; - unless ($line) { - $file = $_; - if (defined $file) { - print "# From $file\n"; - } - next; - } - my $switch = ""; - my @temps ; - my @temp_path; - if (s/^(\s*-\w+)//) { - $switch = $1; - } - - s/^# NOTE.*\n//mg; # remove any NOTE comments in the content - - # unhide conflict markers - we hide them so that naive - # conflict marker detection logic doesn't get upset with our - # tests. - s/([<=>])CONFLICT\1/$1 x 7/ge; - - my ($prog, $expected) = split(/\nEXPECT(?:\n|$)/, $_, 2); - - my %reason; - foreach my $what (qw(skip todo)) { - $prog =~ s/^#\s*\U$what\E\s*(.*)\n//m and $reason{$what} = $1; - # If the SKIP reason starts ? then it's taken as a code snippet to - # evaluate. This provides the flexibility to have conditional SKIPs - if ($reason{$what} && $reason{$what} =~ s/^\?//) { - my $temp = eval $reason{$what}; - if ($@) { - die "# In \U$what\E code reason:\n# $reason{$what}\n$@"; - } - $reason{$what} = $temp; - } - } - - my $name = ''; - if ($prog =~ s/^#\s*NAME\s+(.+)\n//m) { - $name = $1; - } - elsif (defined $file) { - $name = "test from $file at line $line"; - } - - if ($switch=~/[Tt]/ and $taint_disabled eq "define") { - $reason{skip} ||= "This perl does not support taint"; - } - - if ($reason{skip}) { - SKIP: - { - skip($name ? "$name - $reason{skip}" : $reason{skip}, 1); - } - next PROGRAM; - } - - if ($prog =~ /--FILE--/) { - my @files = split(/\n?--FILE--\s*([^\s\n]*)\s*\n/, $prog) ; - shift @files ; - die "Internal error: test $_ didn't split into pairs, got " . - scalar(@files) . "[" . join("%%%%", @files) ."]\n" - if @files % 2; - while (@files > 2) { - my $filename = shift @files; - my $code = shift @files; - push @temps, $filename; - if ($filename =~ m#(.*)/# && $filename !~ m#^\.\./#) { - require File::Path; - File::Path::mkpath($1); - push(@temp_path, $1); - } - open my $fh, '>', $filename or die "Cannot open $filename: $!\n"; - print $fh $code; - close $fh or die "Cannot close $filename: $!\n"; - } - shift @files; - $prog = shift @files; - } - - open my $fh, '>', $tmpfile or die "Cannot open >$tmpfile: $!"; - print $fh q{ - BEGIN { - push @INC, '.'; - open STDERR, '>&', STDOUT - or die "Can't dup STDOUT->STDERR: $!;"; - } - }; - print $fh "\n#line 1\n"; # So the line numbers don't get messed up. - print $fh $prog,"\n"; - close $fh or die "Cannot close $tmpfile: $!"; - my $results = runperl( stderr => 1, progfile => $tmpfile, - stdin => undef, $up - ? (switches => ["-I$up/lib", $switch], nolib => 1) - : (switches => [$switch]) - ); - my $status = $?; - - # allow expected output to be written as if $prog is on STDIN - $results =~ s/$::tempfile_regexp/-/g; - if ($^O eq 'VMS') { - # some tests will trigger VMS messages that won't be expected - $results =~ s/\n?%[A-Z]+-[SIWEF]-[A-Z]+,.*//; - - # pipes double these sometimes - $results =~ s/\n\n/\n/g; - } - # bison says 'parse error' instead of 'syntax error', - # various yaccs may or may not capitalize 'syntax'. - $results =~ s/^(syntax|parse) error/syntax error/mig; - # allow all tests to run when there are leaks - $results =~ s/Scalars leaked: \d+\n//g; - - # avoid repetition in test expectation files, as this is a common message - $results =~ s/^Execution of - aborted due to compilation errors\.\n//m; - - # trim multiple trailing blanks - $results =~ s/\n+$//; - - $expected =~ s/\n+$//; - my $prefix = ($results =~ s#^PREFIX(\n|$)##) ; - # any special options? (OPTIONS foo bar zap) - my $option_regex = 0; - my $option_random = 0; - my $fatal = $FATAL; - if ($expected =~ s/^OPTIONS? (.+)(?:\n|\Z)//) { - foreach my $option (split(' ', $1)) { - if ($option eq 'regex') { # allow regular expressions - $option_regex = 1; - } - elsif ($option eq 'random') { # all lines match, but in any order - $option_random = 1; - } - elsif ($option eq 'fatal') { # perl should fail - $fatal = 1; - } - elsif ($option eq 'nonfatal') { - # used to turn off default fatal - $fatal = 0; - } - else { - die "$0: Unknown OPTION '$option'\n"; - } - } - } - die "$0: can't have OPTION regex and random\n" - if $option_regex + $option_random > 1; - my $ok = 0; - if ($results =~ s/^SKIPPED\n//) { - print "$results\n" ; - $ok = 1; - } - else { - if ($option_random) { - my @got = sort split "\n", $results; - my @expected = sort split "\n", $expected; - - $ok = "@got" eq "@expected"; - } - elsif ($option_regex) { - $ok = $results =~ /^$expected/; - } - elsif ($prefix) { - $ok = $results =~ /^\Q$expected/; - } - else { - $ok = $results eq $expected; - } - - if ($ok && $fatal && !($status >> 8)) { - $ok = 0; - } - } - - local $::TODO = $reason{todo}; - - unless ($ok) { - my $err_line = ''; - $err_line .= "FILE: $file ; line $line\n" if defined $file; - $err_line .= "PROG: $switch\n$prog\n" . - "EXPECTED:\n$expected\n"; - $err_line .= "EXIT STATUS: != 0\n" if $fatal; - $err_line .= "GOT:\n$results\n"; - $err_line .= "EXIT STATUS: " . ($status >> 8) . "\n" if $fatal; - if ($::TODO) { - $err_line =~ s/^/# /mg; - print $err_line; # Harness can't filter it out from STDERR. - } - else { - print STDERR $err_line; - ++$count_failures; - die "PERL_TEST_ABORT_FIRST_FAILURE set Test Failure" - if $ENV{PERL_TEST_ABORT_FIRST_FAILURE}; - } - } - - if (defined $file) { - _ok($ok, "at $file line $line", $name); - } - else { - # We don't have file and line number data for the test, so report - # errors as coming from our caller. - local $Level = $Level + 1; - ok($ok, $name); - } - - foreach (@temps) { - unlink $_ if $_; - } - foreach (@temp_path) { - File::Path::rmtree $_ if -d $_; - } - } - - if ($count_failures) { - print STDERR <<'EOS'; -# -# Note: 'run_multiple_progs' run has one or more failures -# you can consider setting the environment variable -# PERL_TEST_ABORT_FIRST_FAILURE=1 before running the test -# to stop on the first error. -# -EOS - } - - return; -} - -sub can_ok ($@) { - my($proto, @methods) = @_; - my $class = ref $proto || $proto; - - unless( @methods ) { - return _ok( 0, _where(), "$class->can(...)" ); - } - - my @nok = (); - foreach my $method (@methods) { - local($!, $@); # don't interfere with caller's $@ - # eval sometimes resets $! - eval { $proto->can($method) } || push @nok, $method; - } - - my $name; - $name = @methods == 1 ? "$class->can('$methods[0]')" - : "$class->can(...)"; - - _ok( !@nok, _where(), $name ); -} - - -# Call $class->new( @$args ); and run the result through object_ok. -# See Test::More::new_ok -sub new_ok { - my($class, $args, $obj_name) = @_; - $args ||= []; - $obj_name = "The object" unless defined $obj_name; - - local $Level = $Level + 1; - - my $obj; - my $ok = eval { $obj = $class->new(@$args); 1 }; - my $error = $@; - - if($ok) { - object_ok($obj, $class, $obj_name); - } - else { - ok( 0, "new() died" ); - diag("Error was: $@"); - } - - return $obj; - -} - - -sub isa_ok ($$;$) { - my($object, $class, $obj_name) = @_; - - my $diag; - $obj_name = 'The object' unless defined $obj_name; - my $name = "$obj_name isa $class"; - if( !defined $object ) { - $diag = "$obj_name isn't defined"; - } - else { - my $whatami = ref $object ? 'object' : 'class'; - - # We can't use UNIVERSAL::isa because we want to honor isa() overrides - local($@, $!); # eval sometimes resets $! - my $rslt = eval { $object->isa($class) }; - my $error = $@; # in case something else blows away $@ - - if( $error ) { - if( $error =~ /^Can't call method "isa" on unblessed reference/ ) { - # It's an unblessed reference - $obj_name = 'The reference' unless defined $obj_name; - if( !UNIVERSAL::isa($object, $class) ) { - my $ref = ref $object; - $diag = "$obj_name isn't a '$class' it's a '$ref'"; - } - } - elsif( $error =~ /Can't call method "isa" without a package/ ) { - # It's something that can't even be a class - $obj_name = 'The thing' unless defined $obj_name; - $diag = "$obj_name isn't a class or reference"; - } - else { - die <isa on your object and got some weird error. -This should never happen. Please contact the author immediately. -Here's the error. -$@ -WHOA - } - } - elsif( !$rslt ) { - $obj_name = "The $whatami" unless defined $obj_name; - my $ref = ref $object; - $diag = "$obj_name isn't a '$class' it's a '$ref'"; - } - } - - _ok( !$diag, _where(), $name ); -} - - -sub class_ok { - my($class, $isa, $class_name) = @_; - - # Written so as to count as one test - local $Level = $Level + 1; - if( ref $class ) { - ok( 0, "$class is a reference, not a class name" ); - } - else { - isa_ok($class, $isa, $class_name); - } -} - - -sub object_ok { - my($obj, $isa, $obj_name) = @_; - - local $Level = $Level + 1; - if( !ref $obj ) { - ok( 0, "$obj is not a reference" ); - } - else { - isa_ok($obj, $isa, $obj_name); - } -} - - -# Purposefully avoiding a closure. -sub __capture { - push @::__capture, join "", @_; -} - -sub capture_warnings { - my $code = shift; - - local @::__capture; - local $SIG {__WARN__} = \&__capture; - local $Level = 1; - &$code; - return @::__capture; -} - -# This will generate a variable number of tests. -# Use done_testing() instead of a fixed plan. -sub warnings_like { - my ($code, $expect, $name) = @_; - local $Level = $Level + 1; - - my @w = capture_warnings($code); - - cmp_ok(scalar @w, '==', scalar @$expect, $name); - foreach my $e (@$expect) { - if (ref $e) { - like(shift @w, $e, $name); - } else { - is(shift @w, $e, $name); - } - } - if (@w) { - diag("Saw these additional warnings:"); - diag($_) foreach @w; - } -} - -sub _fail_excess_warnings { - my($expect, $got, $name) = @_; - local $Level = $Level + 1; - # This will fail, and produce diagnostics - is($expect, scalar @$got, $name); - diag("Saw these warnings:"); - diag($_) foreach @$got; -} - -sub warning_is { - my ($code, $expect, $name) = @_; - die sprintf "Expect must be a string or undef, not a %s reference", ref $expect - if ref $expect; - local $Level = $Level + 1; - my @w = capture_warnings($code); - if (@w > 1) { - _fail_excess_warnings(0 + defined $expect, \@w, $name); - } else { - is($w[0], $expect, $name); - } -} - -sub warning_like { - my ($code, $expect, $name) = @_; - die sprintf "Expect must be a regexp object" - unless ref $expect eq 'Regexp'; - local $Level = $Level + 1; - my @w = capture_warnings($code); - if (@w > 1) { - _fail_excess_warnings(0 + defined $expect, \@w, $name); - } else { - like($w[0], $expect, $name); - } -} - -# Set or clear a watchdog timer. The input seconds is: -# zero to clear; -# non-zero to set -# and is multiplied by $ENV{PERL_TEST_TIME_OUT_FACTOR} (default 1; minimum 1). -# Set this variable in your profile for slow boxes, or use it to override the -# timeout temporarily for debugging. -# -# This will figure out a suitable method to implement the timer, but you can -# force it to use an alarm by setting the optional second parameter to -# 'alarm', or to use a separate process (if available on this platform) by -# setting that parameter to 'process'. -# -# It is good practice to CLEAR EVERY WATCHDOG timer. Otherwise the timer -# applies to the entire rest of the file. Even if that works now, new tests -# tend to get added to the end of the file, and people may not notice that -# they are being timed. Those tests may all complete before the timer kills -# them, but then more new tests get added, even further away from the timer -# setting code, with less likelihood of noticing that. Those tests may also -# generally work, but flap on heavily loaded smokers, leading to debugging -# effort that wouldn't have had to be expended if the timer had been cancelled -# in the first place -# -# NOTE: If the test file uses 'threads', then call the watchdog() function -# _AFTER_ the 'threads' module is loaded. -{ # Closure - my $watchdog_process; - my $watchdog_thread; - my $watchdog_alarm; - - # Add END block to terminate and clean up any watchdog - END { watchdog(0); }; - -sub watchdog ($;$) -{ - my $timeout = shift; - - # Cancel any existing timer, so the caller can set multiple ones without - # cancelling first. For safety, handle the case where somehow more than - # one type of watchdog got set. - if ($watchdog_thread) { - $watchdog_thread->kill('KILL'); - undef $watchdog_thread; - } - if ($watchdog_process) { - kill('KILL', $watchdog_process); - undef $watchdog_process; - } - if ($watchdog_alarm) { - alarm(0); - undef $watchdog_alarm; - } - - # We are done if this call was just to cancel - return if $timeout == 0; - - my $method = shift || ""; - - my $timeout_msg = 'Test process timed out - terminating'; - - # Accept either spelling - my $timeout_factor = $ENV{PERL_TEST_TIME_OUT_FACTOR} - || $ENV{PERL_TEST_TIMEOUT_FACTOR} - || 1; - $timeout_factor = 1 if $timeout_factor < 1; - $timeout_factor = $1 if $timeout_factor =~ /^(\d+)$/; - - # Valgrind slows perl way down so give it more time before dying. - $timeout_factor = 10 if $timeout_factor < 10 && $ENV{PERL_VALGRIND}; - - $timeout *= $timeout_factor; - - my $pid_to_kill = $$; # PID for this process - - if ($method eq "alarm") { - goto WATCHDOG_VIA_ALARM; - } - - # shut up use only once warning - my $threads_on = $threads::threads && $threads::threads; - - # Use a watchdog process unless 'threads' is loaded and is killable by a - # signal - if ( ! $threads_on - || (defined $ENV{PERL_SIGNALS} && $ENV{PERL_SIGNALS} eq "unsafe") - || $method eq "process") - { - # On Windows and VMS, try launching a watchdog process - # using system(1, ...) (see perlport.pod). system() returns - # immediately on these platforms with effectively a pid of the new - # process - if ($is_mswin || $is_vms) { - # On Windows, try to get the 'real' PID - if ($is_mswin) { - eval { require Win32; }; - if (defined(&Win32::GetCurrentProcessId)) { - $pid_to_kill = Win32::GetCurrentProcessId(); - } - } - - # If we still have a fake PID, we can't use this method at all - return if ($pid_to_kill <= 0); - - # Launch watchdog process - eval { - local $SIG{'__WARN__'} = sub { - _diag("Watchdog warning: $_[0]"); - }; - my $sig = ($is_vms) ? 'TERM' : 'KILL'; - my $prog = "sleep($timeout);" . - "warn qq/# $timeout_msg" . '\n/;' . - "kill(q/$sig/, $pid_to_kill);"; - - # If we're in taint mode PATH will be tainted - $ENV{PATH} =~ /(.*)/s; - local $ENV{PATH} = untaint_path($1); - - # On Windows use the indirect object plus LIST form to guarantee - # that perl is launched directly rather than via the shell (see - # perlfunc.pod), and ensure that the LIST has multiple elements - # since the indirect object plus COMMANDSTRING form seems to - # hang (see perl #121283). Don't do this on VMS, which doesn't - # support the LIST form at all. - if ($is_mswin) { - my $runperl = which_perl(); - $runperl =~ /(.*)/; - $runperl = $1; - if ($runperl =~ m/\s/) { - $runperl = qq{"$runperl"}; - } - $watchdog_process = - system({ $runperl } 1, $runperl, '-e', $prog); - } - else { - my $cmd = _create_runperl(prog => $prog); - $watchdog_process = system(1, $cmd); - } - }; - - if ($@ || $watchdog_process <= 0) { - $@ = "\n$@" if $@; - _diag("Failed to start watchdog$@\nTrying alternate method"); - undef($watchdog_process); - goto WATCHDOG_VIA_ALARM; - } - - return; - } - - # Try using fork() to generate a watchdog process - eval { $watchdog_process = fork() }; - if (defined($watchdog_process)) { - return if $watchdog_process; # Parent process - - ### Watchdog process code - - # Load POSIX if available - eval { require POSIX; }; - - # Execute the timeout - sleep($timeout - 2) if ($timeout > 2); # Workaround for perlbug #49073 - sleep(2); - - # Kill test process if still running - if (kill(0, $pid_to_kill)) { - _diag($timeout_msg); - kill('KILL', $pid_to_kill); - if ($is_cygwin) { - # sometimes the above isn't enough on cygwin - sleep 1; # wait a little, it might have worked after all - system("/bin/kill -f $pid_to_kill") if kill(0, $pid_to_kill); - } - } - - # Don't execute END block (added at beginning of this file) - $NO_ENDING = 1; - - # Terminate ourself (i.e., the watchdog) - POSIX::_exit(1) if (defined(&POSIX::_exit)); - exit(1); - } - - # fork() failed - fall through and try using a thread - } - - # Use a watchdog thread because either 'threads' is loaded, or fork() - # failed - if (eval {require threads; 1}) { - $watchdog_thread = 'threads'->create(sub { - # Load POSIX if available - eval { require POSIX; }; - - $SIG{'KILL'} = sub { threads->exit(); }; - - # Detach after the signal handler is set up; the parent knows - # not to signal until detached. - 'threads'->detach(); - - # Execute the timeout - my $time_left = $timeout; - do { - $time_left = $time_left - sleep($time_left); - } while ($time_left > 0); - - # Kill the parent (and ourself) - select(STDERR); $| = 1; - _diag($timeout_msg); - POSIX::_exit(1) if (defined(&POSIX::_exit)); - my $sig = $is_vms ? 'TERM' : 'KILL'; - kill($sig, $pid_to_kill); - }); - - # Don't proceed until the watchdog has set up its signal handler. - # (Otherwise there is a possibility that we will exit with threads - # running.) The watchdog tells us that the handler is set by - # detaching itself. (The 'is_running()' is a fail-safe.) - while ( $watchdog_thread->is_running() - && ! $watchdog_thread->is_detached()) - { - 'threads'->yield(); - } - - return; - } - - # If everything above fails, then just use an alarm timeout. -WATCHDOG_VIA_ALARM: - if (eval { alarm($timeout); 1; }) { - # Load POSIX if available - eval { require POSIX; }; - - # Alarm handler will do the actual 'killing' - $SIG{'ALRM'} = sub { - select(STDERR); $| = 1; - _diag($timeout_msg); - POSIX::_exit(1) if (defined(&POSIX::_exit)); - my $sig = ($is_vms) ? 'TERM' : 'KILL'; - kill($sig, $pid_to_kill); - }; - $watchdog_alarm = 1; - } -} -} # End closure - -# Orphaned Docker or Linux containers do not necessarily attach to PID 1. They might attach to 0 instead. -sub is_linux_container { - - if ($^O eq 'linux' && open my $fh, '<', '/proc/1/cgroup') { - while(<$fh>) { - if (m{^\d+:pids:(.*)} && $1 ne '/init.scope') { - return 1; - } - } - } - - return 0; -} - -1;