From bb640201c6e15fe9f0a901bbb22bc631b4bd196c Mon Sep 17 00:00:00 2001 From: "Flavio S. Glock" Date: Thu, 28 May 2026 21:26:31 +0200 Subject: [PATCH 1/3] fix: unblock Test::Strict and Tree::Object::Hash Keep CPAN helper metadata out of distribution roots during test runs so manifest checks do not see PerlOnJava's temporary PERL5LIB file. Fix Storable round-tripping for top-level blessed scalar refs, validate typed backslash prototypes, and keep already-owned scalar refs alive when they are blessed in a second step. Generated with [Codex](https://openai.com/codex/) Co-Authored-By: Codex --- .../frontend/parser/PrototypeArgs.java | 65 +++++++++++++++++++ .../runtime/operators/ReferenceOperators.java | 12 +++- .../runtime/perlmodule/storable/Blessed.java | 6 ++ .../perlmodule/storable/StorableWriter.java | 6 +- .../runtimetypes/MyVarCleanupStack.java | 13 ++++ src/main/perl/lib/CPAN/Distribution.pm | 4 +- src/main/perl/lib/ExtUtils/MM_PerlOnJava.pm | 2 +- src/main/perl/lib/ExtUtils/MakeMaker.pm | 2 +- .../unit/bless_existing_scalar_ref_destroy.t | 38 +++++++++++ .../unit/prototype_backslash_typecheck.t | 21 ++++++ .../unit/storable_top_blessed_scalar_ref.t | 24 +++++++ 11 files changed, 188 insertions(+), 5 deletions(-) create mode 100644 src/test/resources/unit/bless_existing_scalar_ref_destroy.t create mode 100644 src/test/resources/unit/prototype_backslash_typecheck.t create mode 100644 src/test/resources/unit/storable_top_blessed_scalar_ref.t diff --git a/src/main/java/org/perlonjava/frontend/parser/PrototypeArgs.java b/src/main/java/org/perlonjava/frontend/parser/PrototypeArgs.java index 39f11cbbb..fe2d8d4f3 100644 --- a/src/main/java/org/perlonjava/frontend/parser/PrototypeArgs.java +++ b/src/main/java/org/perlonjava/frontend/parser/PrototypeArgs.java @@ -1104,6 +1104,9 @@ private static int handleBackslashArgument(Parser parser, ListNode args, String // but \my(@bar) should produce an ARRAYREFERENCE, same as \my @bar. // Unwrap the ListNode so we get OperatorNode("my", OperatorNode("@")). referenceArg = unwrapMyListDeclaration(referenceArg); + + validateBackslashPrototypeArgument(parser, args, refType, referenceArg); + // For \& prototype, check for invalid forms like &foo(), foo(), or bareword foo if (refType == '&') { String subName = parser.ctx.symbolTable.getCurrentSubroutine(); @@ -1211,6 +1214,68 @@ private static int handleBackslashArgument(Parser parser, ListNode args, String return prototypeIndex; // Return index of ']'; caller's i++ advances past it } + private static void validateBackslashPrototypeArgument(Parser parser, ListNode args, char refType, Node referenceArg) { + if (refType != '$' && refType != '@' && refType != '%') { + return; + } + + Character actualSigil = sigilForBackslashPrototypeArg(referenceArg); + if (actualSigil == null || actualSigil == refType) { + return; + } + + String expected = switch (refType) { + case '$' -> "scalar"; + case '@' -> "array"; + case '%' -> "hash"; + default -> "reference"; + }; + String subName = parser.ctx.symbolTable.getCurrentSubroutine(); + String subNamePart = (subName == null || subName.isEmpty()) ? "" : " to " + subName; + parser.throwError("Type of arg " + (args.elements.size() + 1) + subNamePart + + " must be " + expected + " (not " + describeBackslashPrototypeArg(referenceArg) + ")"); + } + + private static Character sigilForBackslashPrototypeArg(Node node) { + if (!(node instanceof OperatorNode opNode)) { + return null; + } + if (opNode.operator.equals("$") || opNode.operator.equals("@") || opNode.operator.equals("%")) { + return opNode.operator.charAt(0); + } + if (opNode.operator.equals("my") || opNode.operator.equals("our") || opNode.operator.equals("local")) { + return sigilForBackslashPrototypeArg(opNode.operand); + } + return null; + } + + private static String describeBackslashPrototypeArg(Node node) { + String prefix = ""; + while (node instanceof OperatorNode opNode + && (opNode.operator.equals("my") || opNode.operator.equals("our") || opNode.operator.equals("local"))) { + if (opNode.operator.equals("my")) { + prefix = "private "; + } else if (opNode.operator.equals("our")) { + prefix = "our "; + } else { + prefix = "local "; + } + node = opNode.operand; + } + + Character sigil = sigilForBackslashPrototypeArg(node); + if (sigil != null) { + String type = switch (sigil) { + case '$' -> "scalar"; + case '@' -> "array"; + case '%' -> "hash"; + default -> "reference"; + }; + return prefix + type; + } + return prefix + "constant item"; + } + public static boolean consumeCommaIfPresent(Parser parser, boolean isOptional) { LexerToken peeked = TokenUtils.peek(parser); if (!isComma(peeked)) { diff --git a/src/main/java/org/perlonjava/runtime/operators/ReferenceOperators.java b/src/main/java/org/perlonjava/runtime/operators/ReferenceOperators.java index 78c7b51dc..856597c73 100644 --- a/src/main/java/org/perlonjava/runtime/operators/ReferenceOperators.java +++ b/src/main/java/org/perlonjava/runtime/operators/ReferenceOperators.java @@ -154,7 +154,17 @@ public static RuntimeScalar bless(RuntimeScalar runtimeScalar, RuntimeScalar cla // statement boundary flushes, fixing method chain temporaries // like `Foo->new()->method()` where the invocant was never // tracked. - referent.refCount = 1; + boolean existingScalarOwner = + runtimeScalar.type == RuntimeScalarType.REFERENCE + && !runtimeScalar.refCountOwned + && (runtimeScalar instanceof GlobalRuntimeScalar + || GlobalVariable.globalVariables.containsValue(runtimeScalar) + || MyVarCleanupStack.isRegistered(runtimeScalar)); + referent.refCount = existingScalarOwner ? 2 : 1; + if (existingScalarOwner) { + referent.recordOwner(runtimeScalar, "first bless of existing scalar ref"); + runtimeScalar.refCountOwned = true; + } MortalList.deferDecrement(referent); } // Activate the mortal mechanism diff --git a/src/main/java/org/perlonjava/runtime/perlmodule/storable/Blessed.java b/src/main/java/org/perlonjava/runtime/perlmodule/storable/Blessed.java index 53adb8abe..3db2d5efb 100644 --- a/src/main/java/org/perlonjava/runtime/perlmodule/storable/Blessed.java +++ b/src/main/java/org/perlonjava/runtime/perlmodule/storable/Blessed.java @@ -67,6 +67,9 @@ public static RuntimeScalar readBless(StorableReader r, StorableContext c) { // not a ref-to-ref). The cost: `freeze \$blessed_ref` // round-trips with one level lost. See item 8 in // dev/modules/storable_binary_format.md. + if (!org.perlonjava.runtime.runtimetypes.RuntimeScalarType.isReference(inner)) { + inner = inner.createReference(); + } return ReferenceOperators.bless(inner, new RuntimeScalar(classname)); } @@ -94,6 +97,9 @@ public static RuntimeScalar readIxBless(StorableReader r, StorableContext c) { String classname = c.getClass(ix); RuntimeScalar inner = r.dispatch(c); // See readBless above for the bare-container-flag rationale. + if (!org.perlonjava.runtime.runtimetypes.RuntimeScalarType.isReference(inner)) { + inner = inner.createReference(); + } return ReferenceOperators.bless(inner, new RuntimeScalar(classname)); } } diff --git a/src/main/java/org/perlonjava/runtime/perlmodule/storable/StorableWriter.java b/src/main/java/org/perlonjava/runtime/perlmodule/storable/StorableWriter.java index a6b2067b4..848b47596 100644 --- a/src/main/java/org/perlonjava/runtime/perlmodule/storable/StorableWriter.java +++ b/src/main/java/org/perlonjava/runtime/perlmodule/storable/StorableWriter.java @@ -87,7 +87,11 @@ private void emitTopLevel(StorableContext c, RuntimeScalar value) { // wrapping in the output) and matches the corresponding // upstream `do_store` → `store` flow. if (value.type == RuntimeScalarType.REFERENCE) { - dispatch(c, (RuntimeScalar) value.value); + if (RuntimeScalarType.blessedId(value) != 0) { + dispatchReferent(c, value); + } else { + dispatch(c, (RuntimeScalar) value.value); + } } else { dispatchReferent(c, value); } diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/MyVarCleanupStack.java b/src/main/java/org/perlonjava/runtime/runtimetypes/MyVarCleanupStack.java index 78217be4d..e7b53d4c8 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/MyVarCleanupStack.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/MyVarCleanupStack.java @@ -49,6 +49,19 @@ public static boolean isLive(Object var) { return liveCounts.containsKey(var); } + /** + * True when {@code var} is currently registered as a lexical, regardless + * of whether weak-ref tracking has populated {@link #liveCounts}. Used by + * first-bless paths that can run before the first {@code weaken()} call. + */ + public static boolean isRegistered(Object var) { + if (var == null) return false; + for (Object entry : stack) { + if (entry == var) return true; + } + return false; + } + /** * Snapshot the currently-live my-variables. Used by the * reachability walker's per-object query diff --git a/src/main/perl/lib/CPAN/Distribution.pm b/src/main/perl/lib/CPAN/Distribution.pm index d53004817..614dadbc1 100644 --- a/src/main/perl/lib/CPAN/Distribution.pm +++ b/src/main/perl/lib/CPAN/Distribution.pm @@ -4022,7 +4022,9 @@ sub test { $self->debug("Changed directory to $self->{build_dir}") if $CPAN::DEBUG; - if (open my $perlonjava_perl5lib_fh, ">", ".perlonjava-cpan-perl5lib") { + mkdir "blib" unless -d "blib"; + unlink ".perlonjava-cpan-perl5lib"; + if (open my $perlonjava_perl5lib_fh, ">", "blib/.perlonjava-cpan-perl5lib") { print {$perlonjava_perl5lib_fh} $ENV{PERL5LIB} || ""; close $perlonjava_perl5lib_fh; } diff --git a/src/main/perl/lib/ExtUtils/MM_PerlOnJava.pm b/src/main/perl/lib/ExtUtils/MM_PerlOnJava.pm index 79ba1b7b7..8a902e21a 100644 --- a/src/main/perl/lib/ExtUtils/MM_PerlOnJava.pm +++ b/src/main/perl/lib/ExtUtils/MM_PerlOnJava.pm @@ -109,7 +109,7 @@ sub test { # Use "undef *Test::Harness::Switches" to disable the default -w switch, # matching standard ExtUtils::MakeMaker behavior (MM_Any::test_via_harness) return <<"MAKE_FRAG"; -PERLONJAVA_CPAN_PERL5LIB = \$(shell test -f .perlonjava-cpan-perl5lib && cat .perlonjava-cpan-perl5lib) +PERLONJAVA_CPAN_PERL5LIB = \$(shell if test -f blib/.perlonjava-cpan-perl5lib; then cat blib/.perlonjava-cpan-perl5lib; elif test -f .perlonjava-cpan-perl5lib; then cat .perlonjava-cpan-perl5lib; fi) PERLONJAVA_TEST_PERL5LIB = \$(INST_LIB):\$(INST_ARCHLIB):\$(PERLONJAVA_CPAN_PERL5LIB):\$\$PERL5LIB test :: pure_all diff --git a/src/main/perl/lib/ExtUtils/MakeMaker.pm b/src/main/perl/lib/ExtUtils/MakeMaker.pm index bc4dad269..e1634dffe 100644 --- a/src/main/perl/lib/ExtUtils/MakeMaker.pm +++ b/src/main/perl/lib/ExtUtils/MakeMaker.pm @@ -889,7 +889,7 @@ INST_LIB = $inst_lib INST_ARCHLIB = $inst_archlib INST_LIBDIR = \$(INST_LIB) INST_ARCHLIBDIR = \$(INST_ARCHLIB) -PERLONJAVA_CPAN_PERL5LIB = \$(shell test -f .perlonjava-cpan-perl5lib && cat .perlonjava-cpan-perl5lib) +PERLONJAVA_CPAN_PERL5LIB = \$(shell if test -f blib/.perlonjava-cpan-perl5lib; then cat blib/.perlonjava-cpan-perl5lib; elif test -f .perlonjava-cpan-perl5lib; then cat .perlonjava-cpan-perl5lib; fi) PERLONJAVA_TEST_PERL5LIB = \$(INST_LIB):\$(INST_ARCHLIB):\$(PERLONJAVA_CPAN_PERL5LIB):\$\$PERL5LIB $siteprefix_var INSTALLSITELIB = $installsitelib diff --git a/src/test/resources/unit/bless_existing_scalar_ref_destroy.t b/src/test/resources/unit/bless_existing_scalar_ref_destroy.t new file mode 100644 index 000000000..f86027865 --- /dev/null +++ b/src/test/resources/unit/bless_existing_scalar_ref_destroy.t @@ -0,0 +1,38 @@ +use strict; +use warnings; +use Test::More; +use Scalar::Util qw(refaddr); + +our @destroyed; + +{ + package BlessExistingScalarRef; + sub DESTROY { push @main::destroyed, Scalar::Util::refaddr($_[0]) } +} + +sub make_two_step { + my $obj = \(my $value); + bless $obj, 'BlessExistingScalarRef'; + return $obj; +} + +my $obj = make_two_step(); +my $addr = refaddr($obj); + +is_deeply(\@destroyed, [], 'two-step blessed scalar ref is not destroyed before caller receives it'); + +undef $obj; + +is_deeply(\@destroyed, [$addr], 'two-step blessed scalar ref is destroyed when caller drops it'); + +our $global = \(my $global_value); +bless $global, 'BlessExistingScalarRef'; +my $global_addr = refaddr($global); + +is_deeply(\@destroyed, [$addr], 'global two-step blessed scalar ref survives bless statement'); + +undef $global; + +is_deeply(\@destroyed, [$addr, $global_addr], 'global two-step blessed scalar ref is destroyed on undef'); + +done_testing(); diff --git a/src/test/resources/unit/prototype_backslash_typecheck.t b/src/test/resources/unit/prototype_backslash_typecheck.t new file mode 100644 index 000000000..fa721bde7 --- /dev/null +++ b/src/test/resources/unit/prototype_backslash_typecheck.t @@ -0,0 +1,21 @@ +use strict; +use warnings; +use Test::More; + +sub wants_hash_ref(\%) { scalar keys %{ $_[0] } } +sub wants_array_ref(\@) { scalar @{ $_[0] } } + +my $hash_error = eval q{ wants_hash_ref my @not_hash; 1 }; +ok(!$hash_error, 'hash prototype rejects private array argument'); +like($@, qr/must be hash/i, 'hash prototype reports hash requirement'); + +my $array_error = eval q{ wants_array_ref my %not_array; 1 }; +ok(!$array_error, 'array prototype rejects private hash argument'); +like($@, qr/must be array/i, 'array prototype reports array requirement'); + +my %hash = (a => 1, b => 2); +my @array = (1, 2, 3); +is(wants_hash_ref(%hash), 2, 'hash prototype still accepts hash variables'); +is(wants_array_ref(@array), 3, 'array prototype still accepts array variables'); + +done_testing(); diff --git a/src/test/resources/unit/storable_top_blessed_scalar_ref.t b/src/test/resources/unit/storable_top_blessed_scalar_ref.t new file mode 100644 index 000000000..6410de983 --- /dev/null +++ b/src/test/resources/unit/storable_top_blessed_scalar_ref.t @@ -0,0 +1,24 @@ +use strict; +use warnings; +use Test::More; +use Scalar::Util qw(blessed reftype refaddr); +use Storable qw(freeze thaw); + +{ + package StorableTopBlessedScalar; + + sub new { + my ($class, $value) = @_; + return bless \$value, $class; + } +} + +my $obj = StorableTopBlessedScalar->new('alive'); +my $copy = thaw(freeze($obj)); + +is(blessed($copy), 'StorableTopBlessedScalar', 'top-level blessed scalar ref keeps its class'); +is(reftype($copy), 'SCALAR', 'top-level blessed scalar ref keeps scalar reftype'); +is($$copy, 'alive', 'top-level blessed scalar ref keeps referent value'); +isnt(refaddr($copy), refaddr($obj), 'top-level blessed scalar ref thaw creates a distinct object'); + +done_testing(); From 5b4e47fbd6a3692c3c674f11f9f9e951004a54bb Mon Sep 17 00:00:00 2001 From: "Flavio S. Glock" Date: Thu, 28 May 2026 21:35:24 +0200 Subject: [PATCH 2/3] fix: preserve CPAN::Changes and Text::Unidecode behavior Handle PerlOnJava surrogate markers as a single logical character in negated regex character classes so Text::Unidecode can load surrogate-bank tables. Preserve Sub::Quote/Sub::Defer metadata captured through deferred CODE refs during quiet weak-ref sweeps, which keeps CPAN::Changes metadata lookups alive at statement boundaries. Generated with [Codex](https://openai.com/codex/) Co-Authored-By: Codex --- .../runtime/regex/RegexPreprocessor.java | 9 +- .../runtimetypes/ReachabilityWalker.java | 87 +++++++++++++++++++ .../unit/refcount/sub_quote_qsub_metadata.t | 21 +++++ .../unit/regex_surrogate_marker_charclass.t | 20 +++++ 4 files changed, 136 insertions(+), 1 deletion(-) create mode 100644 src/test/resources/unit/refcount/sub_quote_qsub_metadata.t create mode 100644 src/test/resources/unit/regex_surrogate_marker_charclass.t diff --git a/src/main/java/org/perlonjava/runtime/regex/RegexPreprocessor.java b/src/main/java/org/perlonjava/runtime/regex/RegexPreprocessor.java index 5a550f2a7..b24fbb4f5 100644 --- a/src/main/java/org/perlonjava/runtime/regex/RegexPreprocessor.java +++ b/src/main/java/org/perlonjava/runtime/regex/RegexPreprocessor.java @@ -1478,7 +1478,7 @@ private static int handleBranchReset(String s, int offset, int length, StringBui private static int handleCharacterClass(String s, boolean flag_xx, StringBuilder sb, int c, int offset) { final int length = s.length(); - int len = sb.length(); + int classStart = sb.length(); sb.append(Character.toChars(c)); // Append the '[' offset++; @@ -1533,6 +1533,13 @@ private static int handleCharacterClass(String s, boolean flag_xx, StringBuilder StringBuilder rejected = new StringBuilder(); offset = RegexPreprocessorHelper.handleRegexCharacterClassEscape(offset, s, sb, length, flag_xx, rejected); + String processedClass = sb.substring(classStart); + if (processedClass.startsWith("[^")) { + sb.setLength(classStart); + sb.append("(?:\\x{FFFD}<[0-9A-F]+>|"); + sb.append(processedClass); + sb.append(')'); + } // Note: rejected is kept for future use but currently \b is handled by direct substitution to \x08 return offset; } diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/ReachabilityWalker.java b/src/main/java/org/perlonjava/runtime/runtimetypes/ReachabilityWalker.java index 27d07cb88..34f02b5e5 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/ReachabilityWalker.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/ReachabilityWalker.java @@ -222,6 +222,7 @@ private void visitCodeCaptures(RuntimeCode code, addReachable(cap, todo); visitScalar(cap, todo); }); + visitReflectiveCodeBases(code, base -> addReachable(base, todo)); if (code instanceof org.perlonjava.backend.bytecode.InterpretedCode interpreted && interpreted.capturedVars != null) { for (RuntimeBase cap : interpreted.capturedVars) { @@ -1209,6 +1210,16 @@ private static boolean followGlobalCodeCaptures(RuntimeCode code, RuntimeBase ta } }); if (foundReflectiveCapture[0]) return true; + final boolean[] foundReflectiveBase = {false}; + visitReflectiveCodeBases(code, base -> { + if (foundReflectiveBase[0]) return; + if (base == target) { + foundReflectiveBase[0] = true; + } else if (seen.add(base)) { + todo.addLast(base); + } + }); + if (foundReflectiveBase[0]) return true; if (code instanceof org.perlonjava.backend.bytecode.InterpretedCode interpreted && interpreted.capturedVars != null) { for (RuntimeBase cap : interpreted.capturedVars) { @@ -1243,6 +1254,28 @@ private static void visitReflectiveCodeScalars(RuntimeCode code, } } + private static void visitReflectiveCodeBases(RuntimeCode code, + java.util.function.Consumer visitor) { + Object closureObject = code.codeObject != null ? code.codeObject : code.subroutine; + if (closureObject == null) return; + try { + for (java.lang.reflect.Field field : closureObject.getClass().getDeclaredFields()) { + Class fieldType = field.getType(); + if (fieldType != RuntimeScalar.class + && RuntimeBase.class.isAssignableFrom(fieldType)) { + RuntimeBase cap = (RuntimeBase) field.get(closureObject); + if (cap != null) { + visitor.accept(cap); + } + } + } + } catch (IllegalAccessException ignored) { + // Generated closure fields are public. If another implementation + // denies reflective access, callers still have capturedScalars and + // interpreter capturedVars metadata as fallbacks. + } + } + /** * Run a reachability sweep and clear weak refs for unreachable objects. * Called from {@code Internals::jperl_gc()} explicitly. @@ -1318,6 +1351,19 @@ public static int sweepWeakRefs(boolean quiet) { continue; } } + // Quiet auto-sweeps can run while a deferred CODE ref is being + // returned to its caller. Sub::Quote stores weak registry + // entries in hashes/arrays that are strongly captured by that + // CODE, but the caller's lexical may not be visible as a root + // yet. Keep this exception limited to unblessed metadata + // containers and only for quiet statement-boundary sweeps; + // explicit jperl_gc() keeps the stricter root-based behavior. + if (quiet + && referent.blessId == 0 + && (referent instanceof RuntimeHash || referent instanceof RuntimeArray) + && isCapturedByWeakBackrefCode(referent)) { + continue; + } toClear.add(referent); } } @@ -1347,4 +1393,45 @@ public static int sweepWeakRefs(boolean quiet) { } return cleared; } + + private static boolean isCapturedByWeakBackrefCode(RuntimeBase target) { + for (RuntimeBase referent : WeakRefRegistry.snapshotWeakRefReferents()) { + if (referent instanceof RuntimeCode code + && WeakRefRegistry.hasWeakRefsTo(code) + && isReachableThroughCodeCaptures(code, target)) { + return true; + } + } + return false; + } + + private static boolean isReachableThroughCodeCaptures(RuntimeCode code, RuntimeBase target) { + Set seen = Collections.newSetFromMap(new IdentityHashMap<>()); + java.util.ArrayDeque todo = new java.util.ArrayDeque<>(); + if (followGlobalCodeCaptures(code, target, seen, todo)) return true; + + int visits = 0; + final int MAX_VISITS = 10_000; + while (!todo.isEmpty() && visits++ < MAX_VISITS) { + RuntimeBase cur = todo.removeFirst(); + if (cur == target) return true; + if (cur instanceof RuntimeStash) { + continue; + } else if (cur instanceof RuntimeHash h) { + if (h.elements instanceof HashSpecialVariable) continue; + for (RuntimeScalar v : h.elements.values()) { + if (followScalar(v, target, seen, todo)) return true; + } + } else if (cur instanceof RuntimeArray a) { + for (RuntimeScalar v : a.elements) { + if (followScalar(v, target, seen, todo)) return true; + } + } else if (cur instanceof RuntimeCode nestedCode) { + if (followGlobalCodeCaptures(nestedCode, target, seen, todo)) return true; + } else if (cur instanceof RuntimeScalar s) { + if (followScalar(s, target, seen, todo)) return true; + } + } + return false; + } } diff --git a/src/test/resources/unit/refcount/sub_quote_qsub_metadata.t b/src/test/resources/unit/refcount/sub_quote_qsub_metadata.t new file mode 100644 index 000000000..ab163cbab --- /dev/null +++ b/src/test/resources/unit/refcount/sub_quote_qsub_metadata.t @@ -0,0 +1,21 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; + +BEGIN { + eval { + require Sub::Quote; + Sub::Quote->import(qw(qsub quoted_from_sub unquote_sub)); + 1; + } or plan skip_all => 'Sub::Quote not available'; +} + +plan tests => 3; + +my $quoted = qsub q{ $_[0] }; +ok(quoted_from_sub($quoted), 'qsub metadata survives after deferred sub creation'); + +my $unquoted = unquote_sub($quoted); +ok($unquoted, 'qsub can be unquoted after metadata lookup'); +is($unquoted->('ok'), 'ok', 'unquoted qsub remains callable'); diff --git a/src/test/resources/unit/regex_surrogate_marker_charclass.t b/src/test/resources/unit/regex_surrogate_marker_charclass.t new file mode 100644 index 000000000..4c5b2fdab --- /dev/null +++ b/src/test/resources/unit/regex_surrogate_marker_charclass.t @@ -0,0 +1,20 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More tests => 4; + +no warnings 'utf8'; + +my $surrogate = chr(0xD800); +my ($captured) = $surrogate =~ /([^\x00-\x7f])/; + +ok(defined $captured, 'negated character class matches surrogate scalar'); +is(ord($captured), 0xD800, 'capture preserves surrogate scalar code point'); + +my $replaced = $surrogate; +$replaced =~ s/([^\x00-\x7f])/sprintf('[%04X]', ord($1))/eg; +is($replaced, '[D800]', 'substitution consumes the whole surrogate marker'); + +my $pair = chr(0xD800) . chr(0xDFFF); +$pair =~ s/([^\x00-\x7f])/sprintf('%04X', ord($1))/eg; +is($pair, 'D800DFFF', 'global substitution handles adjacent surrogate markers'); From 998d6a0877ea3297247d3e4933abbdf9603619c2 Mon Sep 17 00:00:00 2001 From: "Flavio S. Glock" Date: Thu, 28 May 2026 22:26:32 +0200 Subject: [PATCH 3/3] test: avoid optional Sub::Quote skip in unit test Make the Sub::Quote metadata regression test self-contained when the CPAN module is not installed. The embedded Gradle unit runner treats Test::More's skip_all exit as an execution failure, so the test now uses a minimal Sub::Quote-shaped fallback instead of exiting. Generated with [Codex](https://openai.com/codex/) Co-Authored-By: Codex --- .../unit/refcount/sub_quote_qsub_metadata.t | 51 +++++++++++++++++-- 1 file changed, 48 insertions(+), 3 deletions(-) diff --git a/src/test/resources/unit/refcount/sub_quote_qsub_metadata.t b/src/test/resources/unit/refcount/sub_quote_qsub_metadata.t index ab163cbab..4d2d26048 100644 --- a/src/test/resources/unit/refcount/sub_quote_qsub_metadata.t +++ b/src/test/resources/unit/refcount/sub_quote_qsub_metadata.t @@ -4,16 +4,61 @@ use warnings; use Test::More; BEGIN { - eval { + if (!eval { require Sub::Quote; Sub::Quote->import(qw(qsub quoted_from_sub unquote_sub)); 1; - } or plan skip_all => 'Sub::Quote not available'; + }) { + require Scalar::Util; + + our %QUOTED; + + *qsub = sub { + my ($code) = @_; + my $quoted_info = { code => $code }; + my $unquoted; + Scalar::Util::weaken($quoted_info->{unquoted} = \$unquoted); + + my $deferred; + $deferred = sub { + $unquoted if 0; + goto &{ unquote_sub($quoted_info->{deferred}) }; + }; + + Scalar::Util::weaken($quoted_info->{deferred} = $deferred); + Scalar::Util::weaken($QUOTED{$deferred} = $quoted_info); + return $deferred; + }; + + *quoted_from_sub = sub { + my ($sub) = @_; + my $quoted_info = $QUOTED{$sub || ''} or return undef; + my $unquoted = $quoted_info->{unquoted}; + $unquoted &&= $$unquoted; + return [ undef, $quoted_info->{code}, undef, $unquoted, $quoted_info->{deferred} ]; + }; + + *unquote_sub = sub { + my ($sub) = @_; + my $quoted_info = $QUOTED{$sub} or return undef; + my $unquoted = $quoted_info->{unquoted}; + unless ($unquoted && $$unquoted) { + my $_QUOTED = $quoted_info; + my $_UNQUOTED = $unquoted; + $$unquoted = sub { + ($_QUOTED, $_UNQUOTED) if 0; + return $_[0]; + }; + Scalar::Util::weaken($QUOTED{$$unquoted} = $quoted_info); + } + return $$unquoted; + }; + } } plan tests => 3; -my $quoted = qsub q{ $_[0] }; +my $quoted = qsub(q{ $_[0] }); ok(quoted_from_sub($quoted), 'qsub metadata survives after deferred sub creation'); my $unquoted = unquote_sub($quoted);