From afbea8a6d111362f479d469a3f58ec3e6f1684f1 Mon Sep 17 00:00:00 2001 From: "Flavio S. Glock" Date: Sat, 15 Aug 2026 12:58:24 +0200 Subject: [PATCH] fix: improve CPAN compiler and runtime compatibility Fix fixed-prototype trailing commas, nested DATA handle preservation, end-of-scope callback ownership, tied-handler reachability, and DBI metadata statement behavior. Tighten the IO::Async distropref and preserve methods generated by DateTime::Format::Builder during namespace cleanup. Add system-Perl-compatible regression tests and document the completed CPAN compatibility batch. Generated with [Codex](https://openai.com/codex) Co-Authored-By: Codex --- dev/design/jcpan_compiler_tooling_batch.md | 73 +++++++++++++++++++ .../frontend/parser/DataSection.java | 12 +++ .../frontend/parser/PrototypeArgs.java | 14 ++++ .../runtime/CompilationRuntimeState.java | 11 ++- .../runtime/perlmodule/BHooksEndOfScope.java | 16 ++-- .../perlonjava/runtime/perlmodule/DBI.java | 6 ++ .../runtimetypes/ReachabilityWalker.java | 6 ++ .../PerlOnJava/CpanDistroprefs/IO-Async.yml | 2 +- src/main/perl/lib/namespace/autoclean.pm | 6 ++ .../unit/b_hooks_endofscope_require.t | 31 +++++++- .../unit/data_handle_nested_require.t | 24 ++++++ .../resources/unit/dbi_metadata_fetchall.t | 34 +++++++++ .../unit/prototype_trailing_comma_infix.t | 13 ++++ .../unit/refcount/tied_handler_reachability.t | 38 ++++++++++ 14 files changed, 275 insertions(+), 11 deletions(-) create mode 100644 dev/design/jcpan_compiler_tooling_batch.md create mode 100644 src/test/resources/unit/data_handle_nested_require.t create mode 100644 src/test/resources/unit/dbi_metadata_fetchall.t create mode 100644 src/test/resources/unit/prototype_trailing_comma_infix.t create mode 100644 src/test/resources/unit/refcount/tied_handler_reachability.t diff --git a/dev/design/jcpan_compiler_tooling_batch.md b/dev/design/jcpan_compiler_tooling_batch.md new file mode 100644 index 0000000000..ade985659e --- /dev/null +++ b/dev/design/jcpan_compiler_tooling_batch.md @@ -0,0 +1,73 @@ +# CPAN Compiler and Tooling Compatibility Batch + +## Scope + +This batch fixes shared compiler, runtime, and CPAN-tooling behavior exposed by +the following `jcpan` test targets and their dependencies: + +- `Net::Async::SMTP` +- `Group::Git` +- `Locale::CLDR::Locales::Lu` +- `Dist::Zilla::Plugin::Meta::Maintainers` +- `TOML::Tiny` +- `DBIx::Admin::BackupRestore` +- `Number::Phone::NO` + +`WWW::Wikipedia` is excluded because its network-dependent tests also fail +under system Perl. + +## Implemented Fixes + +- Parse a trailing comma after a fixed-prototype argument list before boolean + infix operators, as used by `DBM::Deep`'s `vec` expressions. +- Preserve a caller's populated `DATA` handle while compiling a nested + dependency that temporarily inherits the caller's package. +- Treat tied array and hash handlers as strong reachability edges during the + selective reference-count sweep. +- Associate `B::Hooks::EndOfScope` compile scopes with their owning file so a + nested compile-time `require` cannot attach cleanup callbacks to its caller. +- Make DBI metadata statement handles active and provide DBI's default + `FetchHashKeyName` value. +- Preserve methods generated by `DateTime::Format::Builder` during + `namespace::autoclean` processing. +- Narrow the `IO::Async` distropref match so it cannot patch unrelated + `IO::Async::Resolver::DNS` distributions. + +## Verification + +| Target | Result | +|---|---| +| `Net::Async::SMTP` | PASS: 3 files, 18 tests | +| `Group::Git` | PASS: 7 files, 43 tests | +| `Locale::CLDR::Locales::Lu` | PASS: 1 file, 4 tests | +| `Dist::Zilla::Plugin::Meta::Maintainers` | PASS: 2 files, 2 tests | +| `TOML::Tiny` | PASS: 291 files, 484 tests | +| `DBIx::Admin::BackupRestore` | PASS: 4 files, 15 tests | +| `Number::Phone::NO` | PASS: 10 files, 23 tests | +| `WWW::Wikipedia` under system Perl | FAIL: external API tests; excluded | + +The focused regression tests were validated with system Perl before running +the PerlOnJava build and unit suite. + +## Progress Tracking + +### Current Status: Completed (2026-08-15) + +### Completed Phases + +- [x] Reproduce and classify requested module failures. +- [x] Verify the `WWW::Wikipedia` failures under system Perl. +- [x] Implement shared compiler, runtime, DBI, and CPAN-tooling fixes. +- [x] Add system-Perl-compatible regression coverage. +- [x] Re-run all applicable requested distributions. + +### Next Steps + +1. Monitor the pull request's full CI matrix. + +### Open Questions + +- `Number::Phone::NO` passes, but JVM teardown can emit a non-fatal + `StackOverflowError` while cleaning the very large `DBM::Deep` object graph. + This is separate from test correctness and may warrant a future iterative + teardown improvement. diff --git a/src/main/java/org/perlonjava/frontend/parser/DataSection.java b/src/main/java/org/perlonjava/frontend/parser/DataSection.java index d2c187eb9d..8ecab00a3b 100644 --- a/src/main/java/org/perlonjava/frontend/parser/DataSection.java +++ b/src/main/java/org/perlonjava/frontend/parser/DataSection.java @@ -54,6 +54,18 @@ public static void createPlaceholderDataHandle(Parser parser) { return; // Already created placeholder for this package } + // A nested require starts parsing in the caller's package until the + // loaded file's package declaration is seen. Do not let that + // temporary package context replace the caller's populated DATA + // handle with an empty placeholder. + var existingGlob = GlobalVariable.getExistingGlobalIO(handleName); + RuntimeIO existingIO = existingGlob == null ? null : existingGlob.getRuntimeIO(); + if (existingIO != null + && !(existingIO.ioHandle instanceof org.perlonjava.runtime.io.ClosedIOHandle)) { + state().placeholderCreated.add(handleName); + return; + } + state().placeholderCreated.add(handleName); if (CompilerOptions.DEBUG_ENABLED) parser.ctx.logDebug("Creating placeholder DATA handle for package: " + handleName); diff --git a/src/main/java/org/perlonjava/frontend/parser/PrototypeArgs.java b/src/main/java/org/perlonjava/frontend/parser/PrototypeArgs.java index eb34810351..f55de855ef 100644 --- a/src/main/java/org/perlonjava/frontend/parser/PrototypeArgs.java +++ b/src/main/java/org/perlonjava/frontend/parser/PrototypeArgs.java @@ -341,6 +341,7 @@ static ListNode consumeArgsWithPrototype(Parser parser, String prototype, boolea nextToken.type == LexerTokenType.NEWLINE && !parser.getHeredocNodes().isEmpty(); if (!trailingCommaBeforeHeredoc && !Parser.isExpressionTerminator(nextToken) + && !isInfixOperatorAfterTrailingComma(nextToken) && nextToken.type != LexerTokenType.EOF && !nextToken.text.equals(")")) { throwTooManyArgumentsError(parser); @@ -429,6 +430,19 @@ private static LexerToken tokenAtOrEof(List tokens, int i) { return tokens.get(i); } + /** + * A comma after the final fixed-prototype argument may be followed by an + * infix operator belonging to the enclosing expression. For example, + * DBM::Deep uses {@code vec $mask, $offset, 1, || vec ...}. The comma is + * trailing punctuation for vec(), not the start of a fourth argument. + */ + private static boolean isInfixOperatorAfterTrailingComma(LexerToken token) { + return switch (token.text) { + case "||", "&&", "or", "and", "xor" -> true; + default -> false; + }; + } + private static int firstNonCodeArgIndexAfterAmpersandPrototype(String prototype, ListNode args) { if (prototype == null || args.elements.size() < 2) { return -1; diff --git a/src/main/java/org/perlonjava/runtime/CompilationRuntimeState.java b/src/main/java/org/perlonjava/runtime/CompilationRuntimeState.java index edf938574b..23d861ac34 100644 --- a/src/main/java/org/perlonjava/runtime/CompilationRuntimeState.java +++ b/src/main/java/org/perlonjava/runtime/CompilationRuntimeState.java @@ -43,7 +43,16 @@ public final class CompilationRuntimeState { public final Map> endOfScopeFileCallbacks = new ConcurrentHashMap<>(); public final Deque loadingFileStack = new ArrayDeque<>(); - public final Deque> compileScopes = new ArrayDeque<>(); + public static final class EndOfScopeCompileScope { + public final String ownerFile; + public final Deque callbacks = new ArrayDeque<>(); + + public EndOfScopeCompileScope(String ownerFile) { + this.ownerFile = ownerFile; + } + } + + public final Deque compileScopes = new ArrayDeque<>(); /** UNITCHECK queue belonging to each parser currently compiling a file/eval. */ public final ThreadLocal> unitcheckQueueStack = ThreadLocal.withInitial(ArrayDeque::new); diff --git a/src/main/java/org/perlonjava/runtime/perlmodule/BHooksEndOfScope.java b/src/main/java/org/perlonjava/runtime/perlmodule/BHooksEndOfScope.java index 47e174a896..4916253197 100644 --- a/src/main/java/org/perlonjava/runtime/perlmodule/BHooksEndOfScope.java +++ b/src/main/java/org/perlonjava/runtime/perlmodule/BHooksEndOfScope.java @@ -113,7 +113,8 @@ private static String getCurrentLoadingFile() { /** Enter a parser-visible lexical scope. */ public static void beginCompileScope() { - state().compileScopes.push(new ArrayDeque<>()); + state().compileScopes.push(new CompilationRuntimeState.EndOfScopeCompileScope( + getCurrentLoadingFile())); } /** @@ -121,11 +122,11 @@ public static void beginCompileScope() { * in LIFO order, matching the native hook's ordering. */ public static void endCompileScope() { - Deque> scopes = state().compileScopes; + Deque scopes = state().compileScopes; if (scopes.isEmpty()) { return; } - Deque callbacks = scopes.pop(); + Deque callbacks = scopes.pop().callbacks; while (!callbacks.isEmpty()) { RuntimeScalar codeRef = callbacks.pop(); try { @@ -166,15 +167,14 @@ public static RuntimeList on_scope_end(RuntimeArray args, int ctx) { // Prefer the innermost parser-visible lexical scope. This is the // behavior required by namespace::clean for nested blocks. - Deque> scopes = state().compileScopes; - if (!scopes.isEmpty()) { - scopes.peek().push(codeRef); + String currentFile = getCurrentLoadingFile(); + Deque scopes = state().compileScopes; + if (!scopes.isEmpty() && Objects.equals(scopes.peek().ownerFile, currentFile)) { + scopes.peek().callbacks.push(codeRef); return new RuntimeList(); } // Find which file is currently being loaded - String currentFile = getCurrentLoadingFile(); - if (currentFile != null) { // Register callback for end of file load state().endOfScopeFileCallbacks.computeIfAbsent(currentFile, k -> new ArrayDeque<>()).push(codeRef); diff --git a/src/main/java/org/perlonjava/runtime/perlmodule/DBI.java b/src/main/java/org/perlonjava/runtime/perlmodule/DBI.java index 37582499ab..e532613c79 100644 --- a/src/main/java/org/perlonjava/runtime/perlmodule/DBI.java +++ b/src/main/java/org/perlonjava/runtime/perlmodule/DBI.java @@ -138,6 +138,7 @@ public static RuntimeList connect(RuntimeArray args, int ctx) { // value" on direct assignment. Seen in DBIC t/storage/txn.t line 382. dbh.put("ReadOnly", new RuntimeScalar(false)); dbh.put("AutoCommit", new RuntimeScalar(true)); + dbh.put("FetchHashKeyName", new RuntimeScalar("NAME")); // Handle credentials file if specified in attributes Properties props = new Properties(); @@ -1403,6 +1404,11 @@ private static RuntimeHash createMetadataResultSet(RuntimeHash dbh, ResultSet rs sth.put("NAME_uc", columnNamesUpper.createReference()); sth.put("NUM_OF_FIELDS", new RuntimeScalar(columnCount)); sth.put("Type", new RuntimeScalar("st")); + // Metadata methods return an already-active result set. DBI's Perl + // fetchall_arrayref/fetchall_hashref implementations gate iteration + // on this flag, just like ordinary SELECT statement handles do after + // execute(). + sth.put("Active", new RuntimeScalar(true)); sth.put("Executed", scalarTrue); sth.put("execute_result", result.createReference()); diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/ReachabilityWalker.java b/src/main/java/org/perlonjava/runtime/runtimetypes/ReachabilityWalker.java index ad9169df50..4bd79fa37a 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/ReachabilityWalker.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/ReachabilityWalker.java @@ -272,11 +272,17 @@ private void bfs(java.util.ArrayDeque todo, boolean walkCaptures) { if (cur instanceof RuntimeStash) continue; if (cur instanceof RuntimeHash h) { if (h.elements instanceof HashSpecialVariable) continue; + if (h.elements instanceof TieHash tieHash) { + visitScalar(tieHash.getSelf(), todo); + } for (RuntimeScalar v : h.elements.values()) { addReachable(v, todo); visitScalar(v, todo); } } else if (cur instanceof RuntimeArray a) { + if (a.elements instanceof TieArray tieArray) { + visitScalar(tieArray.getSelf(), todo); + } for (RuntimeScalar v : a.elements) { addReachable(v, todo); visitScalar(v, todo); diff --git a/src/main/perl/lib/PerlOnJava/CpanDistroprefs/IO-Async.yml b/src/main/perl/lib/PerlOnJava/CpanDistroprefs/IO-Async.yml index 1ec87f949d..f8324cfbd1 100644 --- a/src/main/perl/lib/PerlOnJava/CpanDistroprefs/IO-Async.yml +++ b/src/main/perl/lib/PerlOnJava/CpanDistroprefs/IO-Async.yml @@ -8,7 +8,7 @@ comment: | capability so fork/process/routine tests skip instead of failing after the runtime correctly rejects fork(). match: - distribution: "^PEVANS/IO-Async-" + distribution: "^PEVANS/IO-Async-[0-9]" patches: - "IO-Async/NoFork.patch" - "IO-Async/PerlOnJava.patch" diff --git a/src/main/perl/lib/namespace/autoclean.pm b/src/main/perl/lib/namespace/autoclean.pm index 7ede9e2c26..1fd27771c4 100644 --- a/src/main/perl/lib/namespace/autoclean.pm +++ b/src/main/perl/lib/namespace/autoclean.pm @@ -158,6 +158,12 @@ sub _method_check { # target stash, but the coderefs keep Class::XSAccessor::__ANON__ # subnames. Those are generated methods, not imports to clean. return 1 if $code_stash eq 'Class::XSAccessor'; + # DateTime::Format::Builder likewise installs parser methods into the + # target class from factory coderefs whose subnames remain in Builder. + # Nested compile-time dependency loading can defer our scope callback + # until after those methods are installed, so identify the provider as + # a method generator rather than deleting the generated API. + return 1 if $code_stash eq 'DateTime::Format::Builder'; # Companion/helper packages (e.g. DateTime::PP for DateTime) install # functions via glob assignment — these are intentional methods, not imports. # In PerlOnJava, method calls are resolved at runtime through the stash, diff --git a/src/test/resources/unit/b_hooks_endofscope_require.t b/src/test/resources/unit/b_hooks_endofscope_require.t index b0321dc549..296e9d9bc3 100644 --- a/src/test/resources/unit/b_hooks_endofscope_require.t +++ b/src/test/resources/unit/b_hooks_endofscope_require.t @@ -2,7 +2,7 @@ use strict; use warnings; -use Test::More tests => 5; +use Test::More tests => 7; use File::Temp qw(tempdir); use File::Spec; @@ -60,6 +60,21 @@ RequireScopeEndInstaller::install(__PACKAGE__); EOPM close $target_fh; +my $outer_pm = File::Spec->catfile($tmp, 'RequireScopeEndOuter.pm'); +open my $outer_fh, '>', $outer_pm or die "open $outer_pm: $!"; +print {$outer_fh} <<'EOPM'; +package RequireScopeEndOuter; +use strict; +use warnings; + +{ + use RequireScopeEndTarget (); +} + +1; +EOPM +close $outer_fh; + { local @INC = ($tmp, @INC); @@ -84,4 +99,18 @@ close $target_fh; 'generated', 'runtime-installed method remains callable', ); + + delete $INC{'RequireScopeEndTarget.pm'}; + { + no strict 'refs'; + delete ${'RequireScopeEndTarget::'}{'generated'}; + } + + my $outer_loaded = eval { require RequireScopeEndOuter; 1 }; + ok($outer_loaded, 'required module nested inside an outer compile scope loads') + or diag "\$@ = $@"; + ok( + RequireScopeEndTarget->can('generated'), + 'nested require keeps end-of-scope hooks with the required file', + ); } diff --git a/src/test/resources/unit/data_handle_nested_require.t b/src/test/resources/unit/data_handle_nested_require.t new file mode 100644 index 0000000000..2a0d75ce01 --- /dev/null +++ b/src/test/resources/unit/data_handle_nested_require.t @@ -0,0 +1,24 @@ +use strict; +use warnings; +use Test::More tests => 3; +use File::Temp qw(tempdir); + +my $initial_position = tell(DATA); +ok($initial_position > 0, 'DATA starts after its source marker'); + +my $dir = tempdir(CLEANUP => 1); +mkdir "$dir/Local" or die "mkdir $dir/Local: $!"; +open my $module, '>', "$dir/Local/DataHandleDependency.pm" + or die "create dependency: $!"; +print {$module} "package Local::DataHandleDependency; 1;\n"; +close $module or die "close dependency: $!"; + +unshift @INC, $dir; +require Local::DataHandleDependency; + +is(tell(DATA), $initial_position, + 'runtime require does not replace the caller DATA handle'); +is(, "payload\n", 'caller DATA remains readable after runtime require'); + +__DATA__ +payload diff --git a/src/test/resources/unit/dbi_metadata_fetchall.t b/src/test/resources/unit/dbi_metadata_fetchall.t new file mode 100644 index 0000000000..374139992d --- /dev/null +++ b/src/test/resources/unit/dbi_metadata_fetchall.t @@ -0,0 +1,34 @@ +#!/usr/bin/env perl + +use strict; +use warnings; +use Test::More tests => 5; +use File::Temp qw(tempfile); +use DBI; +use DBD::SQLite; + +my ($fh, $db_file) = tempfile(SUFFIX => '.sqlite'); +close $fh; +unlink $db_file; + +my $dbh = DBI->connect( + "dbi:SQLite:dbname=$db_file", '', '', + { RaiseError => 1, AutoCommit => 1 }, +); +is($dbh->{FetchHashKeyName}, 'NAME', 'DBI sets the default hash key name'); +$dbh->do('create table alpha (id int)'); +$dbh->do('create table beta (id int)'); + +my $sth = $dbh->table_info(undef, undef, '%', 'TABLE'); +ok($sth->{Active}, 'table_info returns an active statement handle'); + +my $rows = $sth->fetchall_arrayref({}); +is(ref($rows), 'ARRAY', 'metadata fetchall_arrayref returns an array reference'); +is(scalar(@$rows), 2, 'metadata fetchall_arrayref returns both tables'); +is_deeply( + [ sort map { $_->{TABLE_NAME} } @$rows ], + [qw(alpha beta)], + 'metadata hash rows expose TABLE_NAME', +); + +END { unlink $db_file if defined $db_file } diff --git a/src/test/resources/unit/prototype_trailing_comma_infix.t b/src/test/resources/unit/prototype_trailing_comma_infix.t new file mode 100644 index 0000000000..33ac267a1d --- /dev/null +++ b/src/test/resources/unit/prototype_trailing_comma_infix.t @@ -0,0 +1,13 @@ +#!/usr/bin/env perl + +use strict; +use warnings; +use Test::More tests => 2; + +my $mask = "\x01"; + +my $logical_or = vec $mask, 0, 1, || vec $mask, 1, 1,; +ok($logical_or, 'trailing comma before logical-or ends fixed-prototype arguments'); + +my $logical_and = vec $mask, 0, 1, && !vec $mask, 1, 1,; +ok($logical_and, 'trailing comma before logical-and ends fixed-prototype arguments'); diff --git a/src/test/resources/unit/refcount/tied_handler_reachability.t b/src/test/resources/unit/refcount/tied_handler_reachability.t new file mode 100644 index 0000000000..3c6d9b0749 --- /dev/null +++ b/src/test/resources/unit/refcount/tied_handler_reachability.t @@ -0,0 +1,38 @@ +use strict; +use warnings; +use Scalar::Util qw(weaken); +use Test::More tests => 3; + +{ + package Local::TiedReachability::Storage; + our $DESTROYED = 0; + sub DESTROY { + $_[0]{active} = 0; + $DESTROYED++; + } + + package Local::TiedReachability::Array; + sub TIEARRAY { bless { storage => $_[1] }, $_[0] } + sub FETCHSIZE { 0 } +} + +our $database = []; +our $weak_storage; + +sub build_database { + my $storage = bless { active => 1 }, + 'Local::TiedReachability::Storage'; + $weak_storage = $storage; + weaken($weak_storage); + tie @$database, 'Local::TiedReachability::Array', $storage; +} + +build_database(); +Internals::jperl_gc() if defined &Internals::jperl_gc; + +my $handler = tied(@$database); +ok(defined($weak_storage), 'tied handler keeps its nested object reachable'); +is($handler->{storage}{active}, 1, + 'weak sweep does not destroy an object held by a tied array handler'); +is($Local::TiedReachability::Storage::DESTROYED, 0, + 'nested storage destructor has not fired while the tied array is live');