diff --git a/src/main/java/org/perlonjava/backend/jvm/EmitSubroutine.java b/src/main/java/org/perlonjava/backend/jvm/EmitSubroutine.java index 728a2df68..25147078f 100644 --- a/src/main/java/org/perlonjava/backend/jvm/EmitSubroutine.java +++ b/src/main/java/org/perlonjava/backend/jvm/EmitSubroutine.java @@ -255,8 +255,16 @@ public static void emitSubroutine(EmitterContext ctx, SubroutineNode node) { cvStartFile = ctx.compilerOptions.fileName; } int deparseSourceOffset = -1; - if (ctx.errorUtil != null && node.block != null) { - deparseSourceOffset = ctx.errorUtil.getSourceOffset(node.block.getIndex()); + int deparseSourceEnd = -1; + if (ctx.errorUtil != null) { + // The subroutine node carries the lexer token index. The + // block's index is the first AST child index and can point at + // a later enclosing block for adjacent anonymous subs, + // causing Storable::Deparse to retain the wrong source. + deparseSourceOffset = ctx.errorUtil.getSourceOffset(node.getIndex()); + if (node.sourceEndTokenIndex >= 0) { + deparseSourceEnd = ctx.errorUtil.getSourceOffset(node.sourceEndTokenIndex); + } } String deparseSourceText = null; if (ctx.compilerOptions != null) { @@ -332,11 +340,12 @@ public static void emitSubroutine(EmitterContext ctx, SubroutineNode node) { } mv.visitLdcInsn(deparseFlags); mv.visitLdcInsn(deparseSourceOffset); + mv.visitLdcInsn(deparseSourceEnd); mv.visitMethodInsn( Opcodes.INVOKESTATIC, "org/perlonjava/runtime/runtimetypes/RuntimeCode", "makeCodeObject", - "(Ljava/lang/Object;Ljava/lang/String;Ljava/lang/String;Ljava/lang/String;ILjava/lang/String;II)Lorg/perlonjava/runtime/runtimetypes/RuntimeScalar;", + "(Ljava/lang/Object;Ljava/lang/String;Ljava/lang/String;Ljava/lang/String;ILjava/lang/String;III)Lorg/perlonjava/runtime/runtimetypes/RuntimeScalar;", false); } catch (InterpreterFallbackException fallback) { // JVM compilation failed (e.g., ASM frame crash) - use InterpretedCode instead diff --git a/src/main/java/org/perlonjava/frontend/astnode/SubroutineNode.java b/src/main/java/org/perlonjava/frontend/astnode/SubroutineNode.java index e37225dc3..db455bf25 100644 --- a/src/main/java/org/perlonjava/frontend/astnode/SubroutineNode.java +++ b/src/main/java/org/perlonjava/frontend/astnode/SubroutineNode.java @@ -29,6 +29,9 @@ public class SubroutineNode extends AbstractNode { */ public final boolean useTryCatch; + /** Token immediately after the closing brace, when parsed from source. */ + public int sourceEndTokenIndex = -1; + /** * Constructs a new SubroutineNode with the specified parts. * @@ -50,6 +53,12 @@ public SubroutineNode(String name, String prototype, List attributes, No } } + public SubroutineNode(String name, String prototype, List attributes, Node block, + boolean useTryCatch, int tokenIndex, int sourceEndTokenIndex) { + this(name, prototype, attributes, block, useTryCatch, tokenIndex); + this.sourceEndTokenIndex = sourceEndTokenIndex; + } + /** * Accepts a visitor that performs some operation on this node. * This method is part of the Visitor design pattern, which allows diff --git a/src/main/java/org/perlonjava/frontend/parser/SubroutineParser.java b/src/main/java/org/perlonjava/frontend/parser/SubroutineParser.java index 484aa7a9d..b5a23e1ab 100644 --- a/src/main/java/org/perlonjava/frontend/parser/SubroutineParser.java +++ b/src/main/java/org/perlonjava/frontend/parser/SubroutineParser.java @@ -935,7 +935,8 @@ public static Node parseSubroutineDefinition(Parser parser, boolean wantName, St } if (subName == null) { - return handleAnonSub(parser, subName, prototype, attributes, block, currentIndex); + return handleAnonSub(parser, subName, prototype, attributes, block, currentIndex, + parser.tokenIndex); } else { return handleNamedSub(parser, subName, prototype, attributes, block, declaration); } @@ -1802,7 +1803,8 @@ static void throwInvalidAttributeError(String type, List attrs, Parser p throw new PerlCompilerException(parser.tokenIndex, attrMsg, parser.ctx.errorUtil); } - private static SubroutineNode handleAnonSub(Parser parser, String subName, String prototype, List attributes, BlockNode block, int currentIndex) { + private static SubroutineNode handleAnonSub(Parser parser, String subName, String prototype, + List attributes, BlockNode block, int currentIndex, int sourceEndTokenIndex) { // Now we check if the next token is one of the illegal characters that cannot follow a subroutine. // These are '(', '{', and '['. If any of these follow, we throw a syntax error. LexerToken token = peek(parser); @@ -1815,7 +1817,8 @@ private static SubroutineNode handleAnonSub(Parser parser, String subName, Strin // a compile-time CODE placeholder on the AST; the JVM/interpreter // compiler attaches the executable body to it later. SubroutineNode node = - new SubroutineNode(subName, prototype, attributes, block, false, currentIndex); + new SubroutineNode(subName, prototype, attributes, block, false, currentIndex, + sourceEndTokenIndex); if (attributes != null && hasNonBuiltinCodeAttribute(attributes)) { RuntimeCode placeholder = new RuntimeCode(prototype, new ArrayList<>(attributes)); placeholder.packageName = parser.ctx.symbolTable.getCurrentPackage(); 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 848b47596..aaf1760c5 100644 --- a/src/main/java/org/perlonjava/runtime/perlmodule/storable/StorableWriter.java +++ b/src/main/java/org/perlonjava/runtime/perlmodule/storable/StorableWriter.java @@ -10,6 +10,7 @@ import org.perlonjava.runtime.runtimetypes.RuntimeScalarType; import org.perlonjava.runtime.runtimetypes.NameNormalizer; import org.perlonjava.runtime.runtimetypes.ScalarUtils; +import org.perlonjava.runtime.runtimetypes.GlobalVariable; import java.nio.charset.StandardCharsets; import java.util.ArrayList; @@ -165,7 +166,23 @@ private void dispatchReferent(StorableContext c, RuntimeScalar refScalar) { dispatch(c, (RuntimeScalar) refScalar.value); break; case RuntimeScalarType.CODE: - throw new StorableFormatException("Can't store CODE items"); + // Storable's $Deparse flag enables code-reference storage by + // writing the source text produced by B::Deparse. RuntimeCode + // keeps the source text specifically for this purpose. The + // old implementation unconditionally rejected CODE values, + // which made otherwise pure-Perl users of Storable::freeze + // fail (Struct::Diff is one such consumer). + if (!GlobalVariable.getGlobalVariable("Storable::Deparse").getBoolean()) { + throw new StorableFormatException("Can't store CODE items"); + } + RuntimeCode code = (RuntimeCode) refScalar.value; + String source = codeSource(code); + if (source == null) { + throw new StorableFormatException("Can't store CODE items"); + } + c.writeByte(Opcodes.SX_CODE); + writeStringBody(c, source.getBytes(StandardCharsets.UTF_8), true); + break; case RuntimeScalarType.REGEX: // SX_REGEXP encoder. Foundation delegates to RegexpEncoder // which the regexp agent fills in. @@ -178,6 +195,19 @@ private void dispatchReferent(StorableContext c, RuntimeScalar refScalar) { } } + /** Return the source for this anonymous sub rather than the complete + * compilation unit. CompilerOptions retains the unit for diagnostics; + * using that whole string made every anonymous sub serialize identically. + * The compiler records the exact token span, so runtime serialization does + * not need to parse Perl's delimiter syntax. */ + private static String codeSource(RuntimeCode code) { + String source = code.deparseSourceText; + int start = code.deparseSourceOffset; + int end = code.deparseSourceEnd; + if (source == null || start < 0 || end <= start || start >= source.length()) return source; + return source.substring(start, Math.min(end, source.length())); + } + /** Mirrors {@code store_hook} (Storable.xs L3574). Returns true if we * emitted a {@code SX_HOOK} frame for this object; false to let the * caller fall through to the normal {@code SX_BLESS} path. False is diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeCode.java b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeCode.java index d6e2f4bd2..04bdfadb7 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeCode.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeCode.java @@ -732,6 +732,8 @@ private RuntimeList detachTryExpressionLvalueResult(RuntimeList result, int call public String deparseSourceText; public int deparseFlags; public int deparseSourceOffset = -1; + /** Exclusive source offset for the compiler-recorded subroutine span. */ + public int deparseSourceEnd = -1; public static final int DEPARSE_FLAG_STRICT = 1; public static final int DEPARSE_FLAG_WARNINGS = 2; /** @@ -1041,6 +1043,7 @@ public RuntimeCode cloneForClosure() { clone.deparseSourceText = this.deparseSourceText; clone.deparseFlags = this.deparseFlags; clone.deparseSourceOffset = this.deparseSourceOffset; + clone.deparseSourceEnd = this.deparseSourceEnd; clone.isConstantCv = this.isConstantCv; clone.isStatic = this.isStatic; clone.isDeclared = this.isDeclared; @@ -2677,6 +2680,20 @@ public static RuntimeScalar makeCodeObject( String deparseSourceText, int deparseFlags, int deparseSourceOffset) throws Exception { + return makeCodeObject(codeObject, prototype, packageName, cvStartFile, cvStartLine, + deparseSourceText, deparseFlags, deparseSourceOffset, -1); + } + + public static RuntimeScalar makeCodeObject( + Object codeObject, + String prototype, + String packageName, + String cvStartFile, + int cvStartLine, + String deparseSourceText, + int deparseFlags, + int deparseSourceOffset, + int deparseSourceEnd) throws Exception { // Retrieve the class of the provided code object Class clazz = codeObject.getClass(); @@ -2699,6 +2716,7 @@ public static RuntimeScalar makeCodeObject( code.deparseSourceText = deparseSourceText; code.deparseFlags = deparseFlags; code.deparseSourceOffset = deparseSourceOffset; + code.deparseSourceEnd = deparseSourceEnd; // Look up pad constants registered at compile time for this class. // These track cached string literals referenced via \ inside the sub, diff --git a/src/test/resources/unit/storable_code_deparse.t b/src/test/resources/unit/storable_code_deparse.t new file mode 100644 index 000000000..19b4b9a9b --- /dev/null +++ b/src/test/resources/unit/storable_code_deparse.t @@ -0,0 +1,28 @@ +use strict; +use warnings; +use Test::More tests => 4; +use Storable qw(freeze); + +my $code = sub { return 42 }; +local $Storable::Deparse = 1; +local $Storable::Eval = 1; +my $frozen = eval { freeze($code) }; + +ok(!$@, 'Storable can freeze a code reference with Deparse enabled'); +ok(defined($frozen) && length($frozen), 'the frozen code reference is non-empty'); + +my $delimited = sub { + my $text = q{a{b}}; + return $text; +}; +my $delimited_frozen = eval { freeze($delimited) }; +ok(!$@ && defined($delimited_frozen), + 'compiler span survives quote-like delimiters'); + +my $adjacent = sub { return 1 }; +my $second = sub { return 2 }; +my $adjacent_frozen = eval { freeze($adjacent) }; +my $second_frozen = eval { freeze($second) }; +ok(!$@ && defined($adjacent_frozen) && defined($second_frozen) + && $adjacent_frozen ne $second_frozen, + 'compiler span selects the complete adjacent anonymous subroutine');