diff --git a/src/main/java/org/perlonjava/backend/bytecode/BytecodeCompiler.java b/src/main/java/org/perlonjava/backend/bytecode/BytecodeCompiler.java index 600e5e030..d087ebdfa 100644 --- a/src/main/java/org/perlonjava/backend/bytecode/BytecodeCompiler.java +++ b/src/main/java/org/perlonjava/backend/bytecode/BytecodeCompiler.java @@ -4544,7 +4544,10 @@ void compileVariableReference(OperatorNode node, String op) { // Cache the RuntimeScalar code reference at compile time. // This matches Perl's behavior where the CV (code value) is cached // in the compiled bytecode, surviving stash entry deletion. - RuntimeScalar codeRef = GlobalVariable.getGlobalCodeRef(subName); + Object parseTimeCodeRef = node.getAnnotation("parseTimeCodeRef"); + RuntimeScalar codeRef = parseTimeCodeRef instanceof RuntimeScalar runtimeScalar + ? runtimeScalar + : GlobalVariable.getGlobalCodeRefForFreshLookup(subName); // Allocate register and load from constant pool int rd = allocateOutputRegister(); @@ -4558,7 +4561,7 @@ void compileVariableReference(OperatorNode node, String op) { } else if (node.operand instanceof StringNode strNode) { // Symbolic ref: &{'name'} — look up global code reference by string name String globalName = NameNormalizer.normalizeVariableName(strNode.value, getCurrentPackage()); - RuntimeScalar codeRef = GlobalVariable.getGlobalCodeRef(globalName); + RuntimeScalar codeRef = GlobalVariable.getGlobalCodeRefForFreshLookup(globalName); int rd = allocateOutputRegister(); int constIdx = addToConstantPool(codeRef); emit(Opcodes.LOAD_CONST); @@ -4597,7 +4600,10 @@ void compileVariableReference(OperatorNode node, String op) { // loading, so defined(\&Name) returns true String subName = NameNormalizer.normalizeVariableName( idNode.name, getCurrentPackage()); - RuntimeScalar codeRef = GlobalVariable.getGlobalCodeRef(subName); + Object parseTimeCodeRef = operandOp.getAnnotation("parseTimeCodeRef"); + RuntimeScalar codeRef = parseTimeCodeRef instanceof RuntimeScalar runtimeScalar + ? runtimeScalar + : GlobalVariable.getGlobalCodeRefForFreshLookup(subName); if (codeRef.type == RuntimeScalarType.CODE && codeRef.value instanceof RuntimeCode rc) { rc.isSymbolicReference = true; diff --git a/src/main/java/org/perlonjava/backend/jvm/Dereference.java b/src/main/java/org/perlonjava/backend/jvm/Dereference.java index 255237083..5bfcf9c60 100644 --- a/src/main/java/org/perlonjava/backend/jvm/Dereference.java +++ b/src/main/java/org/perlonjava/backend/jvm/Dereference.java @@ -971,11 +971,21 @@ static void handleArrowOperator(EmitterVisitor emitterVisitor, BinaryOperatorNod // Allocate a unique callsite ID for inline method caching int callsiteId = nextMethodCallsiteId++; - // Set debug line number to the call site (the object/receiver expression), - // so that caller() inside the called method reports the correct source line. - // Without this, the JVM frame reports the line of the closing ')' instead. - if (node.left.getIndex() > 0) { - ByteCodeSourceMapper.setDebugInfoLineNumber(emitterVisitor.ctx, node.left.getIndex()); + // Set debug line number to the whole method call. Perl's caller() + // reports the closing line for a multi-line call expression, which + // is carried by the "->" node or its argument ListNode. + int callSiteIndex = node.getIndex(); + if (node.right instanceof BinaryOperatorNode callNode + && "(".equals(callNode.operator) + && callNode.right != null + && callNode.right.getIndex() > 0) { + callSiteIndex = callNode.right.getIndex(); + } + if (callSiteIndex <= 0 && node.left.getIndex() > 0) { + callSiteIndex = node.left.getIndex(); + } + if (callSiteIndex > 0) { + ByteCodeSourceMapper.setDebugInfoLineNumber(emitterVisitor.ctx, callSiteIndex); } mv.visitLdcInsn(callsiteId); diff --git a/src/main/java/org/perlonjava/backend/jvm/EmitSubroutine.java b/src/main/java/org/perlonjava/backend/jvm/EmitSubroutine.java index 207f7f670..ed01cfcf3 100644 --- a/src/main/java/org/perlonjava/backend/jvm/EmitSubroutine.java +++ b/src/main/java/org/perlonjava/backend/jvm/EmitSubroutine.java @@ -11,9 +11,11 @@ import org.perlonjava.frontend.semantic.ScopedSymbolTable; import org.perlonjava.frontend.semantic.SymbolTable; import org.perlonjava.runtime.runtimetypes.NameNormalizer; +import org.perlonjava.runtime.runtimetypes.GlobalVariable; import org.perlonjava.runtime.runtimetypes.RuntimeBase; import org.perlonjava.runtime.runtimetypes.RuntimeCode; import org.perlonjava.runtime.runtimetypes.RuntimeContextType; +import org.perlonjava.runtime.runtimetypes.RuntimeScalar; import java.util.Arrays; import java.util.HashSet; @@ -523,7 +525,19 @@ static void handleApplyOperator(EmitterVisitor emitterVisitor, BinaryOperatorNod } } - node.left.accept(emitterVisitor.with(RuntimeContextType.SCALAR)); // Target - left parameter: Code ref + if (node.left instanceof OperatorNode operatorNode + && operatorNode.operator.equals("&") + && operatorNode.getAnnotation("parseTimeCodeRef") instanceof RuntimeScalar codeRef) { + int codeRefId = GlobalVariable.registerCompiledCodeRef(codeRef); + mv.visitLdcInsn(codeRefId); + mv.visitMethodInsn(Opcodes.INVOKESTATIC, + "org/perlonjava/runtime/runtimetypes/GlobalVariable", + "getCompiledCodeRef", + "(I)Lorg/perlonjava/runtime/runtimetypes/RuntimeScalar;", + false); + } else { + node.left.accept(emitterVisitor.with(RuntimeContextType.SCALAR)); // Target - left parameter: Code ref + } // Dereference the scalar to get the CODE reference if needed // When we have &$x() the left side is OperatorNode("$") (the & is consumed by the parser) @@ -710,11 +724,35 @@ static void handleApplyOperator(EmitterVisitor emitterVisitor, BinaryOperatorNod } } - // Set debug line number to the call site (the function name/reference expression), - // so that caller() inside the called subroutine reports the correct source line. - // Without this, the JVM frame reports the line of the closing ')' instead. - if (node.left != null && node.left.getIndex() > 0) { - ByteCodeSourceMapper.setDebugInfoLineNumber(emitterVisitor.ctx, node.left.getIndex()); + // Undefined direct-call diagnostics report the line containing the + // function token, while caller() inside a successfully entered sub sees + // the completed call expression's closing line. Keep those as two + // separate bytecode locations. + int errorSiteIndex = node.left != null && node.left.getIndex() > 0 + ? node.left.getIndex() + : (node.getIndex() > 0 ? node.getIndex() : -1); + if (errorSiteIndex > 0) { + ByteCodeSourceMapper.setDebugInfoLineNumber(emitterVisitor.ctx, errorSiteIndex); + } + + mv.visitVarInsn(Opcodes.ALOAD, codeRefSlot); + mv.visitVarInsn(Opcodes.ALOAD, nameSlot); + mv.visitMethodInsn( + Opcodes.INVOKESTATIC, + "org/perlonjava/runtime/runtimetypes/RuntimeCode", + "throwIfDirectCallUndefined", + "(Lorg/perlonjava/runtime/runtimetypes/RuntimeScalar;Ljava/lang/String;)V", + false); + + // Set debug line number to the call site. Perl reports the line where a + // multi-line call expression completes for caller(), not the line + // containing the function name. The argument ListNode is indexed at the + // closing token. + int callSiteIndex = node.right != null && node.right.getIndex() > 0 + ? node.right.getIndex() + : (node.getIndex() > 0 ? node.getIndex() : (node.left != null ? node.left.getIndex() : -1)); + if (callSiteIndex > 0) { + ByteCodeSourceMapper.setDebugInfoLineNumber(emitterVisitor.ctx, callSiteIndex); } mv.visitVarInsn(Opcodes.ALOAD, codeRefSlot); diff --git a/src/main/java/org/perlonjava/frontend/parser/PrototypeArgs.java b/src/main/java/org/perlonjava/frontend/parser/PrototypeArgs.java index 0c71d7104..c5f183eb5 100644 --- a/src/main/java/org/perlonjava/frontend/parser/PrototypeArgs.java +++ b/src/main/java/org/perlonjava/frontend/parser/PrototypeArgs.java @@ -292,6 +292,10 @@ static ListNode consumeArgsWithPrototype(Parser parser, String prototype, boolea parser.throwError("syntax error"); } + // Preserve the end of the parsed argument list for call-site line + // reporting. caller() uses this to match Perl's behavior for + // multi-line direct sub calls. + args.setIndex(parser.tokenIndex); return args; } diff --git a/src/main/java/org/perlonjava/frontend/parser/SubroutineParser.java b/src/main/java/org/perlonjava/frontend/parser/SubroutineParser.java index d1a7ee803..484e5acb7 100644 --- a/src/main/java/org/perlonjava/frontend/parser/SubroutineParser.java +++ b/src/main/java/org/perlonjava/frontend/parser/SubroutineParser.java @@ -177,8 +177,10 @@ static Node parseSubroutineCall(Parser parser, boolean isMethod) { boolean subExists = isNewMethod; String prototype = null; List attributes = null; + RuntimeScalar parseTimeCodeRef = null; if (!isNewMethod && !isMethod && GlobalVariable.existsGlobalCodeRef(fullName)) { RuntimeScalar codeRef = GlobalVariable.getGlobalCodeRef(fullName); + parseTimeCodeRef = codeRef; if (codeRef.value instanceof RuntimeCode runtimeCode) { prototype = runtimeCode.prototype; attributes = runtimeCode.attributes; @@ -549,8 +551,12 @@ && isValidIndirectMethod(subName, parser) } // Rewrite and return the subroutine call as `&name(arguments)` + OperatorNode codeRefNode = new OperatorNode("&", nameNode, currentIndex); + if (parseTimeCodeRef != null) { + codeRefNode.setAnnotation("parseTimeCodeRef", parseTimeCodeRef); + } return new BinaryOperatorNode("(", - new OperatorNode("&", nameNode, currentIndex), + codeRefNode, arguments, currentIndex); } finally { diff --git a/src/main/java/org/perlonjava/runtime/operators/ModuleOperators.java b/src/main/java/org/perlonjava/runtime/operators/ModuleOperators.java index d34617ad9..05e8ebc45 100644 --- a/src/main/java/org/perlonjava/runtime/operators/ModuleOperators.java +++ b/src/main/java/org/perlonjava/runtime/operators/ModuleOperators.java @@ -523,61 +523,23 @@ else if (code == null) { // Check if this @INC entry is a CODE reference, ARRAY reference, or blessed object if (isHook) { - RuntimeBase hookResult = tryIncHook(dirScalar, fileName); + RuntimeList hookResult = tryIncHook(dirScalar, fileName); if (hookResult != null) { - // Hook returned something useful - RuntimeScalar hookResultScalar = hookResult.scalar(); - - // 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 resultArray) { - if (resultArray.size() > 0) { - RuntimeScalar firstElem = resultArray.get(0); - if (firstElem.type == RuntimeScalarType.GLOB || - firstElem.type == RuntimeScalarType.GLOBREFERENCE) { - filehandle = firstElem; - } + IncHookSource hookSource; + try { + hookSource = readIncHookSource(hookResult); + } catch (PerlExitException e) { + throw e; + } catch (Throwable t) { + if (isRequire && setINC) { + getGlobalHash("main::INC").elements.put(fileName, new RuntimeScalar()); } + GlobalVariable.setGlobalVariable("main::@", findInnermostCause(t).getMessage()); + return new RuntimeScalar(); } - - if (filehandle != null) { - // Read content from the filehandle using the same method as STEP 4 - try { - code = Readline.readline(filehandle, RuntimeContextType.LIST).toString(); - actualFileName = fileName; - incHookRef = dirScalar; - break; - } catch (Exception e) { - // Continue to next @INC entry - } - } else if (hookResultScalar.type == RuntimeScalarType.CODE) { - // Hook returned a CODE reference (line-reader sub) - // Perl calls this repeatedly; the sub sets $_ to each line - // and returns true for more data, false to stop - RuntimeCode lineReader = (RuntimeCode) hookResultScalar.value; - RuntimeScalar dollarUnderscore = GlobalVariable.getGlobalVariable("main::_"); - StringBuilder codeBuilder = new StringBuilder(); - while (true) { - RuntimeArray readerArgs = new RuntimeArray(); - RuntimeBase result = lineReader.apply(readerArgs, RuntimeContextType.SCALAR); - if (result == null || !result.scalar().getBoolean()) { - break; - } - codeBuilder.append(dollarUnderscore.toString()).append("\n"); - } - code = codeBuilder.toString(); + if (hookSource != null) { + code = hookSource.code; + shouldApplyFilters = shouldApplyFilters || hookSource.applySourceFilters; actualFileName = fileName; incHookRef = dirScalar; break; @@ -985,16 +947,18 @@ public static RuntimeScalar require(RuntimeScalar runtimeScalar) { * *

The hook can return: *

* * @param hook The @INC hook (CODE, ARRAY, or blessed reference) * @param fileName The file name being required - * @return The result from the hook (undef, filehandle, or array ref), or null if hook can't be called + * @return The list returned by the hook, or null if hook can't handle this file */ - private static RuntimeBase tryIncHook(RuntimeScalar hook, String fileName) { + private static RuntimeList tryIncHook(RuntimeScalar hook, String fileName) { RuntimeCode codeRef = null; RuntimeScalar selfArg = hook; @@ -1057,13 +1021,189 @@ else if (hook.type == RuntimeScalarType.ARRAYREFERENCE && hook.value instanceof // Call the hook - if it throws an exception, propagate it // This matches Perl's behavior where die() in an @INC hook stops require - RuntimeBase result = codeRef.apply(args, RuntimeContextType.SCALAR); + RuntimeList result = codeRef.apply(args, RuntimeContextType.LIST); - // If result is undef, return null to continue to next @INC entry - if (result == null || !result.scalar().defined().getBoolean()) { + // If result is empty or undef, return null to continue to next @INC entry + if (result == null || result.isEmpty() + || (result.size() == 1 && !result.scalar().defined().getBoolean())) { return null; } return result; } -} \ No newline at end of file + + private static class IncHookSource { + final String code; + final boolean applySourceFilters; + + IncHookSource(String code, boolean applySourceFilters) { + this.code = code; + this.applySourceFilters = applySourceFilters; + } + } + + private static IncHookSource readIncHookSource(RuntimeList hookResult) { + if (hookResult == null || hookResult.isEmpty()) { + return null; + } + + // Keep compatibility with older internal handling that accepted an + // array ref from hooks, while the documented Perl API returns a list. + if (hookResult.size() == 1) { + RuntimeScalar scalar = hookResult.scalar(); + if (scalar.type == RuntimeScalarType.ARRAYREFERENCE + && scalar.value instanceof RuntimeArray array) { + return readIncHookSource(array); + } + } + + return readIncHookSource(new IncHookValues(hookResult)); + } + + private static IncHookSource readIncHookSource(RuntimeArray hookResult) { + if (hookResult == null || hookResult.size() == 0) { + return null; + } + + return readIncHookSource(new IncHookValues(hookResult)); + } + + private static IncHookSource readIncHookSource(IncHookValues values) { + StringBuilder prefix = new StringBuilder(); + RuntimeScalar filehandle = null; + RuntimeCode sourceSub = null; + RuntimeScalar state = null; + + RuntimeScalar first = values.get(0); + if (first == null || !first.defined().getBoolean()) { + return null; + } + + if (isFilehandle(first)) { + filehandle = first; + } else if (first.type == RuntimeScalarType.REFERENCE) { + RuntimeScalar deref = first.scalarDeref(); + if (deref != null) { + prefix.append(deref); + } + } else if (first.type == RuntimeScalarType.CODE) { + sourceSub = (RuntimeCode) first.value; + } else { + return null; + } + + RuntimeScalar second = values.get(1); + if (second != null && isFilehandle(second)) { + filehandle = second; + } + + RuntimeScalar third = values.get(2); + if (third != null && third.type == RuntimeScalarType.CODE) { + sourceSub = (RuntimeCode) third.value; + } + + state = values.get(3); + + if (filehandle != null) { + String body = readIncHookFilehandle(filehandle, sourceSub, state); + return new IncHookSource(prefix + body, true); + } + + if (sourceSub != null) { + return new IncHookSource(prefix + readIncHookGenerator(sourceSub, state), true); + } + + if (!prefix.isEmpty()) { + return new IncHookSource(prefix.toString(), true); + } + + return null; + } + + private static String readIncHookFilehandle(RuntimeScalar filehandle, RuntimeCode filterSub, RuntimeScalar state) { + if (filterSub == null) { + return Readline.readline(filehandle, RuntimeContextType.LIST).toString(); + } + + StringBuilder codeBuilder = new StringBuilder(); + RuntimeScalar savedDefaultVar = GlobalVariable.getGlobalVariable("main::_"); + try { + RuntimeBase lineBase; + while ((lineBase = Readline.readline(filehandle, RuntimeContextType.SCALAR)) != null) { + RuntimeScalar line = lineBase.scalar(); + if (line.type == RuntimeScalarType.UNDEF) { + break; + } + + GlobalVariable.aliasGlobalVariable("main::_", new RuntimeScalar(line.toString())); + RuntimeBase result = filterSub.apply(incHookFilterArgs(state), RuntimeContextType.SCALAR); + if (result != null && result.scalar().defined().getBoolean() + && !result.scalar().getBoolean()) { + break; + } + codeBuilder.append(GlobalVariable.getGlobalVariable("main::_")); + } + } finally { + GlobalVariable.aliasGlobalVariable("main::_", savedDefaultVar); + } + return codeBuilder.toString(); + } + + private static String readIncHookGenerator(RuntimeCode sourceSub, RuntimeScalar state) { + StringBuilder codeBuilder = new StringBuilder(); + RuntimeScalar savedDefaultVar = GlobalVariable.getGlobalVariable("main::_"); + try { + while (true) { + GlobalVariable.aliasGlobalVariable("main::_", new RuntimeScalar("")); + RuntimeBase result = sourceSub.apply(incHookFilterArgs(state), RuntimeContextType.SCALAR); + if (result == null || !result.scalar().getBoolean()) { + break; + } + String line = GlobalVariable.getGlobalVariable("main::_").toString(); + codeBuilder.append(line); + if (!line.endsWith("\n")) { + codeBuilder.append("\n"); + } + } + } finally { + GlobalVariable.aliasGlobalVariable("main::_", savedDefaultVar); + } + return codeBuilder.toString(); + } + + private static RuntimeArray incHookFilterArgs(RuntimeScalar state) { + RuntimeArray args = new RuntimeArray(); + args.push(new RuntimeScalar(0)); + if (state != null) { + args.push(state); + } + return args; + } + + private static boolean isFilehandle(RuntimeScalar scalar) { + return scalar.type == RuntimeScalarType.GLOB + || scalar.type == RuntimeScalarType.GLOBREFERENCE; + } + + private static class IncHookValues { + private final RuntimeList list; + private final RuntimeArray array; + + IncHookValues(RuntimeList list) { + this.list = list; + this.array = null; + } + + IncHookValues(RuntimeArray array) { + this.list = null; + this.array = array; + } + + RuntimeScalar get(int index) { + if (list != null) { + return index < list.size() ? list.elements.get(index).scalar() : null; + } + return index < array.size() ? array.get(index) : null; + } + } +} diff --git a/src/main/java/org/perlonjava/runtime/perlmodule/DBI.java b/src/main/java/org/perlonjava/runtime/perlmodule/DBI.java index d290987bc..b9da07d66 100644 --- a/src/main/java/org/perlonjava/runtime/perlmodule/DBI.java +++ b/src/main/java/org/perlonjava/runtime/perlmodule/DBI.java @@ -800,7 +800,8 @@ private static int extractSqlType(RuntimeScalar attr) { * - INTEGER → Long (preserves exact integer values) * - DOUBLE → Long if whole number, else Double (matches Perl's stringification: 10.0 → "10") * - UNDEF → null (SQL NULL) - * - STRING/BYTE_STRING → String + * - STRING → String + * - BYTE_STRING → String for valid UTF-8 bytes, byte[] for binary bytes * - References/blessed objects → String via toString() (triggers overload "" if present) */ private static Object toJdbcValue(RuntimeScalar scalar) { @@ -829,9 +830,9 @@ private static Object toJdbcValue(RuntimeScalar scalar) { // INSERT: bytes → UTF-8 decode → chars → JDBC → SQLite // SELECT: SQLite → JDBC → chars → UTF-8 encode → bytes (same) // - // If the bytes are not valid UTF-8 (e.g., raw Latin-1 like "\xE9"), we - // fall back to passing the char values as-is. This preserves the current - // behavior for non-UTF-8 byte strings. + // If the bytes are not valid UTF-8, pass them as bytes. Passing the + // ISO-8859-1 carrier String to JDBC makes drivers encode high bytes as + // UTF-8 text, corrupting binary payloads such as Storable streams. String s = (String) scalar.value; byte[] rawBytes = s.getBytes(StandardCharsets.ISO_8859_1); String decoded = new String(rawBytes, StandardCharsets.UTF_8); @@ -840,7 +841,7 @@ private static Object toJdbcValue(RuntimeScalar scalar) { if (decoded.indexOf('\uFFFD') < 0) { yield decoded; } else { - yield s; + yield rawBytes; } } default -> scalar.toString(); // Triggers overload "" for blessed refs @@ -1387,4 +1388,4 @@ public static RuntimeList get_info(RuntimeArray args, int ctx) { private interface DBIOperation { RuntimeList execute() throws Exception; } -} \ No newline at end of file +} diff --git a/src/main/java/org/perlonjava/runtime/perlmodule/Universal.java b/src/main/java/org/perlonjava/runtime/perlmodule/Universal.java index ebfb7c1fe..f1b10205e 100644 --- a/src/main/java/org/perlonjava/runtime/perlmodule/Universal.java +++ b/src/main/java/org/perlonjava/runtime/perlmodule/Universal.java @@ -183,13 +183,13 @@ public static RuntimeList can(RuntimeArray args, int ctx) { String normalizedName = NameNormalizer.normalizeVariableName(methodName, perlClassName); if (GlobalVariable.existsGlobalCodeRef(normalizedName)) { RuntimeScalar codeRef = GlobalVariable.getGlobalCodeRef(normalizedName); - if (codeRef.getDefinedBoolean()) { + if (codeRef.value instanceof RuntimeCode rc && rc.isDeclared) { return codeRef.getList(); } - // Forward declarations (sub foo;) should be visible to can() - // even though defined(&foo) returns false. - // Perl 5: can() returns a code ref for forward-declared subs. - if (codeRef.value instanceof RuntimeCode rc && rc.isDeclared) { + if (codeRef.value instanceof RuntimeCode rc && rc.defined()) { + return codeRef.getList(); + } + if (!(codeRef.value instanceof RuntimeCode) && codeRef.getDefinedBoolean()) { return codeRef.getList(); } } diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/GlobalVariable.java b/src/main/java/org/perlonjava/runtime/runtimetypes/GlobalVariable.java index 576fcd028..1c14dd4cc 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/GlobalVariable.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/GlobalVariable.java @@ -39,6 +39,9 @@ public class GlobalVariable { // and should survive stash deletion. This matches Perl's behavior where // compiled bytecode holds direct references to CVs that survive stash deletion. private static final Map pinnedCodeRefs = new HashMap<>(); + private static final Set deletedCodeRefPins = new HashSet<>(); + private static final Map compiledCodeRefs = new HashMap<>(); + private static int nextCompiledCodeRefId = 1; // Stash aliasing: `*{Dst::} = *{Src::}` effectively makes Dst:: symbol table // behave like Src:: for method lookup and stash operations. @@ -124,6 +127,9 @@ public static void resetAllGlobals() { globalHashes.clear(); globalCodeRefs.clear(); pinnedCodeRefs.clear(); + deletedCodeRefPins.clear(); + compiledCodeRefs.clear(); + nextCompiledCodeRefId = 1; globalIORefs.clear(); globalFormatRefs.clear(); globalGlobs.clear(); @@ -649,37 +655,17 @@ public static RuntimeScalar getGlobalCodeRef(String key) { } } } - // First check if we have a pinned reference that survives stash deletion + // First check if we have a pinned reference that survives stash deletion. + // Runtime lookups emitted into already-compiled code use this path so + // those call sites keep their original CV even after delete $Pkg::{sub}. RuntimeScalar pinned = pinnedCodeRefs.get(key); if (pinned != null) { - // Return the pinned ref so compiled code keeps working, but do NOT - // re-add to globalCodeRefs. If it was deleted from the stash (e.g., by - // namespace::clean), that deletion should be respected for method - // resolution via can() and the inheritance hierarchy. return pinned; } RuntimeScalar var = globalCodeRefs.get(key); if (var == null) { - var = new RuntimeScalar(); - var.type = RuntimeScalarType.CODE; // value is null - RuntimeCode runtimeCode = new RuntimeCode((String) null, null); - - // Parse the key to extract package and subroutine names - // key format is typically "Package::SubroutineName" - int lastColonIndex = key.lastIndexOf("::"); - if (lastColonIndex > 0) { - runtimeCode.packageName = key.substring(0, lastColonIndex); - runtimeCode.subName = key.substring(lastColonIndex + 2); - } else { - runtimeCode.packageName = "main"; - runtimeCode.subName = key; - } - - // Note: We don't set isSymbolicReference here by default - // It will be set specifically for \&{string} patterns in createCodeReference - - var.value = runtimeCode; + var = createEmptyCodeRef(key); globalCodeRefs.put(key, var); } @@ -689,6 +675,62 @@ public static RuntimeScalar getGlobalCodeRef(String key) { return var; } + private static RuntimeScalar createEmptyCodeRef(String key) { + RuntimeScalar var = new RuntimeScalar(); + var.type = RuntimeScalarType.CODE; // value is null + RuntimeCode runtimeCode = new RuntimeCode((String) null, null); + + // Parse the key to extract package and subroutine names + // key format is typically "Package::SubroutineName" + int lastColonIndex = key.lastIndexOf("::"); + if (lastColonIndex > 0) { + runtimeCode.packageName = key.substring(0, lastColonIndex); + runtimeCode.subName = key.substring(lastColonIndex + 2); + } else { + runtimeCode.packageName = "main"; + runtimeCode.subName = key; + } + + // Note: We don't set isSymbolicReference here by default + // It will be set specifically for \&{string} patterns in createCodeReference + + var.value = runtimeCode; + return var; + } + + /** + * Looks up a CODE slot for newly compiled/eval'd code. Unlike + * getGlobalCodeRef(), this must not resurrect an old pinned CV after + * delete $Pkg::{sub}; it should see the currently visible stash. + */ + public static RuntimeScalar getGlobalCodeRefForFreshLookup(String key) { + if (key == null) { + return new RuntimeScalar(); + } + if (!stashAliases.isEmpty()) { + String resolvedKey = resolveAliasedFqn(key); + if (resolvedKey != key) { + RuntimeScalar resolvedVar = globalCodeRefs.get(resolvedKey); + if (resolvedVar != null) { + if (!deletedCodeRefPins.contains(resolvedKey)) { + pinnedCodeRefs.put(resolvedKey, resolvedVar); + } + return resolvedVar; + } + } + } + + RuntimeScalar var = globalCodeRefs.get(key); + if (var == null) { + var = createEmptyCodeRef(key); + globalCodeRefs.put(key, var); + } + if (!deletedCodeRefPins.contains(key)) { + pinnedCodeRefs.put(key, var); + } + return var; + } + /** * Retrieves a global code reference for the purpose of DEFINING code. * Unlike getGlobalCodeRef(), this also ensures the entry is visible in @@ -702,14 +744,44 @@ public static RuntimeScalar defineGlobalCodeRef(String key) { // For defines, always resolve through stash aliases: `*Dst:: = *Src::` // followed by `sub Dst::foo {}` should install the sub in Src::foo. String resolvedKey = resolveAliasedFqn(key); - RuntimeScalar ref = getGlobalCodeRef(resolvedKey); + RuntimeScalar ref = globalCodeRefs.get(resolvedKey); + if (ref == null) { + RuntimeScalar pinned = pinnedCodeRefs.get(resolvedKey); + if (pinned != null + && pinned.type == RuntimeScalarType.CODE + && pinned.value instanceof RuntimeCode pinnedCode + && !pinnedCode.defined()) { + // A parser/compiler lookup may have created an undefined CV + // placeholder before a later compile-time import installs the + // real sub. Fill that placeholder so already-compiled call + // sites keep the CV even if a following `no Module` deletes + // the visible stash entry before runtime. + ref = pinned; + globalCodeRefs.put(resolvedKey, ref); + } else { + ref = getGlobalCodeRefForFreshLookup(resolvedKey); + } + } // Ensure it's in globalCodeRefs so method resolution finds it if (!globalCodeRefs.containsKey(resolvedKey)) { globalCodeRefs.put(resolvedKey, ref); } + deletedCodeRefPins.remove(resolvedKey); + pinnedCodeRefs.put(resolvedKey, ref); return ref; } + public static synchronized int registerCompiledCodeRef(RuntimeScalar ref) { + int id = nextCompiledCodeRefId++; + compiledCodeRefs.put(id, ref); + return id; + } + + public static RuntimeScalar getCompiledCodeRef(int id) { + RuntimeScalar ref = compiledCodeRefs.get(id); + return ref != null ? ref : new RuntimeScalar(); + } + /** * Checks if a global code reference exists. * @@ -780,6 +852,15 @@ public static RuntimeScalar existsGlobalCodeRefAsScalar(RuntimeScalar key) { } public static RuntimeScalar existsGlobalCodeRefAsScalar(RuntimeScalar key, String packageName) { + // Handle values that are already CODE/GLOB scalars before falling back + // to package-relative symbolic name lookup. + if (key.type == RuntimeScalarType.GLOB && key.value instanceof RuntimeGlob glob) { + return existsGlobalCodeRefAsScalar(glob.globName); + } + if (key.type == RuntimeScalarType.CODE && key.value instanceof RuntimeCode runtimeCode) { + return (runtimeCode.defined() || runtimeCode.isDeclared) ? scalarTrue : scalarFalse; + } + // Use proper package name resolution like createCodeReference String name = NameNormalizer.normalizeVariableName(key.toString(), packageName); return existsGlobalCodeRefAsScalar(name); @@ -824,6 +905,16 @@ public static RuntimeScalar definedGlobalCodeRefAsScalar(RuntimeScalar key) { } public static RuntimeScalar definedGlobalCodeRefAsScalar(RuntimeScalar key, String packageName) { + // Handle values that are already CODE/GLOB scalars before falling back + // to package-relative symbolic name lookup. This covers `defined &$coderef`, + // where the parser passes the CODE scalar rather than a symbolic name. + if (key.type == RuntimeScalarType.GLOB && key.value instanceof RuntimeGlob glob) { + return definedGlobalCodeRefAsScalar(glob.globName); + } + if (key.type == RuntimeScalarType.CODE && key.value instanceof RuntimeCode runtimeCode) { + return runtimeCode.defined() ? scalarTrue : scalarFalse; + } + // Use proper package name resolution like createCodeReference String name = NameNormalizer.normalizeVariableName(key.toString(), packageName); @@ -833,14 +924,23 @@ public static RuntimeScalar definedGlobalCodeRefAsScalar(RuntimeScalar key, Stri } - public static RuntimeScalar deleteGlobalCodeRefAsScalar(String key) { + public static RuntimeScalar removeGlobalCodeRefForStashDelete(String key) { RuntimeScalar deleted = globalCodeRefs.remove(key); + if (deleted != null || pinnedCodeRefs.containsKey(key)) { + deletedCodeRefPins.add(key); + clearPackageCache(); + } // Decrement stashRefCount on the removed CODE ref if (deleted != null && deleted.value instanceof RuntimeCode removedCode) { if (removedCode.stashRefCount > 0) { removedCode.stashRefCount--; } } + return deleted; + } + + public static RuntimeScalar deleteGlobalCodeRefAsScalar(String key) { + RuntimeScalar deleted = removeGlobalCodeRefForStashDelete(key); return deleted != null ? deleted : scalarFalse; } @@ -872,6 +972,7 @@ public static RuntimeScalar deleteGlobalCodeRefAsScalar(RuntimeScalar key, Strin */ public static void clearPinnedCodeRefsForNamespace(String prefix) { pinnedCodeRefs.keySet().removeIf(k -> k.startsWith(prefix)); + deletedCodeRefPins.removeIf(k -> k.startsWith(prefix)); } /** diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/HashSpecialVariable.java b/src/main/java/org/perlonjava/runtime/runtimetypes/HashSpecialVariable.java index cb21901e2..c50a4aa70 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/HashSpecialVariable.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/HashSpecialVariable.java @@ -338,16 +338,10 @@ public RuntimeScalar remove(Object key) { return scalarUndef; } - // Get references to all the slots before deleting - // Only remove from globalCodeRefs, NOT pinnedCodeRefs, to allow compiled code - // to continue calling the subroutine (Perl caches CVs at compile time) - RuntimeScalar code = GlobalVariable.globalCodeRefs.remove(fullKey); - // Decrement stashRefCount on the removed CODE ref - if (code != null && code.value instanceof RuntimeCode removedCode) { - if (removedCode.stashRefCount > 0) { - removedCode.stashRefCount--; - } - } + // Remove only from the visible stash, not from pinned code refs: + // compiled call sites keep their CV, while future lookups must see + // the deletion and create an undefined slot. + RuntimeScalar code = GlobalVariable.removeGlobalCodeRefForStashDelete(fullKey); RuntimeScalar scalar = GlobalVariable.globalVariables.remove(fullKey); RuntimeArray array = GlobalVariable.globalArrays.remove(fullKey); RuntimeHash hash = GlobalVariable.globalHashes.remove(fullKey); diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/MortalList.java b/src/main/java/org/perlonjava/runtime/runtimetypes/MortalList.java index 20ccb4ce1..c0d732642 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/MortalList.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/MortalList.java @@ -588,55 +588,53 @@ private static boolean isReachableCached(RuntimeBase base) { return flushReachableCache.contains(base); } + private static void processDeferredBase(RuntimeBase base, boolean clearWeakRefsForLocalBinding) { + if (base.refCount > 0) { + base.traceRefCount(-1, "MortalList.flush (deferred decrement)"); + } + if (base.refCount > 0 && --base.refCount == 0) { + if (base.localBindingExists) { + // Named container: local variable may still exist. Skip callDestroy. + // Cleanup will happen at scope exit (scopeExitCleanupHash/Array). + // + // Do NOT clear weak refs here for normal flush paths: + // localBindingExists=true means the container is still alive via + // its lexical slot. Test op/hashassign.t 218 (bug #76716, + // "undef %hash should not zap weak refs") requires that + // `is $p, \%tb; undef %tb;` does not zap the weak ref $p to %tb. + if (clearWeakRefsForLocalBinding) { + WeakRefRegistry.clearWeakRefsTo(base); + } + } else if (base.blessId == 0 + && WeakRefRegistry.hasWeakRefsTo(base) + && ReachabilityWalker.hasStrongCycle(base)) { + // Unblessed self-retaining cycles are intentionally leaked by + // Perl's refcounting. AnyEvent timers use this shape: the weak + // timer queue points at an array whose callback closes over the + // scalar holding that same array. + base.refCount = 1; + } else if (base.blessId != 0 + && base.storedInPackageGlobal + && WeakRefRegistry.hasWeakRefsTo(base) + && isReachableCached(base)) { + // Module-global metadata such as Moose/Class::MOP metaclasses + // can transiently hit zero in the selective refcount model. + // If the walker can still reach the object from Perl-visible + // roots, keep weak links to it intact. + } else { + base.refCount = Integer.MIN_VALUE; + DestroyDispatch.callDestroy(base); + } + } + } + public static void flush() { if (!active || pending.isEmpty() || flushing) return; flushing = true; try { // Process list — DESTROY may add new entries, so use index-based loop for (int i = 0; i < pending.size(); i++) { - RuntimeBase base = pending.get(i); - if (base.refCount > 0) { - base.traceRefCount(-1, "MortalList.flush (deferred decrement)"); - } - if (base.refCount > 0 && --base.refCount == 0) { - if (base.localBindingExists) { - // Named container: local variable may still exist. Skip callDestroy. - // Cleanup will happen at scope exit (scopeExitCleanupHash/Array). - // - // Do NOT clear weak refs here: localBindingExists=true means - // the container is still alive via its lexical slot. Test - // op/hashassign.t 218 (bug #76716, "undef %hash should not - // zap weak refs") requires that `is $p, \%tb; undef %tb;` - // does not zap the weak ref $p to %tb — the `\%tb` inside - // `is(...)` triggers a deferred decrement whose refCount - // transition 1→0 lands here, but the hash is still alive. - // An earlier "Fix 10a" cleared weak refs here for anon-hash - // leak-tracing scenarios; those scenarios now use - // createAnonymousReference() (localBindingExists stays false) - // so the clear is no longer needed and broke #76716. - } else if (base.blessId != 0 - && base.storedInPackageGlobal - && WeakRefRegistry.hasWeakRefsTo(base) - && isReachableCached(base)) { - // D-W6.18: property-based walker gate. - // Replaces the class-name heuristic - // (classNeedsWalkerGate). Object's lifetime is - // module-global metadata (stored in a package- - // global hash like %METAS), so selective - // refCount transient zeros must not fire DESTROY. - // Walker confirms reachability; suppress destroy. - // D-W6.16: heuristic walker gate (primary). - // The new reachableOwnerCount() infrastructure - // (D-W6.14/16) handles Class::MOP/Moose correctly - // without needing this heuristic, but DBIC's - // row-leak tests still over-rescue when using it - // as the only gate. Heuristic stays as primary - // until the over-rescue is fixed (D-W6.17). - } else { - base.refCount = Integer.MIN_VALUE; - DestroyDispatch.callDestroy(base); - } - } + processDeferredBase(pending.get(i), false); } pending.clear(); marks.clear(); // All entries drained; marks are meaningless now @@ -706,17 +704,13 @@ public static void drainPendingSince(int startIdx) { if (startIdx < 0) startIdx = 0; // Loop because DESTROY may add further entries int i = startIdx; - while (i < pending.size()) { - RuntimeBase base = pending.get(i); - i++; - if (base.refCount > 0 && --base.refCount == 0) { - if (base.localBindingExists) { - WeakRefRegistry.clearWeakRefsTo(base); - } else { - base.refCount = Integer.MIN_VALUE; - DestroyDispatch.callDestroy(base); - } + try { + while (i < pending.size()) { + processDeferredBase(pending.get(i), true); + i++; } + } finally { + flushReachableCache = null; } // Truncate the pending list back to startIdx to mark these entries // as processed. Outer flush won't re-process them. @@ -771,15 +765,7 @@ public static void flushAboveMark() { flushing = true; try { for (int i = mark; i < pending.size(); i++) { - RuntimeBase base = pending.get(i); - if (base.refCount > 0 && --base.refCount == 0) { - if (base.localBindingExists) { - // Named container: local variable may still exist. - } else { - base.refCount = Integer.MIN_VALUE; - DestroyDispatch.callDestroy(base); - } - } + processDeferredBase(pending.get(i), false); } // Remove only entries above the mark while (pending.size() > mark) { @@ -787,6 +773,7 @@ public static void flushAboveMark() { } } finally { flushing = false; + flushReachableCache = null; } } @@ -808,20 +795,13 @@ public static void popAndFlush() { } // Process entries from mark onwards (DESTROY may add new entries) for (int i = mark; i < pending.size(); i++) { - RuntimeBase base = pending.get(i); - if (base.refCount > 0 && --base.refCount == 0) { - if (base.localBindingExists) { - // Named container: local variable may still exist. Skip callDestroy. - } else { - base.refCount = Integer.MIN_VALUE; - DestroyDispatch.callDestroy(base); - } - } + processDeferredBase(pending.get(i), false); } // Remove only the entries we processed (keep entries before mark) while (pending.size() > mark) { pending.removeLast(); } + flushReachableCache = null; // After processing mortals (which may have triggered releaseCaptures // via callDestroy), check if any deferred captures are now ready. processReadyDeferredCaptures(); diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/ReachabilityWalker.java b/src/main/java/org/perlonjava/runtime/runtimetypes/ReachabilityWalker.java index 725907aef..c529b9154 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/ReachabilityWalker.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/ReachabilityWalker.java @@ -329,6 +329,94 @@ private void addReachable(RuntimeBase b, java.util.ArrayDeque todo) } } + /** + * Return true if {@code target} can reach itself through strong Perl + * references. Weak scalars are ignored. This models Perl's refcount + * behavior for unblessed self-cycles: they remain alive even when no + * package/global root points at them. + */ + public static boolean hasStrongCycle(RuntimeBase target) { + if (target == null) return false; + final int MAX_VISITS = 50_000; + Set seen = Collections.newSetFromMap(new IdentityHashMap<>()); + java.util.ArrayDeque todo = new java.util.ArrayDeque<>(); + + if (enqueueStrongEdges(target, target, seen, todo)) { + return true; + } + + int visits = 0; + while (!todo.isEmpty() && visits < MAX_VISITS) { + RuntimeBase cur = todo.removeFirst(); + visits++; + if (enqueueStrongEdges(cur, target, seen, todo)) { + return true; + } + } + return false; + } + + private static boolean enqueueStrongEdges(RuntimeBase cur, RuntimeBase target, + Set seen, + java.util.ArrayDeque todo) { + if (cur instanceof RuntimeHash h) { + for (RuntimeScalar v : h.elements.values()) { + if (enqueueStrongScalar(v, target, seen, todo)) return true; + } + } else if (cur instanceof RuntimeArray a) { + for (RuntimeScalar v : a.elements) { + if (enqueueStrongScalar(v, target, seen, todo)) return true; + } + } else if (cur instanceof RuntimeCode code) { + if (code.capturedScalars != null) { + for (RuntimeScalar cap : code.capturedScalars) { + if (enqueueStrongScalar(cap, target, seen, todo)) return true; + } + } + if (cur instanceof org.perlonjava.backend.bytecode.InterpretedCode interpreted + && interpreted.capturedVars != null) { + for (RuntimeBase cap : interpreted.capturedVars) { + if (cap instanceof RuntimeScalar scalar) { + if (enqueueStrongScalar(scalar, target, seen, todo)) return true; + } else if (cap != null) { + if (cap == target) return true; + if (seen.add(cap)) todo.addLast(cap); + } + } + } + Object closureObject = code.codeObject != null ? code.codeObject : code.subroutine; + if (closureObject != null) { + try { + for (java.lang.reflect.Field field : closureObject.getClass().getDeclaredFields()) { + if (field.getType() == RuntimeScalar.class && !"__SUB__".equals(field.getName())) { + RuntimeScalar cap = (RuntimeScalar) field.get(closureObject); + if (enqueueStrongScalar(cap, target, seen, todo)) return true; + } + } + } catch (IllegalAccessException ignored) { + // Generated closure fields are public. If another + // implementation denies access, fall back to the explicit + // capturedScalars / capturedVars metadata above. + } + } + } else if (cur instanceof RuntimeScalar s) { + return enqueueStrongScalar(s, target, seen, todo); + } + return false; + } + + private static boolean enqueueStrongScalar(RuntimeScalar s, RuntimeBase target, + Set seen, + java.util.ArrayDeque todo) { + if (s == null || WeakRefRegistry.isweak(s)) return false; + if ((s.type & RuntimeScalarType.REFERENCE_BIT) != 0 + && s.value instanceof RuntimeBase b) { + if (b == target) return true; + if (seen.add(b)) todo.addLast(b); + } + return false; + } + /** * Lightweight per-object reachability query: walk from Perl-visible * roots and return {@code true} as soon as {@code target} is found, diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeCode.java b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeCode.java index f8b3f6f50..1e63ad3f7 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeCode.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeCode.java @@ -659,6 +659,139 @@ public static boolean isCodeDefined(RuntimeScalar codeRef) { && code.defined(); } + /** + * Preflight for generated direct subroutine calls. Perl reports an + * undefined direct call at the line containing the function token, but + * caller() inside a successfully entered multiline call sees the closing + * call-site line. The emitter calls this while the bytecode line is still + * the function-token line, then moves the real apply() instruction to the + * call-site line. + */ + public static void throwIfDirectCallUndefined(RuntimeScalar runtimeScalar, String subroutineName) { + RuntimeScalar curScalar = runtimeScalar; + + while (curScalar != null) { + if (curScalar.type == RuntimeScalarType.TIED_SCALAR) { + curScalar = curScalar.tiedFetch(); + continue; + } + if (curScalar.type == READONLY_SCALAR) { + curScalar = (RuntimeScalar) curScalar.value; + continue; + } + if (curScalar.type == RuntimeScalarType.UNDEF) { + return; + } + + if (curScalar.type == RuntimeScalarType.CODE) { + RuntimeCode code = (RuntimeCode) curScalar.value; + + if (code.isClosurePrototype) { + return; + } + + if (code.compilerSupplier != null) { + RuntimeList savedConstantValue = code.constantValue; + java.util.List savedAttributes = code.attributes; + code.compilerSupplier.get(); + code = (RuntimeCode) curScalar.value; + if (savedConstantValue != null && code.constantValue == null) { + code.constantValue = savedConstantValue; + } + if (savedAttributes != null && code.attributes == null) { + code.attributes = savedAttributes; + } + } + + if (!code.defined() && "CORE".equals(code.packageName) && code.subName != null) { + if (CoreSubroutineGenerator.generateWrapper(code.subName)) { + curScalar = GlobalVariable.getGlobalCodeRef("CORE::" + code.subName); + if (curScalar.type == RuntimeScalarType.CODE) { + code = (RuntimeCode) curScalar.value; + } + } + } + + if (code.defined()) { + return; + } + + String fullSubName = subroutineName; + if ((fullSubName == null || fullSubName.isEmpty()) && code.packageName != null && code.subName != null) { + fullSubName = code.packageName + "::" + code.subName; + } + + if (fullSubName != null && !fullSubName.isEmpty()) { + RuntimeScalar importedStubAutoload = findImportedStubAutoload(code, fullSubName); + if (importedStubAutoload != null) { + return; + } + + if (code.sourcePackage != null && !code.sourcePackage.isEmpty()) { + String sourceAutoloadString = code.sourcePackage + "::AUTOLOAD"; + RuntimeScalar sourceAutoload = GlobalVariable.getGlobalCodeRef(sourceAutoloadString); + if (isCodeDefined(sourceAutoload)) { + return; + } + } + + int sep = fullSubName.lastIndexOf("::"); + if (sep >= 0) { + String autoloadString = fullSubName.substring(0, sep + 2) + "AUTOLOAD"; + RuntimeScalar autoload = GlobalVariable.getGlobalCodeRef(autoloadString); + if (isCodeDefined(autoload)) { + return; + } + } + + throw new PerlCompilerException(gotoErrorPrefix(subroutineName) + + "ndefined subroutine &" + fullSubName + " called"); + } + return; + } + + if (curScalar.type == RuntimeScalarType.GLOB) { + RuntimeGlob glob = (RuntimeGlob) curScalar.value; + if (glob.globName != null) { + curScalar = GlobalVariable.getGlobalCodeRef(glob.globName); + continue; + } + if (glob.codeSlot != null) { + curScalar = glob.codeSlot; + continue; + } + return; + } + + if ((curScalar.type == RuntimeScalarType.REFERENCE || curScalar.type == RuntimeScalarType.GLOBREFERENCE) + && curScalar.value instanceof RuntimeGlob glob) { + if (glob.globName != null) { + curScalar = GlobalVariable.getGlobalCodeRef(glob.globName); + continue; + } + if (glob.codeSlot != null) { + curScalar = glob.codeSlot; + continue; + } + return; + } + + if (curScalar.type == STRING || curScalar.type == BYTE_STRING) { + String varName = NameNormalizer.normalizeVariableName(curScalar.toString(), "main"); + curScalar = GlobalVariable.getGlobalCodeRef(varName); + continue; + } + + RuntimeScalar overloadedCode = handleCodeOverload(curScalar); + if (overloadedCode != null) { + curScalar = overloadedCode; + continue; + } + + return; + } + } + private static RuntimeScalar findImportedStubAutoload(RuntimeCode code, String fullSubName) { if (code.packageName == null || code.packageName.isEmpty() || fullSubName == null || fullSubName.isEmpty()) { diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeScalar.java b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeScalar.java index 339009887..3e1026a12 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeScalar.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeScalar.java @@ -2287,10 +2287,23 @@ public RuntimeScalar createReference() { public RuntimeScalar undefine() { // Special handling for CODE type - don't set the ref to undef, - // just clear the code from the global symbol table + // just clear the code from the global symbol table. + // + // Do not release closure captures unconditionally here. CODE refs can + // be copied into another lexical/container while a temporary argument + // scalar is later undef'd; releasing captures from that temporary would + // make the still-live callback forget the variables it closed over. + // Captures are released when the CODE object's counted references + // truly reach zero. if (type == RuntimeScalarType.CODE && value instanceof RuntimeCode code) { - // Release captured variables before discarding this CODE ref - code.releaseCaptures(); + if (this.refCountOwned && code.refCount > 0) { + this.refCountOwned = false; + code.releaseActiveOwner(this); + if (--code.refCount == 0) { + code.refCount = Integer.MIN_VALUE; + DestroyDispatch.callDestroy(code); + } + } // Clear the code value but keep the type as CODE this.value = new RuntimeCode((String) null, null); // Invalidate the method resolution cache diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeStash.java b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeStash.java index f81ed8e07..d6276c2cc 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeStash.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeStash.java @@ -182,16 +182,10 @@ private RuntimeScalar deleteGlob(String k) { RuntimeGlob savedIO = GlobalVariable.globalIORefs.get(fullKey); RuntimeScalar savedCode = GlobalVariable.globalCodeRefs.get(fullKey); - // Delete all slots from GlobalVariable - // Only remove from globalCodeRefs, NOT pinnedCodeRefs, to allow compiled code - // to continue calling the subroutine (Perl caches CVs at compile time) - GlobalVariable.globalCodeRefs.remove(fullKey); - // Decrement stashRefCount on the removed CODE ref - if (savedCode != null && savedCode.value instanceof RuntimeCode removedCode) { - if (removedCode.stashRefCount > 0) { - removedCode.stashRefCount--; - } - } + // Delete all slots from GlobalVariable. The CODE slot helper removes + // the visible stash entry while keeping already-pinned CVs alive for + // previously compiled call sites. + GlobalVariable.removeGlobalCodeRefForStashDelete(fullKey); GlobalVariable.globalVariables.remove(fullKey); GlobalVariable.globalArrays.remove(fullKey); GlobalVariable.globalHashes.remove(fullKey); diff --git a/src/main/perl/lib/namespace/autoclean.pm b/src/main/perl/lib/namespace/autoclean.pm index f89f481f4..ae3b0cd18 100644 --- a/src/main/perl/lib/namespace/autoclean.pm +++ b/src/main/perl/lib/namespace/autoclean.pm @@ -128,7 +128,11 @@ sub _method_check { $methods{meta} = 1 if $meta->isa('Moose::Meta::Role') && eval { Moose->VERSION } < 0.90; - return sub { $_[0] =~ /^\(/ || $methods{$_[0]} }; + return sub { + return 1 if $_[0] =~ /^\(/ || $methods{$_[0]}; + return 1 if $constant::declared{"${package}::$_[0]"}; + return 0; + }; } } @@ -142,6 +146,7 @@ sub _method_check { my $coderef = do { no strict 'refs'; \&{"${package}::$_[0]"} }; my $fullname = Sub::Util::subname($coderef); + return 1 if $constant::declared{"${package}::$_[0]"}; return 1 unless defined $fullname; # Can't determine origin, keep it my ($code_stash) = $fullname =~ /\A(.*)::/s; diff --git a/src/test/resources/unit/caller_line_number.t b/src/test/resources/unit/caller_line_number.t index ef81e3a79..dcc47c483 100644 --- a/src/test/resources/unit/caller_line_number.t +++ b/src/test/resources/unit/caller_line_number.t @@ -1,7 +1,7 @@ #!/usr/bin/perl use strict; use warnings; -use Test::More tests => 8; +use Test::More tests => 11; # Test caller() returns correct line numbers, especially for deeper stack frames. # This tests the fix for the bug where caller($level) with level > 1 returned @@ -83,4 +83,33 @@ ok($result3 < $approx_file_end - 20, ok($result3 > 0 && $result3 < 100, "caller(2) line ($result3) is a reasonable positive number"); +sub multiline_direct_caller { return (caller(0))[2]; } +my $expected_line_9 = __LINE__ + 3; +my $result9 = multiline_direct_caller( + sub { 1 } +); +is($result9, $expected_line_9, "caller(0) reports closing line for multiline direct call"); + +{ + package CallerLineNumber::Obj; + sub new { bless {}, shift } + sub multiline_method_caller { return (caller(0))[2]; } +} + +my $expected_line_10 = __LINE__ + 3; +my $result10 = CallerLineNumber::Obj->new->multiline_method_caller( + sub { 1 } +); +is($result10, $expected_line_10, "caller(0) reports closing line for multiline method call"); + +my $expected_line_11 = __LINE__ + 3; +eval { + *{ + CallerLineNumber::Missing::for_line_test() + }; +}; +like($@, + qr/Undefined subroutine &CallerLineNumber::Missing::for_line_test called at .* line $expected_line_11\./, + "undefined multiline direct call reports function line"); + # End of tests diff --git a/src/test/resources/unit/can_missing_subroutine.t b/src/test/resources/unit/can_missing_subroutine.t new file mode 100644 index 000000000..fe2d0f3fa --- /dev/null +++ b/src/test/resources/unit/can_missing_subroutine.t @@ -0,0 +1,15 @@ +#!/usr/bin/env perl + +use strict; +use warnings; +use Test::More tests => 3; + +eval { CanMissingSubroutine::missing() }; +like($@, qr/Undefined subroutine/, 'missing static sub call fails'); +ok(!CanMissingSubroutine->can('missing'), 'failed static sub call is not visible to can'); + +{ + no strict 'refs'; + my $ref = \&{'CanMissingSubroutine::created'}; + ok(CanMissingSubroutine->can('created'), 'symbolic CODE ref creation is visible to can'); +} diff --git a/src/test/resources/unit/code_ref_defined_exists.t b/src/test/resources/unit/code_ref_defined_exists.t new file mode 100644 index 000000000..0f87d1d7f --- /dev/null +++ b/src/test/resources/unit/code_ref_defined_exists.t @@ -0,0 +1,35 @@ +#!/usr/bin/env perl + +use strict; +use warnings; +use Test::More tests => 10; + +{ + package CodeRefDefinedExists::Named; + sub real { 42 } + sub stub; +} + +my $real = \&CodeRefDefinedExists::Named::real; +ok(defined &$real, 'defined &$coderef is true for a named sub'); +ok(exists &$real, 'exists &$coderef is true for a named sub'); + +my $stub = \&CodeRefDefinedExists::Named::stub; +ok(defined $stub, 'forward-declared CODE reference is a defined scalar'); +ok(!defined &$stub, 'defined &$coderef is false for a forward declaration'); +ok(exists &$stub, 'exists &$coderef is true for a forward declaration'); + +my $anon = sub { 42 }; +ok(defined &$anon, 'defined &$coderef is true for an anonymous sub'); +ok(exists &$anon, 'exists &$coderef is true for an anonymous sub'); + +{ + no strict 'refs'; + + my $symbolic = \&{'CodeRefDefinedExists::Named::real'}; + ok(defined &$symbolic, 'defined &$coderef is true for a symbolic named sub'); + + my $missing = \&{'CodeRefDefinedExists::Named::missing'}; + ok(!defined &$missing, 'defined &$coderef is false for a symbolic missing sub'); + ok(exists &$missing, 'exists &$coderef is true after symbolic CODE ref creation'); +} diff --git a/src/test/resources/unit/dbi_storable_bytes.t b/src/test/resources/unit/dbi_storable_bytes.t new file mode 100644 index 000000000..aeaad8f8a --- /dev/null +++ b/src/test/resources/unit/dbi_storable_bytes.t @@ -0,0 +1,28 @@ +use strict; +use warnings; +use Test::More; +use DBI; +use Storable qw(nfreeze thaw); + +my $dbh = DBI->connect( + 'dbi:SQLite:dbname=:memory:', + '', + '', + { RaiseError => 1, PrintError => 0 }, +); + +$dbh->do('CREATE TABLE t (v TEXT)'); + +my $payload = { a => 1, b => [ { c => 2 } ], d => 3 }; +my $frozen = nfreeze($payload); + +like($frozen, qr/[\x80-\xff]/, 'frozen payload exercises binary bytes'); + +$dbh->do('INSERT INTO t (v) VALUES (?)', undef, $frozen); +my ($roundtrip) = $dbh->selectrow_array('SELECT v FROM t'); + +is(length($roundtrip), length($frozen), 'DBI preserves binary Storable length'); +is(unpack('H*', $roundtrip), unpack('H*', $frozen), 'DBI preserves binary Storable bytes'); +is_deeply(thaw($roundtrip), $payload, 'DBI round-tripped Storable payload thaws'); + +done_testing; diff --git a/src/test/resources/unit/eval_after_stash_delete.t b/src/test/resources/unit/eval_after_stash_delete.t new file mode 100644 index 000000000..73cb84c33 --- /dev/null +++ b/src/test/resources/unit/eval_after_stash_delete.t @@ -0,0 +1,28 @@ +#!/usr/bin/env perl + +use strict; +use warnings; +use Test::More tests => 4; + +{ + package EvalAfterStashDelete::Pkg; + sub doomed { 42 } +} + +my $compiled_before_delete = sub { EvalAfterStashDelete::Pkg::doomed() }; + +delete $EvalAfterStashDelete::Pkg::{doomed}; + +ok(!EvalAfterStashDelete::Pkg->can('doomed'), + 'stash delete removes method lookup entry'); + +my $old_value = eval { $compiled_before_delete->() }; +is($old_value, 42, 'call site compiled before stash delete keeps its CV'); + +my $new_value = eval q{EvalAfterStashDelete::Pkg::doomed()}; +like($@, qr/Undefined subroutine &EvalAfterStashDelete::Pkg::doomed called/, + 'eval compiled after stash delete does not resurrect pinned CV'); + +my $new_coderef = eval q{\&EvalAfterStashDelete::Pkg::doomed}; +ok(!defined &$new_coderef, + 'new code reference after stash delete is an undefined slot'); diff --git a/src/test/resources/unit/inc_hook_prefix_filehandle.t b/src/test/resources/unit/inc_hook_prefix_filehandle.t new file mode 100644 index 000000000..f0c9bb907 --- /dev/null +++ b/src/test/resources/unit/inc_hook_prefix_filehandle.t @@ -0,0 +1,49 @@ +#!/usr/bin/env perl + +use strict; +use warnings; +use Test::More tests => 4; +use File::Temp qw(tempdir); +use File::Spec; + +my $tmp = tempdir(CLEANUP => 1); +my $dir = File::Spec->catdir($tmp, 'Hook'); +mkdir $dir or die "mkdir $dir: $!"; + +my $pm = File::Spec->catfile($dir, 'Module.pm'); +open my $out, '>', $pm or die "open $pm: $!"; +print {$out} <<'EOPM'; +use v5.14; + +sub mock () { 42 } +sub current_package { __PACKAGE__ } + +1; +EOPM +close $out; + +my $prefix = 'package Local::Loaded;'; +my $hook_called = 0; +my $hook = sub { + my (undef, $file) = @_; + return unless $file eq 'Hook/Module.pm'; + + $hook_called++; + open my $in, '<', $pm or die "open $pm: $!"; + return (\$prefix, $in); +}; + +{ + local @INC = ($hook, @INC); + my $loaded = eval { require Hook::Module; 1 }; + ok($loaded, '@INC hook scalar prefix plus filehandle loads') + or diag "\$@ = $@"; +} + +is($hook_called, 1, '@INC hook handled the requested module'); +is(Local::Loaded::current_package(), 'Local::Loaded', + 'filehandle source compiled under scalar prefix package'); + +my $value = eval q{use strict; Local::Loaded::mock;}; +is($value, 42, 'constant sub from prefixed package is visible under strict') + or diag "\$@ = $@"; diff --git a/src/test/resources/unit/namespace_autoclean_constants.t b/src/test/resources/unit/namespace_autoclean_constants.t new file mode 100644 index 000000000..2df63cfaa --- /dev/null +++ b/src/test/resources/unit/namespace_autoclean_constants.t @@ -0,0 +1,21 @@ +#!/usr/bin/env perl + +use strict; +use warnings; +use Test::More tests => 4; + +{ + package NamespaceAutocleanConstantTest; + use Moose; + use namespace::autoclean; + use constant FOO_BAR => 7; + use constant lower_const => 'value'; + + no Moose; + __PACKAGE__->meta->make_immutable; +} + +ok(defined &NamespaceAutocleanConstantTest::FOO_BAR, 'uppercase constant survives namespace::autoclean'); +is(NamespaceAutocleanConstantTest->FOO_BAR, 7, 'uppercase constant is callable as a class method'); +ok(defined &NamespaceAutocleanConstantTest::lower_const, 'lowercase constant survives namespace::autoclean'); +is(NamespaceAutocleanConstantTest->lower_const, 'value', 'lowercase constant is callable as a class method'); diff --git a/src/test/resources/unit/pr694_core_regressions.t b/src/test/resources/unit/pr694_core_regressions.t new file mode 100644 index 000000000..1121b49ae --- /dev/null +++ b/src/test/resources/unit/pr694_core_regressions.t @@ -0,0 +1,86 @@ +use strict; +use warnings; +use Test::More tests => 7; + +{ + our sub const; + BEGIN { delete $::{const} } + use constant const => 3; + + is const, 3, 'our sub tombstone is repinned when use constant defines CODE'; + ok defined(&const), 'constant CODE slot is defined after tombstoned stub'; +} + +{ + my $die = sub { die "generator boom\n" }; + my $state = []; + local @INC = (sub { return ($die, $state) }); + + my ($result, $err); + my $outer = eval { + $result = do "pr694_missing.pm"; + $err = $@; + 1; + }; + + ok $outer, 'do FILE traps @INC generator die'; + ok !defined($result), 'do FILE returns undef after @INC generator die'; + like $err, qr/generator boom/, 'do FILE stores @INC generator die in $@'; +} + +{ + my $ok = eval q{ + BEGIN { + package PR694::EvalExporter; + sub import { + my $target = caller; + no strict 'refs'; + *{"${target}::has"} = sub { 1 }; + } + sub unimport { + my $target = caller; + no strict 'refs'; + delete ${"${target}::"}{has}; + } + $INC{'PR694/EvalExporter.pm'} = 1; + } + + package PR694::EvalConsumer; + use PR694::EvalExporter; + has foo => (is => 'ro'); + no PR694::EvalExporter; + 1; + }; + ok $ok, 'string eval call keeps imported CV after no deletes stash entry' + or diag $@; +} + +{ + my $ok = eval q{ + BEGIN { + package PR694::EvalExporterAgain; + sub import { + my $target = caller; + no strict 'refs'; + *{"${target}::has"} = sub { 1 }; + } + sub unimport { + my $target = caller; + no strict 'refs'; + delete ${"${target}::"}{has}; + } + $INC{'PR694/EvalExporterAgain.pm'} = 1; + } + + package PR694::EvalConsumerAgain; + use PR694::EvalExporterAgain; + has foo => (is => 'ro'); + no PR694::EvalExporterAgain; + use PR694::EvalExporterAgain; + has foo2 => (is => 'ro'); + no PR694::EvalExporterAgain; + 1; + }; + ok $ok, 'string eval call keeps re-imported CV across no/use cycle' + or diag $@; +} diff --git a/src/test/resources/unit/weak_self_retaining_closure_cycle.t b/src/test/resources/unit/weak_self_retaining_closure_cycle.t new file mode 100644 index 000000000..fb266a08b --- /dev/null +++ b/src/test/resources/unit/weak_self_retaining_closure_cycle.t @@ -0,0 +1,38 @@ +#!/usr/bin/env perl + +use strict; +use warnings; +use Scalar::Util qw(weaken); +use Test::More tests => 3; + +our @timer_queue; +our $hit = 0; + +sub make_weak_queued_callback { + my ($cb) = @_; + my $watcher; + + $watcher = [ sub { $cb->() } ]; + push @timer_queue, $watcher; + weaken $timer_queue[-1]; + + return $watcher; +} + +sub install_callback { + my $watcher; + + $watcher = make_weak_queued_callback(sub { + $hit++; + $watcher; + }); + + return 1; +} + +install_callback(); + +ok(defined $timer_queue[0], 'weak queue entry survives through self-retaining closure cycle'); +$timer_queue[0][0]->(); +is($hit, 1, 'callback in self-retaining weak queue remains callable'); +ok(defined $timer_queue[0], 'weak queue entry remains defined after callback runs');