diff --git a/dev/tools/perl_test_runner.pl b/dev/tools/perl_test_runner.pl index 31f4b544f..1449a93f2 100755 --- a/dev/tools/perl_test_runner.pl +++ b/dev/tools/perl_test_runner.pl @@ -86,7 +86,7 @@ my $total_files = @test_files; print "Found $total_files test files\n"; -print "Running tests with $jperl_path (${jobs} parallel jobs, ${timeout}s timeout)\n"; +print "Running tests with $jperl_path (${jobs} parallel jobs, ${timeout}s base timeout)\n"; print "-" x 60, "\n"; # Run tests in parallel @@ -233,6 +233,13 @@ sub process_test_result { sub run_single_test { my ($test_file) = @_; + # lib/croak.t launches a fresh jperl process for each of its 300+ cases. + # Under a full parallel run it competes with the other workers and has + # repeatedly finished within a second of the normal per-file deadline. + # Give this subprocess-heavy test a stable minimum wall-clock allowance + # while preserving any larger timeout requested by the caller. + my $test_timeout = timeout_for_test($test_file); + # Temporarily disable fatal unimplemented errors # so we can run tests that mix implemented and unimplemented features local $ENV{JPERL_UNIMPLEMENTED} = $test_file =~ m{ @@ -347,10 +354,10 @@ sub run_single_test { my $kill_after = 10; # seconds between SIGTERM and SIGKILL if (!$is_windows) { if (system('which timeout >/dev/null 2>&1') == 0) { - $timeout_cmd = "timeout -k ${kill_after}s ${timeout}s "; + $timeout_cmd = "timeout -k ${kill_after}s ${test_timeout}s "; } elsif (system('which gtimeout >/dev/null 2>&1') == 0) { # macOS with coreutils - $timeout_cmd = "gtimeout -k ${kill_after}s ${timeout}s "; + $timeout_cmd = "gtimeout -k ${kill_after}s ${test_timeout}s "; } } @@ -369,7 +376,7 @@ sub run_single_test { # Fallback to alarm-based timeout eval { local $SIG{ALRM} = sub { die "timeout\n" }; - alarm($timeout); + alarm($test_timeout); $output = `$abs_jperl $test_name 2>&1`; $exit_code = $? >> 8; alarm(0); @@ -408,6 +415,14 @@ sub run_single_test { return $result; } +sub timeout_for_test { + my ($test_file) = @_; + + return 600 if $test_file =~ m{(?:^|/)perl5_t/t/lib/croak\.t$} + && $timeout < 600; + return $timeout; +} + sub start_test_job { my ($test_queue, $children, $total_files, $completed) = @_; @@ -708,7 +723,8 @@ sub print_usage { Options: --jperl PATH Path to jperl executable (default: ./jperl) - --timeout SEC Timeout per test in seconds (default: 3) + --timeout SEC Base timeout per test in seconds (default: 300; selected + subprocess-heavy tests have a documented minimum) --jobs|-j NUM Number of parallel jobs (default: 4) --output FILE Save detailed results to JSON file --help Show this help message diff --git a/src/main/java/org/perlonjava/frontend/parser/SpecialBlockParser.java b/src/main/java/org/perlonjava/frontend/parser/SpecialBlockParser.java index 1f602fc94..d35b53e6e 100644 --- a/src/main/java/org/perlonjava/frontend/parser/SpecialBlockParser.java +++ b/src/main/java/org/perlonjava/frontend/parser/SpecialBlockParser.java @@ -2,6 +2,7 @@ import org.perlonjava.app.cli.CompilerOptions; import org.perlonjava.app.scriptengine.PerlLanguageProvider; +import org.perlonjava.backend.bytecode.VariableCollectorVisitor; import org.perlonjava.backend.jvm.EmitterMethodCreator; import org.perlonjava.frontend.astnode.*; import org.perlonjava.frontend.lexer.LexerTokenType; @@ -14,8 +15,10 @@ import java.util.ArrayDeque; import java.util.BitSet; import java.util.Deque; +import java.util.HashSet; import java.util.List; import java.util.Map; +import java.util.Set; import java.util.Stack; import static org.perlonjava.runtime.runtimetypes.GlobalContext.GLOBAL_PHASE; @@ -246,6 +249,10 @@ static RuntimeList runSpecialBlock(Parser parser, String blockPhase, Node block, // Declare capture variables Map outerVars = parser.ctx.symbolTable.getAllVisibleVariables(); + Set usedVars = new HashSet<>(); + VariableCollectorVisitor collector = new VariableCollectorVisitor(usedVars); + block.accept(collector); + boolean captureAllVisibleVariables = collector.hasEvalString(); for (SymbolTable.SymbolEntry entry : outerVars.values()) { if (!entry.name().equals("@_") && !entry.decl().isEmpty()) { // Skip lexical subs (entries starting with &) - they are stored as hidden variables @@ -257,6 +264,9 @@ static RuntimeList runSpecialBlock(Parser parser, String blockPhase, Node block, || "$@%*".indexOf(entry.name().charAt(0)) < 0) { continue; } + if (!captureAllVisibleVariables && !usedVars.contains(entry.name())) { + continue; + } String packageName; boolean isFromOuterScope = false; diff --git a/src/main/java/org/perlonjava/runtime/operators/Readline.java b/src/main/java/org/perlonjava/runtime/operators/Readline.java index 639ca37ce..856c92860 100644 --- a/src/main/java/org/perlonjava/runtime/operators/Readline.java +++ b/src/main/java/org/perlonjava/runtime/operators/Readline.java @@ -111,9 +111,11 @@ public static RuntimeScalar readline(RuntimeIO runtimeIO) { return readParagraphMode(runtimeIO); } - if (rs != null && rs.isRecordLengthMode()) { + int recordLength = rs != null && rs.isRecordLengthMode() + ? rs.getRecordLength() + : recordLengthFromLocalizedSeparator(rsScalar); + if (recordLength > 0) { // Handle record length mode when $/ = \N - int recordLength = rs.getRecordLength(); return readFixedLength(runtimeIO, recordLength); } @@ -135,6 +137,31 @@ public static RuntimeScalar readline(RuntimeIO runtimeIO) { } } + /** + * A dynamically localized special variable is represented by the saved + * global binding rather than by the original InputRecordSeparator + * subclass. Preserve Perl's $/ = \N mode across that representation + * change. + */ + private static int recordLengthFromLocalizedSeparator(RuntimeScalar separator) { + if (separator.type != RuntimeScalarType.REFERENCE + || !(separator.value instanceof RuntimeScalar referenced)) { + return -1; + } + if (referenced.type == RuntimeScalarType.INTEGER) { + return referenced.getInt(); + } + if (referenced.type == RuntimeScalarType.STRING + || referenced.type == RuntimeScalarType.BYTE_STRING) { + try { + return Integer.parseInt(referenced.toString()); + } catch (NumberFormatException ignored) { + return -1; + } + } + return -1; + } + private static RuntimeScalar readParagraphMode(RuntimeIO runtimeIO) { boolean isByteMode = runtimeIO.isByteMode(); StringBuilder paragraph = new StringBuilder(); diff --git a/src/test/resources/unit/eval_begin_lexical_storage.t b/src/test/resources/unit/eval_begin_lexical_storage.t new file mode 100644 index 000000000..d40dc1890 --- /dev/null +++ b/src/test/resources/unit/eval_begin_lexical_storage.t @@ -0,0 +1,27 @@ +use strict; +use warnings; +use Scalar::Util qw(refaddr); +use Test::More tests => 6; + +my %defaults = (value => 1); + +sub make_inside_out_object { + my ($class) = @_; + my $object = bless \my($anonymous_scalar), $class; + my $value = eval '$defaults{value}'; + die $@ if $@; + return ($object, $value); +} + +my ($first, $first_value) = make_inside_out_object('First'); +my ($second, $second_value) = make_inside_out_object('Second'); + +is $first_value, 1, 'runtime eval sees the enclosing file lexical'; +is $second_value, 1, 'runtime eval keeps working on later calls'; +isnt refaddr($first), refaddr($second), 'referenced my scalar is fresh on each call'; +is ref($first), 'First', 'first object keeps its original class'; +is ref($second), 'Second', 'second object receives its requested class'; + +$defaults{value} = 2; +my (undef, $updated_value) = make_inside_out_object('Third'); +is $updated_value, 2, 'runtime eval observes updates without persistent local cells'; diff --git a/src/test/resources/unit/input_record_separator_fixed_length.t b/src/test/resources/unit/input_record_separator_fixed_length.t new file mode 100644 index 000000000..83eb519d7 --- /dev/null +++ b/src/test/resources/unit/input_record_separator_fixed_length.t @@ -0,0 +1,23 @@ +use strict; +use warnings; +use Test::More tests => 8; + +my $data = "abcdef"; +open my $fh, '<', \$data or die $!; + +{ + local $/ = \1; + is scalar($fh->getline), 'a', 'localized fixed-length separator reads one character'; + is tell($fh), 1, 'fixed-length getline advances by one character'; +} + +{ + local $/ = \2; + is scalar($fh->getline), 'bc', 'localized fixed-length separator accepts larger records'; + is tell($fh), 3, 'larger fixed-length getline advances by the record size'; + is scalar($fh->getline), 'de', 'fixed-length mode remains active for repeated reads'; + is scalar($fh->getline), 'f', 'final short record is returned'; + is scalar($fh->getline), undef, 'read after the final record returns undef'; +} + +is $/, "\n", 'localized input record separator is restored'; diff --git a/src/test/resources/unit/source_filter_subroutine_lexical_storage.t b/src/test/resources/unit/source_filter_subroutine_lexical_storage.t new file mode 100644 index 000000000..db68c0f01 --- /dev/null +++ b/src/test/resources/unit/source_filter_subroutine_lexical_storage.t @@ -0,0 +1,26 @@ +use strict; +use warnings; +use Test::More tests => 5; +use Scalar::Util qw(refaddr); +use Filter::Simple; + +# A no-op filter is enough to exercise the rewritten-source compiler path. +FILTER { }; + +sub make_filtered_inside_out_object { + my ($class) = @_; + return bless \my($anonymous_scalar), $class; +} + +# Source-filter preprocessing used to leave the subroutine's lexical in the +# shared symbol table, where later BEGIN blocks classified it as persistent. +BEGIN { my $compile_time_only = 1 } + +my $first = make_filtered_inside_out_object('FilteredFirst'); +my $second = make_filtered_inside_out_object('FilteredSecond'); + +isnt refaddr($first), refaddr($second), 'filtered sub creates a fresh scalar referent'; +is ref($first), 'FilteredFirst', 'first filtered object keeps its class'; +is ref($second), 'FilteredSecond', 'second filtered object gets its class'; +isnt "$first", "$second", 'filtered objects remain distinct'; +pass 'later BEGIN block does not make a filtered sub lexical persistent';