Fix CPAN regressions in Test::Strict and Tree::Object::Hash

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)) {

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

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));
     }
 }

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);
             }

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;
     }

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

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<RuntimeBase> 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<RuntimeBase> seen = Collections.newSetFromMap(new IdentityHashMap<>());
+        java.util.ArrayDeque<RuntimeBase> 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;
+    }
 }

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;
     }

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

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

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();

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();