From 588d9db2621ba07eff74782912d21ecc890db450 Mon Sep 17 00:00:00 2001 From: "Flavio S. Glock" Date: Fri, 2 Oct 2026 09:17:36 +0200 Subject: [PATCH 01/41] fix: keep close and fileno from creating symbolic handles Resolve close and fileno against existing symbolic IO slots so probing an unopened name does not materialize a typeglob. Add focused coverage for both operations and their effect on subsequent glob lookup. Generated with [Codex](https://openai.com/codex) Co-Authored-By: Codex <158243242+codex@users.noreply.github.com> --- docs/about/changelog.md | 2 ++ .../runtime/operators/IOOperator.java | 15 ++++++++++-- .../fileno_does_not_vivify_symbolic_glob.t | 24 +++++++++++++++++++ 3 files changed, 39 insertions(+), 2 deletions(-) create mode 100644 src/test/resources/unit/fileno_does_not_vivify_symbolic_glob.t diff --git a/docs/about/changelog.md b/docs/about/changelog.md index 191823624b..15791f6070 100644 --- a/docs/about/changelog.md +++ b/docs/about/changelog.md @@ -6,6 +6,8 @@ priorities and future plans. ## Work in progress +- Keep `close` and `fileno` probes from creating nonexistent symbolic filehandles. + - Preserve objects with counted collection owners during weak-reference sweeps, and resolve deferred user-defined regex properties in the match caller's package. diff --git a/src/main/java/org/perlonjava/runtime/operators/IOOperator.java b/src/main/java/org/perlonjava/runtime/operators/IOOperator.java index 0682203f2f..d72431fc01 100644 --- a/src/main/java/org/perlonjava/runtime/operators/IOOperator.java +++ b/src/main/java/org/perlonjava/runtime/operators/IOOperator.java @@ -698,7 +698,7 @@ public static RuntimeScalar fileno(int ctx, RuntimeBase... args) { fileHandle = args[0].scalar(); } - RuntimeIO fh = fileHandle.getRuntimeIO(); + RuntimeIO fh = getExistingRuntimeIO(fileHandle); if (fh instanceof TieHandle tieHandle) { return TieHandle.tiedFileno(tieHandle); @@ -1147,7 +1147,7 @@ public static RuntimeScalar close(int ctx, RuntimeBase... args) { ForkOpenState.clear(); RuntimeScalar handle = args.length == 1 ? ((RuntimeScalar) args[0]) : select(new RuntimeList(), RuntimeContextType.SCALAR); - RuntimeIO fh = handle.getRuntimeIO(); + RuntimeIO fh = getExistingRuntimeIO(handle); // Handle case where the filehandle is invalid/corrupted if (fh == null) { @@ -1172,6 +1172,17 @@ static boolean unopenedWarningsEnabled() { return Warnings.isCategoryEnabledAtPerlXsCaller("unopened"); } + /** Resolve a handle for operations that must not create a symbolic glob. */ + private static RuntimeIO getExistingRuntimeIO(RuntimeScalar handle) { + if (!handle.isString()) { + return handle.getRuntimeIO(); + } + String name = NameNormalizer.normalizeVariableName(handle.toString(), "main"); + RuntimeGlob glob = GlobalVariable.getExistingGlobalIO(name); + RuntimeScalar ioSlot = glob == null ? null : glob.getIO(); + return ioSlot == null ? null : ioSlot.getRuntimeIO(); + } + private static String filehandleShortName(RuntimeScalar handle) { if (!(handle.value instanceof RuntimeGlob glob) || glob.globName == null) { return null; diff --git a/src/test/resources/unit/fileno_does_not_vivify_symbolic_glob.t b/src/test/resources/unit/fileno_does_not_vivify_symbolic_glob.t new file mode 100644 index 0000000000..f8dd9c7047 --- /dev/null +++ b/src/test/resources/unit/fileno_does_not_vivify_symbolic_glob.t @@ -0,0 +1,24 @@ +use strict; +use warnings; +use Test::More; + +my $handle_name = 'filenoNoVivification'; + +ok(!defined fileno($handle_name), 'fileno on an unopened symbolic handle is undef'); +ok(!defined *{$handle_name}, 'fileno does not create the symbolic typeglob'); +{ + no warnings 'unopened'; + ok(!close $handle_name, 'close on an unopened symbolic handle is false'); +} +ok(!defined *{$handle_name}, 'close does not create the symbolic typeglob'); + +$handle_name++; +ok(!defined fileno($handle_name), 'fileno on the next unopened symbolic handle is undef'); +ok(!defined *{$handle_name}, 'fileno does not create the incremented typeglob'); +{ + no warnings 'unopened'; + ok(!close $handle_name, 'close on the incremented unopened handle is false'); +} +ok(!defined *{$handle_name}, 'close does not create the incremented typeglob'); + +done_testing(); From 39050548e1c6e9ecbba7c6caf2a957da2695663b Mon Sep 17 00:00:00 2001 From: "Flavio S. Glock" Date: Fri, 2 Oct 2026 10:47:14 +0200 Subject: [PATCH 02/41] fix: preserve scalar typeglob results and select identity Return the typeglob for scalar assignments to its CODE slot, while keeping other slot assignments on their assigned value. Preserve selected glob references so select() can reflect later stash detachment and aliasing. Add coverage for code-slot assignment results and selected-glob identity. Generated with [Codex](https://openai.com/codex) Co-Authored-By: Codex <158243242+codex@users.noreply.github.com> --- docs/about/changelog.md | 1 + .../backend/bytecode/BytecodeInterpreter.java | 9 ++++ .../backend/bytecode/CompileAssignment.java | 41 ++++++++++++++----- .../backend/bytecode/Disassemble.java | 8 ++++ .../perlonjava/backend/bytecode/Opcodes.java | 3 ++ .../perlonjava/backend/jvm/EmitVariable.java | 13 +++++- .../runtime/operators/IOOperator.java | 23 ++++++++++- .../runtime/runtimetypes/RuntimeGlob.java | 6 +++ .../runtime/runtimetypes/RuntimeIO.java | 19 ++++++++- .../unit/typeglob_scalar_result_identity.t | 30 ++++++++++++++ 10 files changed, 138 insertions(+), 15 deletions(-) create mode 100644 src/test/resources/unit/typeglob_scalar_result_identity.t diff --git a/docs/about/changelog.md b/docs/about/changelog.md index 15791f6070..6bada2eb21 100644 --- a/docs/about/changelog.md +++ b/docs/about/changelog.md @@ -7,6 +7,7 @@ priorities and future plans. ## Work in progress - Keep `close` and `fileno` probes from creating nonexistent symbolic filehandles. +- Preserve typeglob values from scalar assignments and selected-handle lookups. - Preserve objects with counted collection owners during weak-reference sweeps, and resolve deferred user-defined regex properties in the match caller's diff --git a/src/main/java/org/perlonjava/backend/bytecode/BytecodeInterpreter.java b/src/main/java/org/perlonjava/backend/bytecode/BytecodeInterpreter.java index ba6608881a..3669773fcf 100644 --- a/src/main/java/org/perlonjava/backend/bytecode/BytecodeInterpreter.java +++ b/src/main/java/org/perlonjava/backend/bytecode/BytecodeInterpreter.java @@ -2614,6 +2614,15 @@ private static RuntimeList execute(SuspendedInterpreterFrame frame) { pc = InlineOpcodeHandler.executeStoreGlob(bytecode, pc, registers); } + case Opcodes.GLOB_ASSIGNMENT_RESULT -> { + int rd = bytecode[pc++]; + int globReg = bytecode[pc++]; + int valueReg = bytecode[pc++]; + registers[rd] = RuntimeGlob.scalarAssignmentResult( + (RuntimeGlob) registers[globReg], + (RuntimeScalar) registers[valueReg]); + } + case Opcodes.OPEN -> { // Open file: rd = IOOperator.open(ctx, args...) // Format: OPEN rd ctx argsReg diff --git a/src/main/java/org/perlonjava/backend/bytecode/CompileAssignment.java b/src/main/java/org/perlonjava/backend/bytecode/CompileAssignment.java index 49b4dcfbd3..d601f0ccb6 100644 --- a/src/main/java/org/perlonjava/backend/bytecode/CompileAssignment.java +++ b/src/main/java/org/perlonjava/backend/bytecode/CompileAssignment.java @@ -3051,11 +3051,16 @@ && isLocalizedArraySliceReferenceTarget(referenceOp.operand)) { bytecodeCompiler.emitReg(globReg); bytecodeCompiler.emitReg(valueReg); - // A typeglob assignment evaluates to its RHS, not the - // target glob. This matters for chained assignments: - // *alias = *alias = \&source must feed the CODE ref into - // the outer assignment, as the JVM backend does. - bytecodeCompiler.lastResultReg = valueReg; + if (outerContext == RuntimeContextType.SCALAR) { + int resultReg = bytecodeCompiler.allocateRegister(); + bytecodeCompiler.emit(Opcodes.GLOB_ASSIGNMENT_RESULT); + bytecodeCompiler.emitReg(resultReg); + bytecodeCompiler.emitReg(globReg); + bytecodeCompiler.emitReg(valueReg); + bytecodeCompiler.lastResultReg = resultReg; + } else { + bytecodeCompiler.lastResultReg = valueReg; + } } else if (leftOp.operator.equals("*") && leftOp.operand instanceof BlockNode) { // Dynamic typeglob assignment: *{EXPR} = value. EXPR can // return a real glob reference (Role::Tiny's _getglob @@ -3069,9 +3074,16 @@ && isLocalizedArraySliceReferenceTarget(referenceOp.operand)) { bytecodeCompiler.emitReg(globReg); bytecodeCompiler.emitReg(valueReg); - // Preserve the RHS as the assignment result (see the - // named typeglob case above). - bytecodeCompiler.lastResultReg = valueReg; + if (outerContext == RuntimeContextType.SCALAR) { + int resultReg = bytecodeCompiler.allocateRegister(); + bytecodeCompiler.emit(Opcodes.GLOB_ASSIGNMENT_RESULT); + bytecodeCompiler.emitReg(resultReg); + bytecodeCompiler.emitReg(globReg); + bytecodeCompiler.emitReg(valueReg); + bytecodeCompiler.lastResultReg = resultReg; + } else { + bytecodeCompiler.lastResultReg = valueReg; + } } else if (leftOp.operator.equals("*")) { // Glob assignment where the glob comes from an expression, e.g. $ref->** = ... // or 'name'->** = ... @@ -3083,9 +3095,16 @@ && isLocalizedArraySliceReferenceTarget(referenceOp.operand)) { bytecodeCompiler.emitReg(globReg); bytecodeCompiler.emitReg(valueReg); - // Preserve the RHS as the assignment result (see the - // named typeglob case above). - bytecodeCompiler.lastResultReg = valueReg; + if (outerContext == RuntimeContextType.SCALAR) { + int resultReg = bytecodeCompiler.allocateRegister(); + bytecodeCompiler.emit(Opcodes.GLOB_ASSIGNMENT_RESULT); + bytecodeCompiler.emitReg(resultReg); + bytecodeCompiler.emitReg(globReg); + bytecodeCompiler.emitReg(valueReg); + bytecodeCompiler.lastResultReg = resultReg; + } else { + bytecodeCompiler.lastResultReg = valueReg; + } } else if (leftOp.operator.equals("+")) { // Unary plus is transparent for lvalue assignment, matching LValueVisitor. bytecodeCompiler.compileNode(leftOp.operand, -1, RuntimeContextType.LVALUE); diff --git a/src/main/java/org/perlonjava/backend/bytecode/Disassemble.java b/src/main/java/org/perlonjava/backend/bytecode/Disassemble.java index 6d2ef96856..9eab6a3ee7 100644 --- a/src/main/java/org/perlonjava/backend/bytecode/Disassemble.java +++ b/src/main/java/org/perlonjava/backend/bytecode/Disassemble.java @@ -881,6 +881,14 @@ public static String disassemble(InterpretedCode interpretedCode) { rs = interpretedCode.bytecode[pc++]; sb.append("STORE_GLOB r").append(globReg).append(" = r").append(rs).append("\n"); break; + case Opcodes.GLOB_ASSIGNMENT_RESULT: + int globResultRd = interpretedCode.bytecode[pc++]; + int globResultGlob = interpretedCode.bytecode[pc++]; + int globResultValue = interpretedCode.bytecode[pc++]; + sb.append("GLOB_ASSIGNMENT_RESULT r").append(globResultRd) + .append(" = r").append(globResultGlob) + .append(" or r").append(globResultValue).append("\n"); + break; case Opcodes.OPEN: rd = interpretedCode.bytecode[pc++]; int openCtx = interpretedCode.bytecode[pc++]; diff --git a/src/main/java/org/perlonjava/backend/bytecode/Opcodes.java b/src/main/java/org/perlonjava/backend/bytecode/Opcodes.java index 41768c3d00..40ac36a6d7 100644 --- a/src/main/java/org/perlonjava/backend/bytecode/Opcodes.java +++ b/src/main/java/org/perlonjava/backend/bytecode/Opcodes.java @@ -2742,6 +2742,9 @@ public class Opcodes { /** Create a LAST marker retaining source spelling {@code break}. Format: rd labelIdx. */ public static final short CREATE_SWITCH_BREAK = 619; + /** Select the scalar result of a typeglob assignment. Format: rd globReg valueReg. */ + public static final short GLOB_ASSIGNMENT_RESULT = 632; + /** Create a LAST marker retaining loop-topicalizer break diagnostics. Format: rd labelIdx. */ public static final short CREATE_SWITCH_BREAK_LOOP_TOPICALIZER = 620; diff --git a/src/main/java/org/perlonjava/backend/jvm/EmitVariable.java b/src/main/java/org/perlonjava/backend/jvm/EmitVariable.java index ac87d34f0f..da6cd35946 100644 --- a/src/main/java/org/perlonjava/backend/jvm/EmitVariable.java +++ b/src/main/java/org/perlonjava/backend/jvm/EmitVariable.java @@ -1310,7 +1310,18 @@ static void handleAssignOperator(EmitterVisitor emitterVisitor, BinaryOperatorNo } if (isGlob) { mv.visitInsn(Opcodes.SWAP); // move the target first - mv.visitMethodInsn(Opcodes.INVOKEVIRTUAL, leftDescriptor, "set", rightDescriptor, false); + boolean scalarGlobAssignment = nodeLeft != null + && nodeLeft.operator.equals("*") + && ctx.contextType == RuntimeContextType.SCALAR; + if (scalarGlobAssignment) { + mv.visitMethodInsn(Opcodes.INVOKESTATIC, + "org/perlonjava/runtime/runtimetypes/RuntimeGlob", + "scalarAssignmentResult", + "(Lorg/perlonjava/runtime/runtimetypes/RuntimeGlob;Lorg/perlonjava/runtime/runtimetypes/RuntimeScalar;)Lorg/perlonjava/runtime/runtimetypes/RuntimeScalar;", + false); + } else { + mv.visitMethodInsn(Opcodes.INVOKEVIRTUAL, leftDescriptor, "set", rightDescriptor, false); + } } else { boolean runtimeAssignment = ctx.contextType == RuntimeContextType.RUNTIME; if (runtimeAssignment) emitterVisitor.pushCallContext(); diff --git a/src/main/java/org/perlonjava/runtime/operators/IOOperator.java b/src/main/java/org/perlonjava/runtime/operators/IOOperator.java index d72431fc01..b7a3f21d30 100644 --- a/src/main/java/org/perlonjava/runtime/operators/IOOperator.java +++ b/src/main/java/org/perlonjava/runtime/operators/IOOperator.java @@ -152,7 +152,21 @@ public static RuntimeScalar selectInPackage(RuntimeList runtimeList, int ctx, St newIO = anonIO; } RuntimeIO.setSelectedHandle(newIO); - RuntimeIO.setSelectedHandleValue(selectedHandleValue(fileHandleArg)); + RuntimeScalar selectedValue = selectedHandleValue(fileHandleArg); + if (!(selectedValue.value instanceof RuntimeGlob) + && newIO != null && newIO.globName != null + && !newIO.globName.equals("main::STDIN") + && !newIO.globName.equals("main::STDOUT") + && !newIO.globName.equals("main::STDERR")) { + RuntimeGlob owner = newIO.getOwnerGlob(); + if (owner == null) { + owner = GlobalVariable.getExistingGlobalIO(newIO.globName); + } + if (owner != null) { + selectedValue = owner.createReference(); + } + } + RuntimeIO.setSelectedHandleValue(selectedValue); RuntimeIO.setLastAccessedHandle(newIO); return fh; } @@ -172,7 +186,12 @@ private static RuntimeScalar selectedHandleValue(RuntimeScalar argument) { if (argument.value instanceof RuntimeGlob glob) { String name = glob.globName; if (name != null) { - return new RuntimeScalar(name); + if (name.equals("main::STDIN") || name.equals("main::STDOUT") + || name.equals("main::STDERR")) { + return new RuntimeScalar(name); + } + return argument.type == RuntimeScalarType.GLOBREFERENCE + ? new RuntimeScalar(argument) : glob.createReference(); } return argument.type == RuntimeScalarType.GLOBREFERENCE ? new RuntimeScalar(argument) : glob.createReference(); diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeGlob.java b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeGlob.java index 7f97e689f5..e075f6e146 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeGlob.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeGlob.java @@ -977,6 +977,12 @@ public RuntimeScalar set(RuntimeScalar value) { throw new IllegalStateException("typeglob assignment not implemented for " + value.type); } + /** Return the value produced by Perl's scalar typeglob assignment. */ + public static RuntimeScalar scalarAssignmentResult(RuntimeGlob glob, RuntimeScalar value) { + RuntimeScalar assigned = glob.set(value); + return value.type == RuntimeScalarType.CODE ? glob : assigned; + } + /** * Sets the current RuntimeScalar object to the values associated with the given RuntimeGlob. * This method effectively implements the behavior of assigning one typeglob to another, diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeIO.java b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeIO.java index 5877ace4ab..a052fcf481 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeIO.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeIO.java @@ -197,9 +197,26 @@ public static void setLastAccessedHandle(RuntimeIO io) { public static RuntimeIO getSelectedHandle() { return PerlRuntime.current().ioSelectedHandle; } public static RuntimeScalar getSelectedHandleValue() { PerlRuntime runtime = PerlRuntime.current(); - return runtime.ioSelectedHandleValue == null + RuntimeScalar selected = runtime.ioSelectedHandleValue == null ? new RuntimeScalar(runtime.ioSelectedHandle) : new RuntimeScalar(runtime.ioSelectedHandleValue); + if (selected.value instanceof RuntimeGlob glob && glob.globName != null) { + String name = glob.globName; + if (name.equals("main::STDIN") || name.equals("main::STDOUT") + || name.equals("main::STDERR")) { + return new RuntimeScalar(name); + } + String resolvedName = GlobalVariable.resolveAliasedFqn(name); + RuntimeGlob currentGlob = GlobalVariable.getExistingGlobalIO(resolvedName); + RuntimeScalar currentIO = currentGlob == null ? null : currentGlob.getIO(); + if (currentGlob == null || !resolvedName.equals(currentGlob.globName) + || currentIO == null || currentIO.value != runtime.ioSelectedHandle + || GlobalVariable.isIORefHiddenAfterStashDelete(resolvedName)) { + return selected; + } + return new RuntimeScalar(name); + } + return selected; } public static void setSelectedHandle(RuntimeIO io) { PerlRuntime runtime = PerlRuntime.current(); diff --git a/src/test/resources/unit/typeglob_scalar_result_identity.t b/src/test/resources/unit/typeglob_scalar_result_identity.t new file mode 100644 index 0000000000..79c1880882 --- /dev/null +++ b/src/test/resources/unit/typeglob_scalar_result_identity.t @@ -0,0 +1,30 @@ +use strict; +use warnings; +use Test::More; + +sub typeglob_assignment_source { 'value' } + +my $assignment_result; +{ + no strict 'refs'; + $assignment_result = *{'TypeglobAssignmentTarget::installed'} = + \&typeglob_assignment_source; +} +is(ref(\$assignment_result), 'GLOB', + 'non-void typeglob assignment returns its glob value'); + +{ + package TypeglobSelectionTarget; + open TypeglobSelectionTarget::handle, '<', 'Makefile' or die "open Makefile: $!"; +} +select TypeglobSelectionTarget::handle; +my $selected_glob = \*TypeglobSelectionTarget::handle; +my $selected_stash = \%TypeglobSelectionTarget::; +{ + no strict 'refs'; + *TypeglobSelectionTarget:: = *TypeglobSelectionSource::; +} +is(select(), $selected_glob, + 'select retains the selected glob after its stash entry is detached'); + +done_testing(); From ff8ed6b08b54b3e883776b0ddfbcc4648524127f Mon Sep 17 00:00:00 2001 From: "Flavio S. Glock" Date: Fri, 2 Oct 2026 11:06:26 +0200 Subject: [PATCH 03/41] fix: handle scalar getc EOF and argumentless system Return undef when scalar-backed getc reaches EOF. Treat system() without arguments as a child wait instead of raising a missing-command error. Add standard-Perl coverage for both behaviors. Generated with [Codex](https://openai.com/codex) Co-Authored-By: Codex <158243242+codex@users.noreply.github.com> --- docs/about/changelog.md | 1 + .../perlonjava/runtime/operators/IOOperator.java | 6 +++++- .../runtime/operators/SystemOperator.java | 6 +++++- .../unit/io_system_no_command_and_getc_eof.t | 16 ++++++++++++++++ 4 files changed, 27 insertions(+), 2 deletions(-) create mode 100644 src/test/resources/unit/io_system_no_command_and_getc_eof.t diff --git a/docs/about/changelog.md b/docs/about/changelog.md index 6bada2eb21..d094e6af5f 100644 --- a/docs/about/changelog.md +++ b/docs/about/changelog.md @@ -8,6 +8,7 @@ priorities and future plans. - Keep `close` and `fileno` probes from creating nonexistent symbolic filehandles. - Preserve typeglob values from scalar assignments and selected-handle lookups. +- Return EOF as undef from scalar-backed `getc`, and let argumentless `system()` wait. - Preserve objects with counted collection owners during weak-reference sweeps, and resolve deferred user-defined regex properties in the match caller's diff --git a/src/main/java/org/perlonjava/runtime/operators/IOOperator.java b/src/main/java/org/perlonjava/runtime/operators/IOOperator.java index b7a3f21d30..0f9b2f157d 100644 --- a/src/main/java/org/perlonjava/runtime/operators/IOOperator.java +++ b/src/main/java/org/perlonjava/runtime/operators/IOOperator.java @@ -616,7 +616,11 @@ public static RuntimeScalar getc(int ctx, RuntimeBase... args) { } if (fh.ioHandle != null) { - return fh.ioHandle.read(1); + RuntimeScalar character = fh.ioHandle.read(1); + if (character.type != RuntimeScalarType.UNDEF && character.toString().isEmpty()) { + return scalarUndef; + } + return character; } throw new PerlCompilerException("No input source available"); } diff --git a/src/main/java/org/perlonjava/runtime/operators/SystemOperator.java b/src/main/java/org/perlonjava/runtime/operators/SystemOperator.java index de2f97a06c..6e5c2abd88 100644 --- a/src/main/java/org/perlonjava/runtime/operators/SystemOperator.java +++ b/src/main/java/org/perlonjava/runtime/operators/SystemOperator.java @@ -204,7 +204,11 @@ public static RuntimeScalar system(RuntimeList args, boolean hasHandle, int ctx) // Flatten the arguments - arrays and lists should be expanded to individual elements List flattenedArgs = flattenToStringList(args.elements); if (flattenedArgs.isEmpty()) { - throw new PerlCompilerException("system: no command specified"); + RuntimeScalar waited = WaitpidOperator.waitForChild(); + if (waited.getLong() < 0) { + return new RuntimeScalar(-1); + } + return new RuntimeScalar(getGlobalVariable("main::?")); } CommandResult result; diff --git a/src/test/resources/unit/io_system_no_command_and_getc_eof.t b/src/test/resources/unit/io_system_no_command_and_getc_eof.t new file mode 100644 index 0000000000..60be06fc2f --- /dev/null +++ b/src/test/resources/unit/io_system_no_command_and_getc_eof.t @@ -0,0 +1,16 @@ +use strict; +use warnings; +use Test::More; + +my $system_status; +my $system_ok = eval { $system_status = system(); 1 }; +ok($system_ok && defined $system_status, 'system() without a command returns a status'); + +my $text = 'foo'; +open my $scalar_fh, '<', \$text or die "open scalar handle: $!"; +getc $scalar_fh; +is(getc($scalar_fh), 'o', 'scalar-backed getc reads remaining content'); +is(getc($scalar_fh), 'o', 'scalar-backed getc reads final content'); +is(getc($scalar_fh), undef, 'scalar-backed getc returns undef at EOF'); + +done_testing(); From 5d7fbe53c5260044b44a13e7f3e2a2971315fb79 Mon Sep 17 00:00:00 2001 From: "Flavio S. Glock" Date: Fri, 2 Oct 2026 11:21:01 +0200 Subject: [PATCH 04/41] fix: resolve symbolic pipe handles and reuse closed stdin fd Resolve scalar values passed to pipe as named globs, and assign descriptor 0 when STDIN has been closed and no handle owns that descriptor. Add regression coverage for both behaviors. Generated with [Codex](https://openai.com/codex) Co-Authored-By: Codex <158243242+codex@users.noreply.github.com> --- docs/about/changelog.md | 2 ++ .../runtime/operators/IOOperator.java | 8 ++++++++ .../runtime/runtimetypes/RuntimeIO.java | 11 +++++++++++ .../unit/pipe_symbolic_handle_and_fd_reuse.t | 19 +++++++++++++++++++ 4 files changed, 40 insertions(+) create mode 100644 src/test/resources/unit/pipe_symbolic_handle_and_fd_reuse.t diff --git a/docs/about/changelog.md b/docs/about/changelog.md index d094e6af5f..1eebb688d0 100644 --- a/docs/about/changelog.md +++ b/docs/about/changelog.md @@ -9,6 +9,8 @@ priorities and future plans. - Keep `close` and `fileno` probes from creating nonexistent symbolic filehandles. - Preserve typeglob values from scalar assignments and selected-handle lookups. - Return EOF as undef from scalar-backed `getc`, and let argumentless `system()` wait. +- Resolve scalar pipe names as symbolic handles and reuse descriptor 0 after + closing STDIN. - Preserve objects with counted collection owners during weak-reference sweeps, and resolve deferred user-defined regex properties in the match caller's diff --git a/src/main/java/org/perlonjava/runtime/operators/IOOperator.java b/src/main/java/org/perlonjava/runtime/operators/IOOperator.java index 0f9b2f157d..180e76bca5 100644 --- a/src/main/java/org/perlonjava/runtime/operators/IOOperator.java +++ b/src/main/java/org/perlonjava/runtime/operators/IOOperator.java @@ -2893,6 +2893,10 @@ public static RuntimeScalar pipe(int ctx, RuntimeBase... args) { if ((readHandle.type == RuntimeScalarType.GLOB || readHandle.type == RuntimeScalarType.GLOBREFERENCE) && readHandle.value instanceof RuntimeGlob glob) { readGlob = glob; + } else if (readHandle.isString()) { + String name = NameNormalizer.normalizeVariableName( + readHandle.toString(), RuntimeCode.getCurrentPackage()); + readGlob = GlobalVariable.getGlobalIO(name); } if (readGlob != null) { readGlob.setIO(readerIO); @@ -2911,6 +2915,10 @@ public static RuntimeScalar pipe(int ctx, RuntimeBase... args) { if ((writeHandle.type == RuntimeScalarType.GLOB || writeHandle.type == RuntimeScalarType.GLOBREFERENCE) && writeHandle.value instanceof RuntimeGlob glob) { writeGlob = glob; + } else if (writeHandle.isString()) { + String name = NameNormalizer.normalizeVariableName( + writeHandle.toString(), RuntimeCode.getCurrentPackage()); + writeGlob = GlobalVariable.getGlobalIO(name); } if (writeGlob != null) { writeGlob.setIO(writerIO); diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeIO.java b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeIO.java index a052fcf481..60163ffef3 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeIO.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeIO.java @@ -324,6 +324,17 @@ public int assignFileno() { if (existing != null) { return existing; } + // POSIX open() assigns the lowest available descriptor. If STDIN was + // explicitly closed, the next regular handle receives descriptor 0. + // Keep that slot in the RuntimeIO registry so fileno() and later dup/ + // require operations observe the same descriptor until it is closed. + RuntimeIO stdin = getStdin(); + if (stdin != null && stdin.ioHandle instanceof ClosedIOHandle + && !registry.filenoToIO.containsKey(StandardIO.STDIN_FILENO)) { + registry.filenoToIO.put(StandardIO.STDIN_FILENO, this); + registry.ioToFileno.put(this, StandardIO.STDIN_FILENO); + return StandardIO.STDIN_FILENO; + } // First, process any GC'd globs to free their fds processAbandonedGlobs(); // Try to reuse the lowest freed fd diff --git a/src/test/resources/unit/pipe_symbolic_handle_and_fd_reuse.t b/src/test/resources/unit/pipe_symbolic_handle_and_fd_reuse.t new file mode 100644 index 0000000000..04c1a47941 --- /dev/null +++ b/src/test/resources/unit/pipe_symbolic_handle_and_fd_reuse.t @@ -0,0 +1,19 @@ +#!/usr/bin/env perl + +use strict; +use warnings; +use Test::More tests => 5; +no strict 'refs'; + +my $symbolic = 'pipe_symbolic_regression'; +my $writer = 'pipe_symbolic_writer_regression'; +ok(pipe($symbolic, $writer), 'pipe accepts scalar values naming symbolic handles'); +ok(close $symbolic, 'pipe reader is installed in the named glob'); +ok(close $writer, 'pipe writer is installed in the named glob'); +ok(!close $symbolic, 'closing the scalar name again sees the closed named glob'); + +# Keep this last: it closes the process stdin so the next open must reuse fd 0. +close STDIN or die "close STDIN: $!"; +open my $fh, '<', __FILE__ or die "open test source: $!"; +is(fileno($fh), 0, 'open reuses fd 0 after STDIN is closed'); +close $fh or die "close file: $!"; From 74a598bc79f80aa89ce445222f253022ea081384 Mon Sep 17 00:00:00 2001 From: "Flavio S. Glock" Date: Fri, 2 Oct 2026 11:33:35 +0200 Subject: [PATCH 05/41] fix: enforce readonly splice and tied array size checks Reject splice on a read-only array and report a negative value returned by FETCHSIZE. Add regression coverage for both array behaviors. Generated with [Codex](https://openai.com/codex) Co-Authored-By: Codex <158243242+codex@users.noreply.github.com> --- docs/about/changelog.md | 1 + .../runtime/operators/Operator.java | 2 ++ .../runtime/runtimetypes/TieArray.java | 6 ++++- .../unit/readonly_splice_and_tied_fetchsize.t | 26 +++++++++++++++++++ 4 files changed, 34 insertions(+), 1 deletion(-) create mode 100644 src/test/resources/unit/readonly_splice_and_tied_fetchsize.t diff --git a/docs/about/changelog.md b/docs/about/changelog.md index 1eebb688d0..b0a15c3f54 100644 --- a/docs/about/changelog.md +++ b/docs/about/changelog.md @@ -11,6 +11,7 @@ priorities and future plans. - Return EOF as undef from scalar-backed `getc`, and let argumentless `system()` wait. - Resolve scalar pipe names as symbolic handles and reuse descriptor 0 after closing STDIN. +- Reject splice on read-only arrays and negative tied-array `FETCHSIZE` values. - Preserve objects with counted collection owners during weak-reference sweeps, and resolve deferred user-defined regex properties in the match caller's diff --git a/src/main/java/org/perlonjava/runtime/operators/Operator.java b/src/main/java/org/perlonjava/runtime/operators/Operator.java index 9044bfd1a9..b254c506b8 100644 --- a/src/main/java/org/perlonjava/runtime/operators/Operator.java +++ b/src/main/java/org/perlonjava/runtime/operators/Operator.java @@ -668,6 +668,8 @@ public static RuntimeList splice(RuntimeArray runtimeArray, RuntimeList list, in yield splice(runtimeArray, list, ctx); // Recursive call after vivification } case TIED_ARRAY -> TieArray.tiedSplice(runtimeArray, list, ctx); + case READONLY_ARRAY -> throw new PerlCompilerException( + "Modification of a read-only value attempted"); default -> throw new IllegalStateException("Unknown array type: " + runtimeArray.type); }; diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/TieArray.java b/src/main/java/org/perlonjava/runtime/runtimetypes/TieArray.java index 36656a7b1d..90b878caf5 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/TieArray.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/TieArray.java @@ -139,7 +139,11 @@ public static RuntimeScalar tiedStore(RuntimeArray array, RuntimeScalar index, R * Gets the size of a tied array (delegates to FETCHSIZE). */ public static RuntimeScalar tiedFetchSize(RuntimeArray array) { - return tieCall(array, "FETCHSIZE").getFirst(); + RuntimeScalar size = tieCall(array, "FETCHSIZE").getFirst(); + if (size.getInt() < 0) { + throw new PerlCompilerException("FETCHSIZE returned a negative value"); + } + return size; } /** diff --git a/src/test/resources/unit/readonly_splice_and_tied_fetchsize.t b/src/test/resources/unit/readonly_splice_and_tied_fetchsize.t new file mode 100644 index 0000000000..4d8d60a00f --- /dev/null +++ b/src/test/resources/unit/readonly_splice_and_tied_fetchsize.t @@ -0,0 +1,26 @@ +#!/usr/bin/env perl + +use strict; +use warnings; +use Test::More tests => 4; + +{ + my @readonly = (10, 11); + Internals::SvREADONLY(@readonly, 1); + my $ok = eval { splice @readonly, 1, 0, (); 1 }; + ok(!$ok, 'splice rejects a read-only array'); + like($@, qr/^Modification of a read-only value/, + 'splice reports the read-only modification'); +} + +{ + package NegativeFetchSizeRegression; + sub TIEARRAY { bless {}, $_[0] } + sub FETCHSIZE { -1 } +} + +tie my @negative_size, 'NegativeFetchSizeRegression'; +my $ok = eval { scalar @negative_size; 1 }; +ok(!$ok, 'a negative tied-array FETCHSIZE is rejected'); +like($@, qr/^FETCHSIZE returned a negative value/, + 'negative tied-array FETCHSIZE reports the error'); From 9a2bf991555184031f1d806cf049ad528b79d2f3 Mon Sep 17 00:00:00 2001 From: "Flavio S. Glock" Date: Fri, 2 Oct 2026 11:40:30 +0200 Subject: [PATCH 06/41] fix: reset array each iterator after replacement Clear the array each iterator when assigning replacement contents so the next iteration starts from index zero. Add focused regression coverage. Generated with [Codex](https://openai.com/codex) Co-Authored-By: Codex <158243242+codex@users.noreply.github.com> --- docs/about/changelog.md | 1 + .../runtime/runtimetypes/RuntimeArray.java | 4 ++++ .../unit/array_each_resets_after_assignment.t | 13 +++++++++++++ 3 files changed, 18 insertions(+) create mode 100644 src/test/resources/unit/array_each_resets_after_assignment.t diff --git a/docs/about/changelog.md b/docs/about/changelog.md index b0a15c3f54..9521a58fb8 100644 --- a/docs/about/changelog.md +++ b/docs/about/changelog.md @@ -12,6 +12,7 @@ priorities and future plans. - Resolve scalar pipe names as symbolic handles and reuse descriptor 0 after closing STDIN. - Reject splice on read-only arrays and negative tied-array `FETCHSIZE` values. +- Reset array `each` iterators when replacing their contents. - Preserve objects with counted collection owners during weak-reference sweeps, and resolve deferred user-defined regex properties in the match caller's diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeArray.java b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeArray.java index dd42d52c62..f55964a4e4 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeArray.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeArray.java @@ -1391,6 +1391,7 @@ public RuntimeArray set(RuntimeScalar value) { if (this.type == READONLY_ARRAY) { throw new PerlCompilerException("Modification of a read-only value attempted"); } + this.eachIteratorIndex = null; notePackageRootMutation(); MortalList.deferDestroyForContainerClear(this.elements); this.elements.clear(); @@ -1412,6 +1413,7 @@ public RuntimeArray set(RuntimeScalar value) { public RuntimeArray setFromList(RuntimeList list) { return switch (type) { case PLAIN_ARRAY -> { + this.eachIteratorIndex = null; notePackageRootMutation(); // Check if the list contains references to this array's elements // If so, we need to save the values before clearing @@ -1542,6 +1544,7 @@ public RuntimeArray setFromListAliased(RuntimeList list) { // refcount-inflation risk is lower there. return setFromList(list); } + this.eachIteratorIndex = null; notePackageRootMutation(); MortalList.deferDestroyForContainerClear(this.elements); this.elements.clear(); @@ -1568,6 +1571,7 @@ public RuntimeArray setFromReferenceList(RuntimeList list) { if (type != PLAIN_ARRAY) { throw new PerlCompilerException("Assignment to unsupported ref aliasing target"); } + this.eachIteratorIndex = null; RuntimeArray references = new RuntimeArray(); references.setFromList(list); notePackageRootMutation(); diff --git a/src/test/resources/unit/array_each_resets_after_assignment.t b/src/test/resources/unit/array_each_resets_after_assignment.t new file mode 100644 index 0000000000..c080f537c7 --- /dev/null +++ b/src/test/resources/unit/array_each_resets_after_assignment.t @@ -0,0 +1,13 @@ +#!/usr/bin/env perl + +use strict; +use warnings; +use Test::More tests => 2; + +my @items = 'a' .. 'c'; +my ($index, $value) = each @items; +is("$index-$value", '0-a', 'each starts at the first array element'); + +@items = 'A' .. 'C'; +($index, $value) = each @items; +is("$index-$value", '0-A', 'array replacement resets the each iterator'); From 44767b80b4af81db84ab2706c7c6b974e86e0d43 Mon Sep 17 00:00:00 2001 From: "Flavio S. Glock" Date: Fri, 2 Oct 2026 12:04:50 +0200 Subject: [PATCH 07/41] fix: fetch tied values during study and clear crypt UTF-8 flag Make study fetch tied scalars on both execution backends. Return crypt output as an unflagged byte string so assignment replaces a wide target cleanly. Generated with [Codex](https://openai.com/codex) Co-Authored-By: Codex <158243242+codex@users.noreply.github.com> --- docs/about/changelog.md | 2 ++ .../backend/bytecode/CompileOperator.java | 9 ++++++++- .../runtime/CoreSubroutineGenerator.java | 5 ++++- .../perlonjava/runtime/operators/Crypt.java | 4 +++- .../runtime/runtimetypes/RuntimeScalar.java | 3 +++ .../unit/study_tied_scalar_and_crypt_utf8.t | 20 +++++++++++++++++++ 6 files changed, 40 insertions(+), 3 deletions(-) create mode 100644 src/test/resources/unit/study_tied_scalar_and_crypt_utf8.t diff --git a/docs/about/changelog.md b/docs/about/changelog.md index 9521a58fb8..64293de9d3 100644 --- a/docs/about/changelog.md +++ b/docs/about/changelog.md @@ -13,6 +13,8 @@ priorities and future plans. closing STDIN. - Reject splice on read-only arrays and negative tied-array `FETCHSIZE` values. - Reset array `each` iterators when replacing their contents. +- Fetch tied scalars during `study` and return `crypt` results without the + UTF-8 flag. - Preserve objects with counted collection owners during weak-reference sweeps, and resolve deferred user-defined regex properties in the match caller's diff --git a/src/main/java/org/perlonjava/backend/bytecode/CompileOperator.java b/src/main/java/org/perlonjava/backend/bytecode/CompileOperator.java index 6c4ae3487c..6b2d07479a 100644 --- a/src/main/java/org/perlonjava/backend/bytecode/CompileOperator.java +++ b/src/main/java/org/perlonjava/backend/bytecode/CompileOperator.java @@ -1515,7 +1515,14 @@ public static void visitOperator(BytecodeCompiler bytecodeCompiler, OperatorNode bytecodeCompiler.lastResultReg = rd; } case "study" -> { - if (node.operand != null) node.operand.accept(bytecodeCompiler); + if (node.operand != null) { + node.operand.accept(bytecodeCompiler); + int operandReg = bytecodeCompiler.lastResultReg; + int ignoredReg = bytecodeCompiler.allocateRegister(); + bytecodeCompiler.emit(Opcodes.DEFINED); + bytecodeCompiler.emitReg(ignoredReg); + bytecodeCompiler.emitReg(operandReg); + } int rd = bytecodeCompiler.allocateOutputRegister(); bytecodeCompiler.emit(Opcodes.LOAD_INT); bytecodeCompiler.emitReg(rd); diff --git a/src/main/java/org/perlonjava/runtime/CoreSubroutineGenerator.java b/src/main/java/org/perlonjava/runtime/CoreSubroutineGenerator.java index 4c14cf5481..a36d26dbd2 100644 --- a/src/main/java/org/perlonjava/runtime/CoreSubroutineGenerator.java +++ b/src/main/java/org/perlonjava/runtime/CoreSubroutineGenerator.java @@ -458,7 +458,10 @@ private static RuntimeList callUnary(String name, RuntimeScalar arg) { case "sleep" -> Time.sleep(arg).getList(); case "sqrt" -> MathOperators.sqrt(arg).getList(); case "srand" -> Random.srand(arg).getList(); - case "study" -> new RuntimeScalar(1).getList(); // study is a no-op + case "study" -> { + arg.study(); + yield new RuntimeScalar(1).getList(); + } case "uc" -> StringOperators.uc(arg).getList(); case "ucfirst" -> StringOperators.ucfirst(arg).getList(); default -> diff --git a/src/main/java/org/perlonjava/runtime/operators/Crypt.java b/src/main/java/org/perlonjava/runtime/operators/Crypt.java index f3891497d1..709a9f72fb 100644 --- a/src/main/java/org/perlonjava/runtime/operators/Crypt.java +++ b/src/main/java/org/perlonjava/runtime/operators/Crypt.java @@ -5,6 +5,7 @@ import java.security.MessageDigest; import java.security.NoSuchAlgorithmException; +import java.nio.charset.StandardCharsets; import java.util.Base64; import static org.perlonjava.frontend.parser.StringParser.assertNoWideCharacters; @@ -50,7 +51,8 @@ public static RuntimeScalar crypt(RuntimeList args) { } String hashed = hashWithSalt(plaintext, salt); - return new RuntimeScalar(hashed).propagateTaint(plaintextScalar, saltScalar); + RuntimeScalar result = new RuntimeScalar(hashed.getBytes(StandardCharsets.ISO_8859_1)); + return result.propagateTaint(plaintextScalar, saltScalar); } /** diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeScalar.java b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeScalar.java index 85d75d24de..0c315ff3be 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeScalar.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeScalar.java @@ -1113,6 +1113,9 @@ private void setIntegerValue(BigInteger integerValue) { } public RuntimeScalar study() { + if (type == TIED_SCALAR) { + tiedFetch(); + } return scalarUndef; } diff --git a/src/test/resources/unit/study_tied_scalar_and_crypt_utf8.t b/src/test/resources/unit/study_tied_scalar_and_crypt_utf8.t new file mode 100644 index 0000000000..ebaaabcd99 --- /dev/null +++ b/src/test/resources/unit/study_tied_scalar_and_crypt_utf8.t @@ -0,0 +1,20 @@ +#!/usr/bin/env perl + +use strict; +use warnings; +use Test::More tests => 2; + +{ + package StudyTieRegression; + sub TIESCALAR { bless {}, $_[0] } + sub FETCH { ++$main::study_tie_fetches == 1 ? 'first' : 'next' } +} + +our $study_tie_fetches = 0; +tie my $value, 'StudyTieRegression'; +study $value; +is($value, 'next', 'study fetches a tied scalar before later reads'); + +my $target = chr 256; +$target = crypt 'foo', 'bar'; +ok(!utf8::is_utf8($target), 'crypt assignment clears the target UTF-8 flag'); From 88d429a09051a694be50cadbbe351925334eb78c Mon Sep 17 00:00:00 2001 From: "Flavio S. Glock" Date: Fri, 2 Oct 2026 12:16:30 +0200 Subject: [PATCH 08/41] fix: reject evalbytes when its feature is disabled Keep the feature-gated evalbytes keyword from falling through to ordinary subroutine lookup when disabled. Add a regression for the syntax diagnostic. Generated with [Codex](https://openai.com/codex) Co-Authored-By: Codex <158243242+codex@users.noreply.github.com> --- docs/about/changelog.md | 1 + .../org/perlonjava/frontend/parser/ParsePrimary.java | 6 ++++++ src/test/resources/unit/evalbytes_requires_feature.t | 11 +++++++++++ 3 files changed, 18 insertions(+) create mode 100644 src/test/resources/unit/evalbytes_requires_feature.t diff --git a/docs/about/changelog.md b/docs/about/changelog.md index 64293de9d3..494c2f9c97 100644 --- a/docs/about/changelog.md +++ b/docs/about/changelog.md @@ -15,6 +15,7 @@ priorities and future plans. - Reset array `each` iterators when replacing their contents. - Fetch tied scalars during `study` and return `crypt` results without the UTF-8 flag. +- Report disabled `evalbytes` as a syntax error. - Preserve objects with counted collection owners during weak-reference sweeps, and resolve deferred user-defined regex properties in the match caller's diff --git a/src/main/java/org/perlonjava/frontend/parser/ParsePrimary.java b/src/main/java/org/perlonjava/frontend/parser/ParsePrimary.java index fd65e2368d..13534c45bc 100644 --- a/src/main/java/org/perlonjava/frontend/parser/ParsePrimary.java +++ b/src/main/java/org/perlonjava/frontend/parser/ParsePrimary.java @@ -235,6 +235,12 @@ private static Node parseIdentifier(Parser parser, int startIndex, LexerToken to }; } + if (operator.equals("evalbytes") && !operatorEnabled && !calledWithCore) { + var location = parser.ctx.errorUtil.getSourceLocationAccurate(startIndex); + throw new PerlParserException("syntax error at " + location.fileName() + + " line " + location.lineNumber() + ", near \"evalbytes\""); + } + // Check for overridable operators (unless explicitly called with CORE::) if (!calledWithCore && operatorEnabled && ParserTables.OVERRIDABLE_OP.contains(operator)) { // Core functions can be overridden in two ways: diff --git a/src/test/resources/unit/evalbytes_requires_feature.t b/src/test/resources/unit/evalbytes_requires_feature.t new file mode 100644 index 0000000000..0cd301fec5 --- /dev/null +++ b/src/test/resources/unit/evalbytes_requires_feature.t @@ -0,0 +1,11 @@ +#!/usr/bin/env perl + +use strict; +use warnings; +use Test::More tests => 1; + +{ + no feature 'evalbytes'; + eval q{evalbytes 'foo'}; + like($@, qr/syntax error/, 'evalbytes is a syntax error when its feature is disabled'); +} From 9189741e4105a81d3c9503762f91c48d410be85f Mon Sep 17 00:00:00 2001 From: "Flavio S. Glock" Date: Fri, 2 Oct 2026 12:33:06 +0200 Subject: [PATCH 09/41] fix: warn when hash keys are inserted during each Emit Perl's internal warning when a new key is inserted while a hash each iterator is active. Respect lexical suppression of internal warnings. Generated with [Codex](https://openai.com/codex) Co-Authored-By: Codex <158243242+codex@users.noreply.github.com> --- docs/about/changelog.md | 1 + .../runtime/runtimetypes/RuntimeHash.java | 15 ++++++++++ .../resources/unit/hash_each_insert_warning.t | 28 +++++++++++++++++++ 3 files changed, 44 insertions(+) create mode 100644 src/test/resources/unit/hash_each_insert_warning.t diff --git a/docs/about/changelog.md b/docs/about/changelog.md index 494c2f9c97..7db8681a74 100644 --- a/docs/about/changelog.md +++ b/docs/about/changelog.md @@ -16,6 +16,7 @@ priorities and future plans. - Fetch tied scalars during `study` and return `crypt` results without the UTF-8 flag. - Report disabled `evalbytes` as a syntax error. +- Warn when inserting new keys into a hash during an active `each` traversal. - Preserve objects with counted collection owners during weak-reference sweeps, and resolve deferred user-defined regex properties in the match caller's diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeHash.java b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeHash.java index 96459f26c6..021617c2dc 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeHash.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeHash.java @@ -51,6 +51,7 @@ private static Stack dynamicStateStack() { public String taintEnvironmentAliasDescription; // Iterator for traversing the hash elements Iterator hashIterator; + private boolean hashIteratorInsertionWarningIssued; // Track which keys were stored with BYTE_STRING type (vs STRING/UTF-8). // In Perl, hash keys preserve their byte/UTF-8 flag, which affects regex matching semantics. // Lazily initialized to avoid overhead when key type tracking is not needed. @@ -594,6 +595,7 @@ public void put(String key, RuntimeScalar value) { // slot container. This matters for pure-Perl deep-cloners // which preserve referent identity while populating hashes. RuntimeScalar existing = elements.get(key); + warnHashIteratorInsertion(existing); if (isDestroyRescueAssignment(existing, value)) { value.addToScalar(existing); } else if (existing != null @@ -609,6 +611,7 @@ && isAggregateClearAssignment(existing, value)) { case AUTOVIVIFY_HASH -> { AutovivificationHash.vivify(this); RuntimeScalar existing = elements.get(key); + warnHashIteratorInsertion(existing); if (isDestroyRescueAssignment(existing, value)) { value.addToScalar(existing); } else if (existing != null @@ -631,6 +634,17 @@ && isAggregateClearAssignment(existing, value)) { } } + private void warnHashIteratorInsertion(RuntimeScalar existing) { + if (existing != null || hashIterator == null || hashIteratorInsertionWarningIssued) { + return; + } + hashIteratorInsertionWarningIssued = true; + WarnDie.warnWithCategoryByDefault( + new RuntimeScalar("Use of each() on hash after insertion without resetting hash iterator results in undefined behavior"), + new RuntimeScalar(""), + "internal"); + } + private static RuntimeBase directReferent(RuntimeScalar scalar) { return scalar != null && scalar.value instanceof RuntimeBase base ? base : null; } @@ -1567,6 +1581,7 @@ public RuntimeList each(int ctx) { if (hashIterator == null) { hashIterator = iterator(); + hashIteratorInsertionWarningIssued = false; } if (hashIterator.hasNext()) { if (ctx == RuntimeContextType.SCALAR) { diff --git a/src/test/resources/unit/hash_each_insert_warning.t b/src/test/resources/unit/hash_each_insert_warning.t new file mode 100644 index 0000000000..78ee18b30b --- /dev/null +++ b/src/test/resources/unit/hash_each_insert_warning.t @@ -0,0 +1,28 @@ +#!/usr/bin/env perl + +use strict; +use warnings; +use Test::More tests => 2; + +my $warned = 0; +{ + local $SIG{__WARN__} = sub { + ++$warned if $_[0] =~ /Use of each\(\) on hash after insertion without resetting hash iterator results in undefined behavior/; + }; + my %items = map { $_ => $_ } 'A' .. 'F'; + while (my ($key, $value) = each %items) { + $items{"$key$key"} = $value; + } +} +ok($warned > 0, 'insertion during each warns when warnings are enabled'); + +$warned = 0; +{ + no warnings 'internal'; + local $SIG{__WARN__} = sub { ++$warned }; + my %items = map { $_ => $_ } 'A' .. 'F'; + while (my ($key, $value) = each %items) { + $items{"$key$key"} = $value; + } +} +is($warned, 0, 'internal warning can be disabled'); From 8583449cc7df9ac768da6aaf8a208ca82e99639e Mon Sep 17 00:00:00 2001 From: "Flavio S. Glock" Date: Fri, 2 Oct 2026 12:54:18 +0200 Subject: [PATCH 10/41] fix: preserve scalar list values in defined expressions Compile parenthesized lists in scalar context as their final value and limit defined's take-reference parsing to direct code reference probes. Generated with [Codex](https://openai.com/codex) Co-Authored-By: Codex <158243242+codex@users.noreply.github.com> --- docs/about/changelog.md | 1 + .../backend/bytecode/CompileOperator.java | 6 +++++- .../frontend/parser/OperatorParser.java | 16 ++++++++++++++-- .../resources/unit/scalar_list_context_defined.t | 15 +++++++++++++++ 4 files changed, 35 insertions(+), 3 deletions(-) create mode 100644 src/test/resources/unit/scalar_list_context_defined.t diff --git a/docs/about/changelog.md b/docs/about/changelog.md index 7db8681a74..bee4d161ce 100644 --- a/docs/about/changelog.md +++ b/docs/about/changelog.md @@ -17,6 +17,7 @@ priorities and future plans. UTF-8 flag. - Report disabled `evalbytes` as a syntax error. - Warn when inserting new keys into a hash during an active `each` traversal. +- Return the final expression from parenthesized lists in scalar context. - Preserve objects with counted collection owners during weak-reference sweeps, and resolve deferred user-defined regex properties in the match caller's diff --git a/src/main/java/org/perlonjava/backend/bytecode/CompileOperator.java b/src/main/java/org/perlonjava/backend/bytecode/CompileOperator.java index 6b2d07479a..5c4146b303 100644 --- a/src/main/java/org/perlonjava/backend/bytecode/CompileOperator.java +++ b/src/main/java/org/perlonjava/backend/bytecode/CompileOperator.java @@ -1217,7 +1217,11 @@ public static void visitOperator(BytecodeCompiler bytecodeCompiler, OperatorNode ? RuntimeContextType.LVALUE : RuntimeContextType.SCALAR; bytecodeCompiler.compileNode(node.operand, -1, operandContext); int operandReg = bytecodeCompiler.lastResultReg; - if (operandContext == RuntimeContextType.LVALUE) { + if (operandContext == RuntimeContextType.LVALUE + || node.operand instanceof ListNode) { + // A parenthesized expression list in scalar context + // evaluates to its final value. ARRAY_SIZE is only + // appropriate for aggregate operands such as @array. bytecodeCompiler.lastResultReg = operandReg; } else { int rd = bytecodeCompiler.allocateOutputRegister(); diff --git a/src/main/java/org/perlonjava/frontend/parser/OperatorParser.java b/src/main/java/org/perlonjava/frontend/parser/OperatorParser.java index 23a6934d59..7580f78035 100644 --- a/src/main/java/org/perlonjava/frontend/parser/OperatorParser.java +++ b/src/main/java/org/perlonjava/frontend/parser/OperatorParser.java @@ -1448,9 +1448,21 @@ private static void transformCodeRefPatterns(Parser parser, ListNode operand, St static OperatorNode parseDefined(Parser parser, LexerToken token, int currentIndex) { ListNode operand; - // Handle 'defined' operator with special parsing context + // A direct `defined &sub` probes the CODE slot rather than calling it. + // Do not let that context leak into nested expressions: in + // `defined scalar(42, &sub)`, the ampersand is an old-style call and + // the scalar expression's final value is what defined() checks. boolean parsingTakeReference = parser.parsingTakeReference; - parser.parsingTakeReference = true; // don't call `&subr` while parsing "Take reference" + int argumentIndex = Whitespace.skipWhitespace(parser, parser.tokenIndex, parser.tokens); + boolean directCodeReference = argumentIndex < parser.tokens.size() + && parser.tokens.get(argumentIndex).text.equals("&"); + if (!directCodeReference && argumentIndex < parser.tokens.size() + && parser.tokens.get(argumentIndex).text.equals("(")) { + int nestedIndex = Whitespace.skipWhitespace(parser, argumentIndex + 1, parser.tokens); + directCodeReference = nestedIndex < parser.tokens.size() + && parser.tokens.get(nestedIndex).text.equals("&"); + } + parser.parsingTakeReference = directCodeReference; operand = ListParser.parseZeroOrOneList(parser, 0, "defined"); parser.parsingTakeReference = parsingTakeReference; if (operand.elements.isEmpty()) { diff --git a/src/test/resources/unit/scalar_list_context_defined.t b/src/test/resources/unit/scalar_list_context_defined.t new file mode 100644 index 0000000000..a65ce0b760 --- /dev/null +++ b/src/test/resources/unit/scalar_list_context_defined.t @@ -0,0 +1,15 @@ +#!/usr/bin/env perl + +use strict; +use warnings; +use Test::More tests => 2; + +sub scalar_list_returns_undef { undef } +{ + no warnings 'void'; + ok(!defined(scalar(42, &scalar_list_returns_undef)), + 'scalar list expression returns its final value for defined'); +} + +my @items = qw(one two three); +is(scalar @items, 3, 'scalar array expression returns the element count'); From f3b56a378777a743463d2053f115ea71e22dea53 Mon Sep 17 00:00:00 2001 From: "Flavio S. Glock" Date: Fri, 2 Oct 2026 13:48:48 +0200 Subject: [PATCH 11/41] fix: warn on bareword numeric exponent suffixes Emit the default syntax::bareword warning for incomplete hexadecimal float prefixes and adjacent decimal exponent-like barewords while keeping fractional nondecimal diagnostics unchanged. Generated with [Codex](https://openai.com/codex) Co-Authored-By: Codex <158243242+codex@users.noreply.github.com> --- docs/about/changelog.md | 1 + .../frontend/parser/NumberParser.java | 15 +++++++++ .../frontend/parser/ParseInfix.java | 33 +++++++++++++++++++ .../incomplete_hex_float_operator_warning.t | 22 +++++++++++++ 4 files changed, 71 insertions(+) create mode 100644 src/test/resources/unit/incomplete_hex_float_operator_warning.t diff --git a/docs/about/changelog.md b/docs/about/changelog.md index bee4d161ce..c6b7396a64 100644 --- a/docs/about/changelog.md +++ b/docs/about/changelog.md @@ -18,6 +18,7 @@ priorities and future plans. - Report disabled `evalbytes` as a syntax error. - Warn when inserting new keys into a hash during an active `each` traversal. - Return the final expression from parenthesized lists in scalar context. +- Warn about bareword exponent suffixes following numeric literals. - Preserve objects with counted collection owners during weak-reference sweeps, and resolve deferred user-defined regex properties in the match caller's diff --git a/src/main/java/org/perlonjava/frontend/parser/NumberParser.java b/src/main/java/org/perlonjava/frontend/parser/NumberParser.java index 25c3275a83..e67280f419 100644 --- a/src/main/java/org/perlonjava/frontend/parser/NumberParser.java +++ b/src/main/java/org/perlonjava/frontend/parser/NumberParser.java @@ -248,6 +248,11 @@ public static Node parseNumber(Parser parser, LexerToken token) { * Unified parsing method for special number formats (binary, octal, hex) */ private static Node parseSpecialNumber(Parser parser, String initialPart, NumberFormat format) { + if (format == HEX_FORMAT && initialPart.startsWith("p") + && initialPart.length() > 1) { + warnMissingOperatorBeforeBareword(parser, initialPart, + "0x" + initialPart, Math.max(0, parser.tokenIndex - 1)); + } if (!containsDigitForFormat(initialPart, format) && !hasLeadingFractionalDigit(parser, format)) { PerlParserException adjacentNumberError = @@ -504,6 +509,16 @@ private static void deferNoDigitsForLiteral(Parser parser, String initialPart, N } } + static void warnMissingOperatorBeforeBareword(Parser parser, String bareword, + String near, int tokenIndex) { + String message = "Bareword found where operator expected (Missing operator before \"" + + bareword + "\"?)"; + RuntimeScalar warning = new RuntimeScalar(message); + RuntimeScalar location = new RuntimeScalar( + parser.ctx.errorUtil.warningLocation(tokenIndex) + ", near \"" + near + "\""); + WarnDie.warnWithCategoryByDefault(warning, location, "syntax::bareword"); + } + /** * A base-literal prefix immediately after another number is not a second * expression: Perl diagnoses the missing operator first, then preserves diff --git a/src/main/java/org/perlonjava/frontend/parser/ParseInfix.java b/src/main/java/org/perlonjava/frontend/parser/ParseInfix.java index f4903f3a70..b1e4384c8d 100644 --- a/src/main/java/org/perlonjava/frontend/parser/ParseInfix.java +++ b/src/main/java/org/perlonjava/frontend/parser/ParseInfix.java @@ -639,6 +639,13 @@ public static Node parseInfixOperation(Parser parser, Node left, int precedence) && !ParserTables.INFIX_OP.contains(token.text)) { NumberNode concatenatedNumber = rightmostConcatenatedNumber(left); if (concatenatedNumber != null) { + if (left instanceof NumberNode && token.text.matches("p[0-9]+") + && !hasFractionalDotBefore(parser, operatorIndex)) { + NumberParser.warnMissingOperatorBeforeBareword(parser, token.text, + concatenatedNumber.value + token.text, operatorIndex); + throwSyntaxErrorAfterNumericBareword(parser, concatenatedNumber, + token, operatorIndex); + } throwMissingOperatorBeforeBareword(parser, concatenatedNumber, token, operatorIndex); } } @@ -808,6 +815,32 @@ private static void throwMissingOperatorBeforeBareword(Parser parser, NumberNode throw new PerlParserException(message); } + private static void throwSyntaxErrorAfterNumericBareword(Parser parser, NumberNode left, + LexerToken bareword, int barewordIndex) { + ErrorMessageUtil.SourceLocation location = + parser.ctx.errorUtil.getSourceLocationAccurate(barewordIndex); + String near = left.value + bareword.text; + String at = " at " + location.fileName() + " line " + location.lineNumber() + + ", near \"" + near + "\"\n"; + throw new PerlParserException("syntax error" + at + "Execution of " + + location.fileName() + " aborted due to compilation errors.\n"); + } + + private static boolean hasFractionalDotBefore(Parser parser, int tokenIndex) { + int previous = tokenIndex - 1; + while (previous >= 0 && parser.tokens.get(previous).type == LexerTokenType.WHITESPACE) { + previous--; + } + if (previous < 0 || parser.tokens.get(previous).type != LexerTokenType.NUMBER) { + return false; + } + previous--; + while (previous >= 0 && parser.tokens.get(previous).type == LexerTokenType.WHITESPACE) { + previous--; + } + return previous >= 0 && parser.tokens.get(previous).text.equals("."); + } + /** * Perl's bitwise compound assignments are scalar operations. Applying * them to an aggregate is rejected during compilation rather than reaching diff --git a/src/test/resources/unit/incomplete_hex_float_operator_warning.t b/src/test/resources/unit/incomplete_hex_float_operator_warning.t new file mode 100644 index 0000000000..3f1f0b4c4e --- /dev/null +++ b/src/test/resources/unit/incomplete_hex_float_operator_warning.t @@ -0,0 +1,22 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More tests => 3; + +for my $source ('0xp3', '5p3') { + my $warning; + { + local $SIG{__WARN__} = sub { $warning = shift }; + eval $source; + } + like($warning, qr/Missing operator before "p3"/, + "incomplete numeric form $source warns about the trailing exponent marker"); +} + +my $suppressed_warning; +{ + no warnings 'syntax'; + local $SIG{__WARN__} = sub { $suppressed_warning = shift }; + eval '5p3'; +} +ok(!defined $suppressed_warning, 'no warnings syntax suppresses the bareword warning'); From 23ebe5a5feb54193a6702faac3045767be893aa0 Mon Sep 17 00:00:00 2001 From: "Flavio S. Glock" Date: Fri, 2 Oct 2026 13:57:00 +0200 Subject: [PATCH 12/41] fix: preserve undef range list value Keep the list-context value for undef..undef as the empty string so the range does not coerce both endpoints to numeric zero. Generated with [Codex](https://openai.com/codex) Co-Authored-By: Codex <158243242+codex@users.noreply.github.com> --- docs/about/changelog.md | 1 + .../perlonjava/runtime/runtimetypes/PerlRange.java | 7 +++++++ src/test/resources/unit/undef_range_is_empty.t | 12 ++++++++++++ 3 files changed, 20 insertions(+) create mode 100644 src/test/resources/unit/undef_range_is_empty.t diff --git a/docs/about/changelog.md b/docs/about/changelog.md index c6b7396a64..771350d8ab 100644 --- a/docs/about/changelog.md +++ b/docs/about/changelog.md @@ -19,6 +19,7 @@ priorities and future plans. - Warn when inserting new keys into a hash during an active `each` traversal. - Return the final expression from parenthesized lists in scalar context. - Warn about bareword exponent suffixes following numeric literals. +- Preserve the empty string yielded by a range with two undefined endpoints. - Preserve objects with counted collection owners during weak-reference sweeps, and resolve deferred user-defined regex properties in the match caller's diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/PerlRange.java b/src/main/java/org/perlonjava/runtime/runtimetypes/PerlRange.java index a3f8546b7e..4731d9d5c9 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/PerlRange.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/PerlRange.java @@ -15,6 +15,7 @@ public class PerlRange extends RuntimeBase implements Iterable { private final RuntimeScalar start; private final RuntimeScalar end; + private final boolean bothEndpointsUndefined; /** * Constructs a PerlRange with the specified start and end values. @@ -60,6 +61,9 @@ public PerlRange(RuntimeScalar start, RuntimeScalar end) { evalEnd = evalEnd.tiedFetch(); } + bothEndpointsUndefined = evalStart.type == RuntimeScalarType.UNDEF + && evalEnd.type == RuntimeScalarType.UNDEF; + // Handle undef values: treat as 0 for numeric context or "" for string context // We'll determine context based on the other operand or default to numeric if (evalStart.type == RuntimeScalarType.UNDEF) { @@ -106,6 +110,9 @@ public static PerlRange createRange(RuntimeScalar start, RuntimeScalar end) { */ @Override public Iterator iterator() { + if (bothEndpointsUndefined) { + return scalarEmptyString.iterator(); + } if (start.type == RuntimeScalarType.INTEGER) { // Use integer iterator for integer ranges return new PerlRangeIntegerIterator(); diff --git a/src/test/resources/unit/undef_range_is_empty.t b/src/test/resources/unit/undef_range_is_empty.t new file mode 100644 index 0000000000..2db244594a --- /dev/null +++ b/src/test/resources/unit/undef_range_is_empty.t @@ -0,0 +1,12 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More tests => 2; + +is(join(':', map "[$_]", undef .. undef), '[]', + 'undef .. undef yields an empty string in list context'); + +my @loop_values; +push @loop_values, $_ for undef .. undef; +is(join(':', map "[$_]", @loop_values), '[]', + 'undef .. undef yields an empty string in a for loop'); From 70a064d57a80520490e286440599c991468e5d06 Mon Sep 17 00:00:00 2001 From: "Flavio S. Glock" Date: Fri, 2 Oct 2026 15:09:28 +0200 Subject: [PATCH 13/41] fix: avoid fetching discarded empty list assignment values Preserve side effects for empty list assignments in void context without materializing tied scalar repeats, while retaining list context for regex matches that produce callback or position state. Generated with [Codex](https://openai.com/codex) Co-Authored-By: Codex <158243242+codex@users.noreply.github.com> --- docs/about/changelog.md | 1 + .../backend/bytecode/BytecodeCompiler.java | 18 +++++++++++++++++- .../backend/bytecode/CompileAssignment.java | 17 +++++++++++++++++ .../perlonjava/backend/jvm/EmitVariable.java | 18 ++++++++++++++++++ .../perlonjava/runtime/operators/Operator.java | 4 ++++ .../unit/empty_list_assignment_void_context.t | 15 +++++++++++++++ 6 files changed, 72 insertions(+), 1 deletion(-) create mode 100644 src/test/resources/unit/empty_list_assignment_void_context.t diff --git a/docs/about/changelog.md b/docs/about/changelog.md index 771350d8ab..5cc76bbbd5 100644 --- a/docs/about/changelog.md +++ b/docs/about/changelog.md @@ -20,6 +20,7 @@ priorities and future plans. - Return the final expression from parenthesized lists in scalar context. - Warn about bareword exponent suffixes following numeric literals. - Preserve the empty string yielded by a range with two undefined endpoints. +- Avoid materializing values from empty list assignments in void context. - Preserve objects with counted collection owners during weak-reference sweeps, and resolve deferred user-defined regex properties in the match caller's diff --git a/src/main/java/org/perlonjava/backend/bytecode/BytecodeCompiler.java b/src/main/java/org/perlonjava/backend/bytecode/BytecodeCompiler.java index 263a75ff71..ec9520e1d3 100644 --- a/src/main/java/org/perlonjava/backend/bytecode/BytecodeCompiler.java +++ b/src/main/java/org/perlonjava/backend/bytecode/BytecodeCompiler.java @@ -2078,7 +2078,12 @@ public void visit(BlockNode node) { boolean isLastStatement = (i == lastMeaningfulIndex); int stmtTarget = (isLastStatement && outerResultReg >= 0) ? outerResultReg : -1; int stmtContext; - if (!isLastStatement && !(stmt instanceof BinaryOperatorNode && ((BinaryOperatorNode) stmt).operator.equals("="))) { + boolean emptyListAssignment = stmt instanceof BinaryOperatorNode assignment + && assignment.operator.equals("=") + && assignment.left instanceof ListNode targets + && targets.elements.isEmpty(); + if (!isLastStatement && (!(stmt instanceof BinaryOperatorNode assignment + && assignment.operator.equals("=")) || emptyListAssignment)) { stmtContext = RuntimeContextType.VOID; } else { stmtContext = isLastStatement && node.getBooleanAnnotation("subroutineIsLvalue") @@ -9181,6 +9186,17 @@ public void visit(ListNode node) { return; } + if (currentCallContext == RuntimeContextType.VOID + && node.getBooleanAnnotation("emptyTargetAssignmentVoidRhs")) { + for (Node element : node.elements) { + int elementContext = RegexUsageDetector.containsRegexOperation(element) + ? RuntimeContextType.LIST : RuntimeContextType.VOID; + compileNode(element, -1, elementContext); + } + lastResultReg = -1; + return; + } + int elementContext = switch (currentCallContext) { case RuntimeContextType.RUNTIME -> RuntimeContextType.RUNTIME; case RuntimeContextType.LVALUE_LIST -> RuntimeContextType.LVALUE_LIST; diff --git a/src/main/java/org/perlonjava/backend/bytecode/CompileAssignment.java b/src/main/java/org/perlonjava/backend/bytecode/CompileAssignment.java index d601f0ccb6..eb7f8cbf70 100644 --- a/src/main/java/org/perlonjava/backend/bytecode/CompileAssignment.java +++ b/src/main/java/org/perlonjava/backend/bytecode/CompileAssignment.java @@ -2,6 +2,7 @@ import org.perlonjava.frontend.analysis.ConstantFoldingVisitor; import org.perlonjava.frontend.analysis.LValueVisitor; +import org.perlonjava.frontend.analysis.RegexUsageDetector; import org.perlonjava.frontend.astnode.*; import org.perlonjava.frontend.semantic.SymbolTable; import org.perlonjava.runtime.runtimetypes.NameNormalizer; @@ -2180,6 +2181,22 @@ && isLocalizedArraySliceReferenceTarget(referenceOp.operand)) { // Set the context for subroutine calls in RHS int outerContext = bytecodeCompiler.currentCallContext; + // An empty list assignment whose value is discarded still evaluates + // its RHS for side effects, but Perl does not materialize list values + // that have no targets (notably tied scalar repeats). + if (outerContext == RuntimeContextType.VOID + && node.left instanceof ListNode emptyTargets + && emptyTargets.elements.isEmpty()) { + boolean preserveListContext = RegexUsageDetector.containsRegexOperation(node.right); + if (!preserveListContext && node.right instanceof ListNode rhsList) { + rhsList.setAnnotation("emptyTargetAssignmentVoidRhs", true); + } + bytecodeCompiler.compileNode(node.right, -1, preserveListContext + ? RuntimeContextType.LIST : RuntimeContextType.VOID); + bytecodeCompiler.lastResultReg = -1; + return; + } + // Unary plus is normally transparent around an lvalue. A parenthesized // list is the important exception: `+() = expr` is Perl's idiom for a // list assignment with no targets, whose scalar result is the number of diff --git a/src/main/java/org/perlonjava/backend/jvm/EmitVariable.java b/src/main/java/org/perlonjava/backend/jvm/EmitVariable.java index da6cd35946..a8987a1c1e 100644 --- a/src/main/java/org/perlonjava/backend/jvm/EmitVariable.java +++ b/src/main/java/org/perlonjava/backend/jvm/EmitVariable.java @@ -7,6 +7,7 @@ import org.objectweb.asm.Opcodes; import org.perlonjava.frontend.analysis.EmitterVisitor; import org.perlonjava.frontend.analysis.LValueVisitor; +import org.perlonjava.frontend.analysis.RegexUsageDetector; import org.perlonjava.frontend.astnode.*; import org.perlonjava.frontend.semantic.SymbolTable; import org.perlonjava.runtime.perlmodule.Strict; @@ -882,6 +883,23 @@ static void handleAssignOperator(EmitterVisitor emitterVisitor, BinaryOperatorNo Node left = node.left; Node right = node.right; + // An empty list assignment in void context has no targets and its + // result is discarded. Preserve RHS side effects while avoiding list + // materialization (which can fetch tied values). + if (ctx.contextType == RuntimeContextType.VOID + && left instanceof ListNode targets && targets.elements.isEmpty()) { + // A list-context global match must keep running through all + // matches (including callbacks) even when its result list is + // discarded by the empty target. + int rhsContext = RegexUsageDetector.containsRegexOperation(right) + ? RuntimeContextType.LIST : RuntimeContextType.VOID; + right.accept(emitterVisitor.with(rhsContext)); + if (rhsContext == RuntimeContextType.LIST) { + mv.visitInsn(Opcodes.POP); + } + return; + } + boolean isLocalAssignment = left instanceof OperatorNode operatorNode && operatorNode.operator.equals("local"); boolean localCaptureAssignment = isLocalAssignment && left instanceof OperatorNode local diff --git a/src/main/java/org/perlonjava/runtime/operators/Operator.java b/src/main/java/org/perlonjava/runtime/operators/Operator.java index b254c506b8..23b5db3b83 100644 --- a/src/main/java/org/perlonjava/runtime/operators/Operator.java +++ b/src/main/java/org/perlonjava/runtime/operators/Operator.java @@ -867,6 +867,10 @@ private static RuntimeList reversePlainArray(RuntimeArray array) { } public static RuntimeBase repeat(RuntimeBase value, RuntimeScalar timesScalar, int ctx) { + if (ctx == RuntimeContextType.VOID && value instanceof RuntimeScalar scalarValue + && scalarValue.type == RuntimeScalarType.TIED_SCALAR) { + return new RuntimeScalar(); + } if (value instanceof RuntimeScalar scalarValue) { value = RuntimeScalar.fetchTiedOnce(scalarValue); } diff --git a/src/test/resources/unit/empty_list_assignment_void_context.t b/src/test/resources/unit/empty_list_assignment_void_context.t new file mode 100644 index 0000000000..e2d85c288d --- /dev/null +++ b/src/test/resources/unit/empty_list_assignment_void_context.t @@ -0,0 +1,15 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More tests => 1; + +package Local::EmptyListAssignment; +sub TIESCALAR { bless {}, shift } +sub FETCH { $_[0]{fetched}++ } +sub empty { } + +package main; +tie my $tied, 'Local::EmptyListAssignment'; +() = (Local::EmptyListAssignment::empty(), ($tied) x 10); +is(tied($tied)->{fetched}, undef, + 'void assignment to an empty list does not fetch discarded tied values'); From 0909e9640ee8490056a576e6fd825d4b2d04a50c Mon Sep 17 00:00:00 2001 From: "Flavio S. Glock" Date: Fri, 2 Oct 2026 15:29:34 +0200 Subject: [PATCH 14/41] fix: omit absent optional underscore prototype arguments Only fill an omitted underscore prototype slot from $_ when the slot is required or no earlier argument was supplied. Optional trailing underscore slots after required arguments remain absent from @_ when omitted. Generated with [Codex](https://openai.com/codex) Co-Authored-By: Codex <158243242+codex@users.noreply.github.com> --- docs/about/changelog.md | 1 + .../frontend/parser/PrototypeArgs.java | 11 ++++++++--- ...prototype_optional_underscore_required_arg.t | 17 +++++++++++++++++ 3 files changed, 26 insertions(+), 3 deletions(-) create mode 100644 src/test/resources/unit/prototype_optional_underscore_required_arg.t diff --git a/docs/about/changelog.md b/docs/about/changelog.md index 5cc76bbbd5..2eeb73a2cf 100644 --- a/docs/about/changelog.md +++ b/docs/about/changelog.md @@ -21,6 +21,7 @@ priorities and future plans. - Warn about bareword exponent suffixes following numeric literals. - Preserve the empty string yielded by a range with two undefined endpoints. - Avoid materializing values from empty list assignments in void context. +- Preserve omitted optional underscore prototype arguments after required arguments. - Preserve objects with counted collection owners during weak-reference sweeps, and resolve deferred user-defined regex properties in the match caller's diff --git a/src/main/java/org/perlonjava/frontend/parser/PrototypeArgs.java b/src/main/java/org/perlonjava/frontend/parser/PrototypeArgs.java index a7f86e8c29..2b0e4f527e 100644 --- a/src/main/java/org/perlonjava/frontend/parser/PrototypeArgs.java +++ b/src/main/java/org/perlonjava/frontend/parser/PrototypeArgs.java @@ -815,9 +815,14 @@ private static boolean isFilehandleOperator(String operatorName) { private static void handleUnderscoreArgument(Parser parser, ListNode args, boolean isOptional, boolean needComma) { Node arg = parseArgumentWithComma(parser, true, needComma, "scalar argument"); if (arg == null) { - Node underscoreArg = scalarUnderscore(parser); - underscoreArg.setAnnotation("context", "SCALAR"); - args.elements.add(underscoreArg); + // `_` aliases $_ when it is the only available argument. In a + // prototype such as `$;_`, an omitted trailing `_` after the + // required scalar leaves @_ unchanged instead of adding $_. + if (args.elements.isEmpty() || !isOptional) { + Node underscoreArg = scalarUnderscore(parser); + underscoreArg.setAnnotation("context", "SCALAR"); + args.elements.add(underscoreArg); + } return; } Node scalarArg = ParserNodeUtils.toScalarContext(arg); diff --git a/src/test/resources/unit/prototype_optional_underscore_required_arg.t b/src/test/resources/unit/prototype_optional_underscore_required_arg.t new file mode 100644 index 0000000000..c81a3d2e98 --- /dev/null +++ b/src/test/resources/unit/prototype_optional_underscore_required_arg.t @@ -0,0 +1,17 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More tests => 2; + +sub optional_underscore ($;_) { return @_ } + +{ + local $_ = 'default'; + my @args = optional_underscore('required'); + is_deeply(\@args, ['required'], + 'omitted optional underscore does not add $_ after a required argument'); +} + +my @explicit = optional_underscore('required', 'explicit'); +is_deeply(\@explicit, ['required', 'explicit'], + 'optional underscore accepts an explicit second argument'); From 2b58d1ddb14047b7274174dbffd49c9fd22326b6 Mon Sep 17 00:00:00 2001 From: "Flavio S. Glock" Date: Fri, 2 Oct 2026 15:47:56 +0200 Subject: [PATCH 15/41] fix: recognize comma-delimited quote operators in hashrefs Treat q and qq as quote operators when comma is their delimiter during brace disambiguation, while preserving trailing-comma block parsing. Generated with [Codex](https://openai.com/codex) Co-Authored-By: Codex <158243242+codex@users.noreply.github.com> --- docs/about/changelog.md | 1 + .../frontend/parser/StatementResolver.java | 10 +++++++--- .../resources/unit/nested_q_delimiter_eval_hash.t | 14 ++++++++++++++ 3 files changed, 22 insertions(+), 3 deletions(-) create mode 100644 src/test/resources/unit/nested_q_delimiter_eval_hash.t diff --git a/docs/about/changelog.md b/docs/about/changelog.md index 2eeb73a2cf..cfe8aa175d 100644 --- a/docs/about/changelog.md +++ b/docs/about/changelog.md @@ -22,6 +22,7 @@ priorities and future plans. - Preserve the empty string yielded by a range with two undefined endpoints. - Avoid materializing values from empty list assignments in void context. - Preserve omitted optional underscore prototype arguments after required arguments. +- Parse comma-delimited `q` and `qq` strings when disambiguating hashrefs from blocks. - Preserve objects with counted collection owners during weak-reference sweeps, and resolve deferred user-defined regex properties in the match caller's diff --git a/src/main/java/org/perlonjava/frontend/parser/StatementResolver.java b/src/main/java/org/perlonjava/frontend/parser/StatementResolver.java index 2c36efc73c..0df27074dc 100644 --- a/src/main/java/org/perlonjava/frontend/parser/StatementResolver.java +++ b/src/main/java/org/perlonjava/frontend/parser/StatementResolver.java @@ -1447,8 +1447,9 @@ public static boolean isHashLiteral(Parser parser) { if (token.type == LexerTokenType.IDENTIFIER && (token.text.equals("q") || token.text.equals("qq"))) { // Only treat as quote-like operators when a real delimiter follows. - // Bareword `q` / `qq` before `,` / `=>` / `;` / closing paren is not q(): - // { q,'bar', } { q => 'bar' } first line is a block; second is a hash key. + // Comma is a valid q delimiter: `{q,a'b,,'foo'}` is a hashref + // whose first key is the string `a'b`. A single quoted q-string + // followed by a trailing comma still remains a block below. int peekIdx = parser.tokenIndex; while (peekIdx < parser.tokens.size() && parser.tokens.get(peekIdx).type == LexerTokenType.WHITESPACE) { @@ -1456,10 +1457,13 @@ public static boolean isHashLiteral(Parser parser) { } if (peekIdx < parser.tokens.size()) { String nextText = parser.tokens.get(peekIdx).text; - if (nextText.equals(",") || nextText.equals("=>") || nextText.equals(";") + if (nextText.equals("=>") || nextText.equals(";") || nextText.equals(")") || nextText.equals("}")) { // Fall through: process `q` / `qq` like any other identifier. } else { + if (token == firstToken) { + firstTokenIsKeyLike = true; + } awaitingQuoteLikeDelimiter = true; continue; } diff --git a/src/test/resources/unit/nested_q_delimiter_eval_hash.t b/src/test/resources/unit/nested_q_delimiter_eval_hash.t new file mode 100644 index 0000000000..b27bf9d1ba --- /dev/null +++ b/src/test/resources/unit/nested_q_delimiter_eval_hash.t @@ -0,0 +1,14 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More tests => 5; + +my $hash = eval q{{q,a'b,,'value'}}; +is($@, '', 'quote with a comma delimiter parses inside a hash constructor'); +is(ref($hash), 'HASH', 'evaluated constructor returns a hash reference'); +is(ref($hash) eq 'HASH' ? $hash->{"a'b"} : undef, 'value', + 'quote with a comma delimiter preserves its key text'); + +my $block = eval q{{q,'bar',}}; +is(ref($block), '', 'bareword q followed by a trailing comma remains a block'); +is($block, "'bar'", 'the block control still returns its final expression'); From ce231627226a5cbfb62c8cbff599a61a5fc7e528 Mon Sep 17 00:00:00 2001 From: "Flavio S. Glock" Date: Fri, 2 Oct 2026 16:22:16 +0200 Subject: [PATCH 16/41] fix: clear pos after a failed global match-once retry Treat the short-circuited second m?pattern?g attempt as a failed global match and clear pos unless /c asks to preserve it. Generated with [Codex](https://openai.com/codex) Co-Authored-By: Codex <158243242+codex@users.noreply.github.com> --- docs/about/changelog.md | 1 + .../runtime/regex/RuntimeRegex.java | 5 +++++ .../unit/match_once_global_pos_reset.t | 22 +++++++++++++++++++ 3 files changed, 28 insertions(+) create mode 100644 src/test/resources/unit/match_once_global_pos_reset.t diff --git a/docs/about/changelog.md b/docs/about/changelog.md index cfe8aa175d..612a7c7a24 100644 --- a/docs/about/changelog.md +++ b/docs/about/changelog.md @@ -23,6 +23,7 @@ priorities and future plans. - Avoid materializing values from empty list assignments in void context. - Preserve omitted optional underscore prototype arguments after required arguments. - Parse comma-delimited `q` and `qq` strings when disambiguating hashrefs from blocks. +- Clear `pos()` after a failed second match of a global match-once pattern. - Preserve objects with counted collection owners during weak-reference sweeps, and resolve deferred user-defined regex properties in the match caller's diff --git a/src/main/java/org/perlonjava/runtime/regex/RuntimeRegex.java b/src/main/java/org/perlonjava/runtime/regex/RuntimeRegex.java index fdecb6d34d..10e69dfb9b 100644 --- a/src/main/java/org/perlonjava/runtime/regex/RuntimeRegex.java +++ b/src/main/java/org/perlonjava/runtime/regex/RuntimeRegex.java @@ -3772,6 +3772,11 @@ private static RuntimeBase matchRegexDirect(RuntimeScalar quotedRegex, RuntimeSc if (originalFlags.isMatchExactlyOnce() && matchOnceState.matched) { // m?PAT? already matched once; now return false + // This is still a failed /g match for pos() semantics: clear the + // published position unless /c requested that it be retained. + if (originalFlags.isGlobalMatch() && !originalFlags.keepCurrentPosition()) { + RuntimePosLvalue.publishMatchPosition(string, scalarUndef); + } if (ctx == RuntimeContextType.LIST) { return new RuntimeList(); } else if (ctx == RuntimeContextType.SCALAR) { diff --git a/src/test/resources/unit/match_once_global_pos_reset.t b/src/test/resources/unit/match_once_global_pos_reset.t new file mode 100644 index 0000000000..1a8be5d428 --- /dev/null +++ b/src/test/resources/unit/match_once_global_pos_reset.t @@ -0,0 +1,22 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More tests => 4; + +my $text = 'bird'; +for (1 .. 2) { + if ($text =~ m?bird?g) { + is(pos($text), 4, 'first match-once global match publishes pos'); + } else { + is(pos($text), undef, 'failed match-once global retry clears pos'); + } +} + +$_ = '1'; +for (1 .. 2) { + if (m?\d?g) { + is(pos, 1, 'first default-variable match-once match publishes pos'); + } else { + is(pos, undef, 'failed default-variable match-once retry clears pos'); + } +} From 7cadb21c851eeb6082911ed44064cd80c8b2dda4 Mon Sep 17 00:00:00 2001 From: "Flavio S. Glock" Date: Fri, 2 Oct 2026 16:37:59 +0200 Subject: [PATCH 17/41] fix: recognize explicitly referenced typed %FIELDS tables Record references to package %FIELDS hashes during parsing so typed hash and hash-slice dereferences validate keys before runtime vivification. Generated with [Codex](https://openai.com/codex) Co-Authored-By: Codex <158243242+codex@users.noreply.github.com> --- docs/about/changelog.md | 1 + .../org/perlonjava/frontend/parser/ParseInfix.java | 3 ++- .../org/perlonjava/frontend/parser/Variable.java | 10 ++++++++++ .../resources/unit/typed_hash_field_validation.t | 13 +++++++++++++ 4 files changed, 26 insertions(+), 1 deletion(-) create mode 100644 src/test/resources/unit/typed_hash_field_validation.t diff --git a/docs/about/changelog.md b/docs/about/changelog.md index 612a7c7a24..122df0dbe5 100644 --- a/docs/about/changelog.md +++ b/docs/about/changelog.md @@ -24,6 +24,7 @@ priorities and future plans. - Preserve omitted optional underscore prototype arguments after required arguments. - Parse comma-delimited `q` and `qq` strings when disambiguating hashrefs from blocks. - Clear `pos()` after a failed second match of a global match-once pattern. +- Validate typed hash dereferences against explicitly referenced `%FIELDS` tables. - Preserve objects with counted collection owners during weak-reference sweeps, and resolve deferred user-defined regex properties in the match caller's diff --git a/src/main/java/org/perlonjava/frontend/parser/ParseInfix.java b/src/main/java/org/perlonjava/frontend/parser/ParseInfix.java index b1e4384c8d..77743dd1b8 100644 --- a/src/main/java/org/perlonjava/frontend/parser/ParseInfix.java +++ b/src/main/java/org/perlonjava/frontend/parser/ParseInfix.java @@ -67,7 +67,8 @@ private static void validateTypedFields( // legacy fields hash. Avoid auto-vivifying an empty %FIELDS merely // while parsing a hash dereference, which would falsely reject every // key as an unknown class field. - if (!GlobalVariable.existsGlobalHash(fieldsName)) return; + if (!GlobalVariable.existsGlobalHash(fieldsName) + && !GlobalVariable.isDeclaredGlobalHash(fieldsName)) return; RuntimeHash fields = GlobalVariable.getGlobalHash(fieldsName); for (Node key : keys.elements) { String name = key instanceof StringNode string ? string.value diff --git a/src/main/java/org/perlonjava/frontend/parser/Variable.java b/src/main/java/org/perlonjava/frontend/parser/Variable.java index 97828ee242..29d46136a7 100644 --- a/src/main/java/org/perlonjava/frontend/parser/Variable.java +++ b/src/main/java/org/perlonjava/frontend/parser/Variable.java @@ -195,6 +195,16 @@ public static Node parseVariable(Parser parser, String sigil) { } IdentifierParser.validateIdentifier(parser, varName, startIndex); + // An explicit reference to a package's legacy %FIELDS hash is + // enough to make it the field table for typed lexical checks. + // Parsing happens before the statement can vivify the hash at + // runtime, so retain that declaration for following dereferences. + if (sigil.equals("%") && varName.equals("FIELDS")) { + String fullName = NameNormalizer.normalizeVariableName( + varName, parser.ctx.symbolTable.getCurrentPackage()); + GlobalVariable.declareGlobalHash(fullName); + } + // Variable name is valid. // Check for illegal characters after a variable if (!parser.parsingForLoopVariable && !parser.parsingIndirectObject diff --git a/src/test/resources/unit/typed_hash_field_validation.t b/src/test/resources/unit/typed_hash_field_validation.t new file mode 100644 index 0000000000..497f323307 --- /dev/null +++ b/src/test/resources/unit/typed_hash_field_validation.t @@ -0,0 +1,13 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More tests => 2; +no strict; + +eval q{package TypedBlockField; %FIELDS; my TypedBlockField $r; ${$r}{key};}; +like($@, qr/No such class field "key" in variable \$r of type TypedBlockField/, + 'block hash dereference rejects an unknown field after referencing %FIELDS'); + +eval q{package TypedSliceField; %FIELDS; my TypedSliceField $f; @$f{"a"};}; +like($@, qr/No such class field "a" in variable \$f of type TypedSliceField/, + 'one-key hash slice rejects an unknown field after referencing %FIELDS'); From cfaeccdf715476dcedd61eaeb9499b827c757379 Mon Sep 17 00:00:00 2001 From: "Flavio S. Glock" Date: Fri, 2 Oct 2026 19:32:35 +0200 Subject: [PATCH 18/41] fix: clear anonymous CVs through dynamic undef Handle `undef &{EXPR}` as an in-place code-reference undef and report void-context anonymous subroutine warnings using lexical warning settings. Generated with [Codex](https://openai.com/codex) Co-Authored-By: Codex <158243242+codex@users.noreply.github.com> --- docs/about/changelog.md | 1 + .../backend/bytecode/BytecodeCompiler.java | 4 +- .../backend/bytecode/CompileOperator.java | 17 +++++ .../backend/bytecode/InterpretedCode.java | 6 ++ .../perlonjava/backend/jvm/EmitOperator.java | 28 ++++++-- .../frontend/parser/OperatorParser.java | 30 ++++++++- .../frontend/parser/StatementResolver.java | 22 +++++++ .../runtime/runtimetypes/RuntimeCode.java | 65 ++++++++++++++++--- .../unit/anonymous_sub_void_warning.t | 16 +++++ src/test/resources/unit/undef_lvalue.t | 7 ++ 10 files changed, 180 insertions(+), 16 deletions(-) create mode 100644 src/test/resources/unit/anonymous_sub_void_warning.t diff --git a/docs/about/changelog.md b/docs/about/changelog.md index 122df0dbe5..edc21ce85e 100644 --- a/docs/about/changelog.md +++ b/docs/about/changelog.md @@ -25,6 +25,7 @@ priorities and future plans. - Parse comma-delimited `q` and `qq` strings when disambiguating hashrefs from blocks. - Clear `pos()` after a failed second match of a global match-once pattern. - Validate typed hash dereferences against explicitly referenced `%FIELDS` tables. +- Warn about anonymous subroutines in void context and undef dynamic code references in place. - Preserve objects with counted collection owners during weak-reference sweeps, and resolve deferred user-defined regex properties in the match caller's diff --git a/src/main/java/org/perlonjava/backend/bytecode/BytecodeCompiler.java b/src/main/java/org/perlonjava/backend/bytecode/BytecodeCompiler.java index ec9520e1d3..babb1f1c22 100644 --- a/src/main/java/org/perlonjava/backend/bytecode/BytecodeCompiler.java +++ b/src/main/java/org/perlonjava/backend/bytecode/BytecodeCompiler.java @@ -6327,7 +6327,9 @@ void compileVariableReference(OperatorNode node, String op) { emitReg(rd); emit(constIdx); lastResultReg = rd; - } else if (node.operand instanceof BlockNode || node.operand instanceof OperatorNode) { + } else if (node.operand instanceof BlockNode + || node.operand instanceof OperatorNode + || node.operand instanceof BinaryOperatorNode) { // Dynamic code reference: &{$name} or &$name // Compile the expression to get the name/value, then dereference as code compileNode(node.operand, -1, RuntimeContextType.SCALAR); diff --git a/src/main/java/org/perlonjava/backend/bytecode/CompileOperator.java b/src/main/java/org/perlonjava/backend/bytecode/CompileOperator.java index 5c4146b303..e9fd392a06 100644 --- a/src/main/java/org/perlonjava/backend/bytecode/CompileOperator.java +++ b/src/main/java/org/perlonjava/backend/bytecode/CompileOperator.java @@ -1685,6 +1685,23 @@ public static void visitOperator(BytecodeCompiler bytecodeCompiler, OperatorNode idNode.name, bytecodeCompiler.getCurrentPackage()); bytecodeCompiler.emit(Opcodes.UNDEFINE_GLOBAL_CODE); bytecodeCompiler.emit(bytecodeCompiler.addToStringPool(subName)); + } else if (undefTarget instanceof OperatorNode ampNode + && ampNode.operator.equals("&") + && !(ampNode.operand instanceof IdentifierNode) + && !(ampNode.operand instanceof OperatorNode dollarNode + && dollarNode.operator.equals("$"))) { + // `undef &{EXPR}` first resolves the computed value as + // a CODE reference, then clears that CV in place. + Node codeRefExpression = ampNode.operand; + boolean expressionReturnsCodeRef = codeRefExpression instanceof BinaryOperatorNode assignment + && assignment.operator.equals("=") + && assignment.right instanceof SubroutineNode; + bytecodeCompiler.compileNode( + expressionReturnsCodeRef ? codeRefExpression : ampNode, + -1, RuntimeContextType.SCALAR); + int codeRefReg = bytecodeCompiler.lastResultReg; + bytecodeCompiler.emit(Opcodes.UNDEFINE_CODE_REF); + bytecodeCompiler.emitReg(codeRefReg); } else if (isScalarUndefTarget(undefTarget)) { compileScalarUndefTarget(bytecodeCompiler, undefTarget); int operandReg = bytecodeCompiler.lastResultReg; diff --git a/src/main/java/org/perlonjava/backend/bytecode/InterpretedCode.java b/src/main/java/org/perlonjava/backend/bytecode/InterpretedCode.java index cba788d5f0..0b0954074c 100644 --- a/src/main/java/org/perlonjava/backend/bytecode/InterpretedCode.java +++ b/src/main/java/org/perlonjava/backend/bytecode/InterpretedCode.java @@ -388,6 +388,9 @@ public InterpreterState.InterpreterFrame getOrCreateFrame(String packageName, St */ @Override public RuntimeList apply(RuntimeArray args, int callContext) { + if (codeReferenceUndefined) { + throw RuntimeCode.undefinedCodeReferenceException(this, null); + } // Return cached constant value if this sub has been const-folded if (constantValue != null) { RuntimeCode.requireLvalueCallable(this, callContext, null); @@ -477,6 +480,9 @@ public RuntimeList apply(RuntimeArray args, int callContext) { @Override public RuntimeList apply(String subroutineName, RuntimeArray args, int callContext) { + if (codeReferenceUndefined) { + throw RuntimeCode.undefinedCodeReferenceException(this, subroutineName); + } // Return cached constant value if this sub has been const-folded if (constantValue != null) { RuntimeCode.requireLvalueCallable(this, callContext, subroutineName); diff --git a/src/main/java/org/perlonjava/backend/jvm/EmitOperator.java b/src/main/java/org/perlonjava/backend/jvm/EmitOperator.java index f1057c05ed..9cea76e013 100644 --- a/src/main/java/org/perlonjava/backend/jvm/EmitOperator.java +++ b/src/main/java/org/perlonjava/backend/jvm/EmitOperator.java @@ -1415,14 +1415,34 @@ static void handleUndefOperator(EmitterVisitor emitterVisitor, OperatorNode node return; } - // Special handling for `undef &$coderef`. The normal path would call - // the subroutine and undefine its return value, but Perl undefines the - // CV in place so saved coderefs observe a later redefinition. + // Special handling for `undef &$coderef` and `undef &{EXPR}`. The + // normal path would call the subroutine and undefine its return value, + // but Perl undefines the CV in place so saved coderefs observe a later + // redefinition. if (node.operand instanceof ListNode listNode && listNode.elements.size() == 1) { Node element = listNode.elements.getFirst(); if (element instanceof OperatorNode ampNode && ampNode.operator.equals("&")) { + Node codeRefExpression = null; + boolean dereferenceDynamicCodeRef = false; if (ampNode.operand instanceof OperatorNode dollarNode && dollarNode.operator.equals("$")) { - dollarNode.accept(emitterVisitor.with(RuntimeContextType.SCALAR)); + codeRefExpression = dollarNode; + } else if (!(ampNode.operand instanceof IdentifierNode)) { + codeRefExpression = ampNode.operand; + dereferenceDynamicCodeRef = true; + } + if (codeRefExpression != null) { + codeRefExpression.accept(emitterVisitor.with(RuntimeContextType.SCALAR)); + boolean assignmentReturnsCodeRef = codeRefExpression instanceof BinaryOperatorNode assignment + && assignment.operator.equals("=") + && assignment.right instanceof SubroutineNode; + if (dereferenceDynamicCodeRef && !assignmentReturnsCodeRef) { + emitterVisitor.pushCurrentPackage(); + emitterVisitor.ctx.mv.visitMethodInsn(Opcodes.INVOKEVIRTUAL, + "org/perlonjava/runtime/runtimetypes/RuntimeScalar", + "codeDerefNonStrict", + "(Ljava/lang/String;)Lorg/perlonjava/runtime/runtimetypes/RuntimeScalar;", + false); + } emitterVisitor.ctx.mv.visitMethodInsn(Opcodes.INVOKESTATIC, "org/perlonjava/runtime/runtimetypes/RuntimeCode", "undefineCodeReference", diff --git a/src/main/java/org/perlonjava/frontend/parser/OperatorParser.java b/src/main/java/org/perlonjava/frontend/parser/OperatorParser.java index 7580f78035..b2511f7d42 100644 --- a/src/main/java/org/perlonjava/frontend/parser/OperatorParser.java +++ b/src/main/java/org/perlonjava/frontend/parser/OperatorParser.java @@ -1484,7 +1484,35 @@ static OperatorNode parseUndef(Parser parser, LexerToken token, int currentIndex // Similar to 'defined', we need to prevent &subr from being auto-called boolean parsingTakeReference = parser.parsingTakeReference; parser.parsingTakeReference = true; // don't call `&subr` while parsing "Take reference" - operand = ListParser.parseZeroOrOneList(parser, 0, "undef"); + int operandStart = parser.tokenIndex; + LexerToken firstOperandToken = TokenUtils.peek(parser); + if (firstOperandToken.text.equals("&")) { + TokenUtils.consume(parser, OPERATOR, "&"); + if (TokenUtils.peek(parser).text.equals("{")) { + int codeRefIndex = parser.tokenIndex; + TokenUtils.consume(parser, OPERATOR, "{"); + Node codeRefExpression = parser.parseExpression(0); + if (!TokenUtils.peek(parser).text.equals("}")) { + parser.throwError("Missing closing brace in code reference"); + } + TokenUtils.consume(parser, OPERATOR, "}"); + // The opening brace is a delimiter for the dynamic code-ref + // expression, not a Perl block to execute. parseExpression + // represents the delimited form as a one-statement block, so + // unwrap that parser wrapper and preserve the actual value. + if (codeRefExpression instanceof BlockNode expressionBlock + && expressionBlock.elements.size() == 1) { + codeRefExpression = expressionBlock.elements.getFirst(); + } + Node codeRef = new OperatorNode("&", codeRefExpression, codeRefIndex); + operand = new ListNode(List.of(codeRef), codeRefIndex); + } else { + parser.tokenIndex = operandStart; + operand = ListParser.parseZeroOrOneList(parser, 0, "undef"); + } + } else { + operand = ListParser.parseZeroOrOneList(parser, 0, "undef"); + } parser.parsingTakeReference = parsingTakeReference; if (operand.elements.isEmpty()) { // `undef` without arguments returns undef diff --git a/src/main/java/org/perlonjava/frontend/parser/StatementResolver.java b/src/main/java/org/perlonjava/frontend/parser/StatementResolver.java index 0df27074dc..03f1050a03 100644 --- a/src/main/java/org/perlonjava/frontend/parser/StatementResolver.java +++ b/src/main/java/org/perlonjava/frontend/parser/StatementResolver.java @@ -1064,6 +1064,28 @@ yield dieWarnNode(parser, "die", new ListNode(List.of( int expressionStartIndex = parser.tokenIndex; Node expression = parser.parseExpression(0); token = peek(parser); + int followingTokenIndex = parser.tokenIndex; + while (followingTokenIndex < parser.tokens.size() + && (parser.tokens.get(followingTokenIndex).type == LexerTokenType.WHITESPACE + || parser.tokens.get(followingTokenIndex).type == LexerTokenType.NEWLINE + || parser.tokens.get(followingTokenIndex).text.equals(";"))) { + followingTokenIndex++; + } + boolean expressionIsDiscarded = followingTokenIndex < parser.tokens.size() + && parser.tokens.get(followingTokenIndex).type != LexerTokenType.EOF + && !parser.tokens.get(followingTokenIndex).text.equals("}"); + + if (expression instanceof SubroutineNode anonymousSubroutine + && anonymousSubroutine.name == null + && expressionIsDiscarded) { + String location = parser.ctx.errorUtil == null + ? "" : parser.ctx.errorUtil.warningLocation(expressionStartIndex); + WarnDie.warnWithCategoryFromCode( + new RuntimeScalar("Useless use of anonymous subroutine in void context"), + new RuntimeScalar(location), + "void", + parser.ctx.symbolTable.getWarningBitsString()); + } if (token.type == LexerTokenType.IDENTIFIER) { // Handle statement modifiers using switch expression diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeCode.java b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeCode.java index 7892aba3b1..13c87cb023 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeCode.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeCode.java @@ -1754,6 +1754,8 @@ public static void registerDisabledWarnings(String className, Set catego // as opposed to auto-created by getGlobalCodeRef() for lookups. // In Perl 5, declared subs (even forward declarations) are visible via *{glob}{CODE}. public boolean isDeclared = false; + /** True when undef cleared this CV's body without replacing its identity. */ + public boolean codeReferenceUndefined = false; /** True once this named CV has received an actual body, not just a declaration. */ public boolean hasBodyDefinition = false; // Flag to indicate this is a closure prototype (the template CV before cloning). @@ -2503,8 +2505,7 @@ private static RuntimeScalar resolveEvalFilledLexicalForward(RuntimeScalar runti private static RuntimeList undefCodeRefResultOrThrow(RuntimeScalar runtimeScalar, String subroutineName, int callContext) { String fullSubName = knownUndefinedSubroutineName(runtimeScalar, subroutineName); if (fullSubName != null) { - throw new PerlCompilerException(gotoErrorPrefix(subroutineName) - + "ndefined subroutine &" + fullSubName + " called"); + throw new PerlCompilerException(undefinedSubroutineMessage(subroutineName, fullSubName)); } if (RuntimeContextType.isListLike(callContext)) { return new RuntimeList(); @@ -3017,6 +3018,7 @@ public static void clearCaches() { } public static void copy(RuntimeCode code, RuntimeCode codeFrom) { + code.codeReferenceUndefined = codeFrom.codeReferenceUndefined; code.prototype = codeFrom.prototype; code.attributes = codeFrom.attributes; code.methodHandle = codeFrom.methodHandle; @@ -3061,6 +3063,7 @@ public void adoptDefinitionFrom(RuntimeCode codeFrom) { this.isSymbolicReference = codeFrom.isSymbolicReference; this.isBuiltin = codeFrom.isBuiltin; this.isDeclared = codeFrom.isDeclared; + this.codeReferenceUndefined = codeFrom.codeReferenceUndefined; this.isClosurePrototype = codeFrom.isClosurePrototype; this.definitionPending = codeFrom.definitionPending; this.attributesDispatchedAtCompileTime = codeFrom.attributesDispatchedAtCompileTime; @@ -6272,10 +6275,25 @@ private static String gotoErrorPrefix(String subroutineName) { } private static String undefinedSubroutineMessage(String subroutineName, String fullSubName) { + if ((fullSubName == null || fullSubName.isEmpty()) + && !"tailcall".equals(subroutineName)) { + return "Undefined subroutine called"; + } String message = gotoErrorPrefix(subroutineName) + "ndefined subroutine &" + fullSubName; return "tailcall".equals(subroutineName) ? message : message + " called"; } + /** Build Perl's undefined-subroutine diagnostic for a cleared CV. */ + public static PerlCompilerException undefinedCodeReferenceException( + RuntimeCode code, String subroutineName) { + String fullSubName = code.referenceOriginFqn; + if ((fullSubName == null || fullSubName.isEmpty()) + && code.packageName != null && code.subName != null) { + fullSubName = code.packageName + "::" + code.subName; + } + return new PerlCompilerException(undefinedSubroutineMessage(subroutineName, fullSubName)); + } + /** * Extracts Java class names from a Throwable's stack trace, parallel to * how ExceptionFormatter.formatException produces Perl frames. @@ -6528,6 +6546,9 @@ public static RuntimeList apply(RuntimeScalar runtimeScalar, RuntimeArray a, int String displayName = code.lexicalForwardGlobPlaceholder && code.subName != null ? code.subName : code.referenceOriginFqn != null ? code.referenceOriginFqn : autoloadTargetName; + if (displayName == null || displayName.isEmpty()) { + throw new PerlCompilerException("Undefined subroutine called"); + } throw new PerlCompilerException("Undefined subroutine &" + displayName + " called"); } String resolvedSubroutineName = code.packageName != null && code.subName != null @@ -7321,6 +7342,8 @@ public static RuntimeList apply(RuntimeScalar runtimeScalar, String subroutineNa + fullSubName + "() is no longer allowed"); } throw new PerlCompilerException(undefinedSubroutineMessage(subroutineName, fullSubName)); + } else { + throw new PerlCompilerException(undefinedSubroutineMessage(subroutineName, fullSubName)); } } @@ -7671,9 +7694,9 @@ private static RuntimeList applyImpl(RuntimeScalar runtimeScalar, String subrout "Use of inherited AUTOLOAD for non-method " + fullSubName + "() is no longer allowed"); } - throw new PerlCompilerException(gotoErrorPrefix(subroutineName) + "ndefined subroutine &" + fullSubName + " called"); + throw new PerlCompilerException(undefinedSubroutineMessage(subroutineName, fullSubName)); } - throw new PerlCompilerException(gotoErrorPrefix(subroutineName) + "ndefined subroutine &" + fullSubName + " called"); + throw new PerlCompilerException(undefinedSubroutineMessage(subroutineName, fullSubName)); } // Handle GLOB type - extract CODE slot from the glob @@ -8143,12 +8166,27 @@ public static RuntimeScalar undefineCodeReference(RuntimeScalar codeRef) { if (code.isConstantCv && code.lexicalSubDisplayName) { return codeRef.undefine(); } - if (code.referenceOriginFqn == null && codeRef.globalCodeRefFqn != null) { - code.referenceOriginFqn = codeRef.globalCodeRefFqn; + if (!code.hadStashRef + && ("__ANON__".equals(code.subName) + || (code.referenceOriginFqn != null + && code.referenceOriginFqn.endsWith("::__ANON__")))) { + // Anonymous CVs are sometimes tagged with the conventional + // __ANON__ spelling even though they are not the stash's CV. Do + // not let an unrelated named __ANON__ sub capture later calls. + code.referenceOriginFqn = null; + code.packageName = null; + code.subName = null; } if (code.referenceOriginFqn == null) { code.referenceOriginFqn = GlobalVariable.findGlobalCodeRefName(code); - if (code.referenceOriginFqn == null) { + // A scalar can carry a stale global name that belongs to a + // different CV (notably main::__ANON__). Retain that name only + // for CVs which were actually installed in a stash. + if (code.referenceOriginFqn == null && code.hadStashRef + && codeRef.globalCodeRefFqn != null) { + code.referenceOriginFqn = codeRef.globalCodeRefFqn; + } + if (code.referenceOriginFqn == null && code.hadStashRef) { code.referenceOriginFqn = GlobalVariable.findPseudoConstantCodeRefName(code); } } @@ -8158,10 +8196,17 @@ public static RuntimeScalar undefineCodeReference(RuntimeScalar codeRef) { code.packageName = code.referenceOriginFqn.substring(0, separator); code.subName = code.referenceOriginFqn.substring(separator + 2); } + } else if (!code.hadStashRef) { + // An anonymous CV must stay anonymous after undef. Otherwise an + // unrelated named __ANON__ slot can be late-resolved on the next + // call through the saved code reference. + code.packageName = null; + code.subName = null; } // `undef &named_sub` retains a declared CODE slot even after its // callable body is cleared. code.isDeclared = true; + code.codeReferenceUndefined = true; code.clearPadConstantWeakRefs(); code.methodHandle = null; code.subroutine = null; @@ -8315,7 +8360,7 @@ public RuntimeList apply(RuntimeArray a, int callContext) { } throw new PerlCompilerException("Undefined subroutine &" + fullSubName + " called"); } - throw new PerlCompilerException("Undefined subroutine called at "); + throw new PerlCompilerException("Undefined subroutine called"); } requireLvalueCallable(this, callContext, null); @@ -8476,9 +8521,9 @@ public RuntimeList apply(String subroutineName, RuntimeArray a, int callContext) getGlobalVariable(autoloadVarFor(autoload, lookupPkg)).set(fullSubName); return apply(autoload, a, callContext); } - throw new PerlCompilerException(gotoErrorPrefix(subroutineName) + "ndefined subroutine &" + fullSubName + " called"); + throw new PerlCompilerException(undefinedSubroutineMessage(subroutineName, fullSubName)); } - throw new PerlCompilerException(gotoErrorPrefix(subroutineName) + "ndefined subroutine &" + (fullSubName != null ? fullSubName : "") + " called"); + throw new PerlCompilerException(undefinedSubroutineMessage(subroutineName, fullSubName)); } requireLvalueCallable(this, callContext, subroutineName); diff --git a/src/test/resources/unit/anonymous_sub_void_warning.t b/src/test/resources/unit/anonymous_sub_void_warning.t new file mode 100644 index 0000000000..d798368276 --- /dev/null +++ b/src/test/resources/unit/anonymous_sub_void_warning.t @@ -0,0 +1,16 @@ +#!/usr/bin/env perl +use strict; +use warnings; + +use Test::More; + +my @warnings; +{ + local $SIG{__WARN__} = sub { push @warnings, @_ }; + eval q{{ use warnings; sub { 1 }; 1; }}; +} + +like(join('', @warnings), qr/Useless use of anonymous subroutine in void context/, + 'anonymous subroutine in void context warns'); + +done_testing; diff --git a/src/test/resources/unit/undef_lvalue.t b/src/test/resources/unit/undef_lvalue.t index 888a25598f..ad24994459 100644 --- a/src/test/resources/unit/undef_lvalue.t +++ b/src/test/resources/unit/undef_lvalue.t @@ -12,6 +12,13 @@ my $code = sub { 1 }; undef $code; ok !defined($code), 'undef clears coderef scalar lvalue'; +our $x; +sub __ANON__ { print "unexpected call\n" } +undef &{$x = sub { print "unexpected call\n" }}; +my $error = eval { $x->(); 1 }; +like($@, qr/^Undefined subroutine called at /, + 'undef &{...} clears an anonymous CV in place'); + my $array = [ sub { 1 }, sub { 2 } ]; undef $array->[1]; ok !defined($array->[1]), 'undef clears array element lvalue'; From f692268617d8ec31a09a24c8783a2214e3bb7095 Mon Sep 17 00:00:00 2001 From: "Flavio S. Glock" Date: Fri, 2 Oct 2026 19:54:07 +0200 Subject: [PATCH 19/41] fix: anonymize caller names after stash deletion Report a saved stash-backed CV as anonymous after its symbol table entry is deleted, matching Perl's caller() behavior. Generated with [Codex](https://openai.com/codex) Co-Authored-By: Codex <158243242+codex@users.noreply.github.com> --- docs/about/changelog.md | 1 + .../runtime/runtimetypes/RuntimeCode.java | 7 +++++++ src/test/resources/unit/caller_deleted_cv_name.t | 16 ++++++++++++++++ 3 files changed, 24 insertions(+) create mode 100644 src/test/resources/unit/caller_deleted_cv_name.t diff --git a/docs/about/changelog.md b/docs/about/changelog.md index edc21ce85e..5ec7671116 100644 --- a/docs/about/changelog.md +++ b/docs/about/changelog.md @@ -26,6 +26,7 @@ priorities and future plans. - Clear `pos()` after a failed second match of a global match-once pattern. - Validate typed hash dereferences against explicitly referenced `%FIELDS` tables. - Warn about anonymous subroutines in void context and undef dynamic code references in place. +- Report deleted stash-backed subroutines as anonymous in `caller()`. - Preserve objects with counted collection owners during weak-reference sweeps, and resolve deferred user-defined regex properties in the match caller's diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeCode.java b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeCode.java index 13c87cb023..4f95fe9de5 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeCode.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeCode.java @@ -5880,6 +5880,13 @@ private static String callerSubNameForCode(RuntimeCode code) { } return null; } + if (code.hadStashRef && !code.explicitlyRenamed + && GlobalVariable.findGlobalCodeRefName(code) == null) { + // A named CV reached through a saved glob can outlive its stash + // entry. Perl then reports the surviving CV as anonymous because + // its name depended on that glob. + return normalizeCallerPackage(code.packageName) + "::__ANON__"; + } if (code.subName.contains("::")) { return code.subName; } diff --git a/src/test/resources/unit/caller_deleted_cv_name.t b/src/test/resources/unit/caller_deleted_cv_name.t new file mode 100644 index 0000000000..9169303e38 --- /dev/null +++ b/src/test/resources/unit/caller_deleted_cv_name.t @@ -0,0 +1,16 @@ +use strict; +use utf8; +use open qw( :utf8 :std ); +use Test::More tests => 1; + +package main; +my @c; +sub foo { @c = caller(0) } +{ + no strict 'refs'; + no warnings 'utf8'; + () = *{"foo"}; +} +my $fooref = delete $main::{foo}; +$fooref->(); +::is($c[3], "main::__ANON__", 'deleted named CV is reported as anonymous'); From 039f6d7957d6d650860e7a5e859602569365ad67 Mon Sep 17 00:00:00 2001 From: "Flavio S. Glock" Date: Fri, 2 Oct 2026 20:09:31 +0200 Subject: [PATCH 20/41] fix: preserve deleted CV names in interpreter caller frames When interpreter caller() frames retain a deleted stash name, resolve the active CV and report its anonymous name just like the JVM backend. Generated with [Codex](https://openai.com/codex) Co-Authored-By: Codex <158243242+codex@users.noreply.github.com> --- .../runtime/runtimetypes/RuntimeCode.java | 24 ++++++++++++++++++- 1 file changed, 23 insertions(+), 1 deletion(-) diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeCode.java b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeCode.java index 4f95fe9de5..149c1f3390 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeCode.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeCode.java @@ -5477,7 +5477,10 @@ public static RuntimeList callerWithSub(RuntimeList args, int ctx, RuntimeScalar if (subName == null && currentFrameIsInterpreter) { String interpreterSubName = interpreterFrameBeforeVirtualEval ? frameSubName : previousFrameSubName; - if (interpreterSubName != null && !interpreterSubName.startsWith("(eval")) { + RuntimeCode deletedActiveCode = deletedStashCodeForCallerName(interpreterSubName); + if (deletedActiveCode != null) { + subName = callerSubNameForCode(deletedActiveCode); + } else if (interpreterSubName != null && !interpreterSubName.startsWith("(eval")) { subName = interpreterSubName; } } @@ -5897,6 +5900,25 @@ private static String callerSubNameForCode(RuntimeCode code) { return pkg + "::" + code.subName; } + private static RuntimeCode deletedStashCodeForCallerName(String callerName) { + if (callerName == null || callerName.startsWith("(") + || !callerName.contains("::")) { + return null; + } + for (RuntimeCode active : activeCodeStack()) { + String activeName = active.referenceOriginFqn; + if (activeName == null && active.packageName != null && active.subName != null) { + activeName = active.packageName + "::" + active.subName; + } + if (active.hadStashRef && !active.explicitlyRenamed + && callerName.equals(activeName) + && GlobalVariable.findGlobalCodeRefName(active) == null) { + return active; + } + } + return null; + } + /** Attach a lexical declaration's display name without installing a package CV. */ public static RuntimeScalar setLexicalSubDisplayName(RuntimeScalar codeRef, String name) { if (codeRef != null && codeRef.value instanceof RuntimeCode code From 9f4ee04ec193f2fb18c9db7034887251337e4e63 Mon Sep 17 00:00:00 2001 From: "Flavio S. Glock" Date: Fri, 2 Oct 2026 20:22:06 +0200 Subject: [PATCH 21/41] fix: detect oversized repetition counts before narrowing Reject large positive repeat counts before converting them to an int, so 64-bit bitwise results cannot wrap into negative list sizes. Generated with [Codex](https://openai.com/codex) Co-Authored-By: Codex <158243242+codex@users.noreply.github.com> --- docs/about/changelog.md | 1 + .../java/org/perlonjava/runtime/operators/Operator.java | 8 ++++++++ src/test/resources/unit/repeat_large_list_count.t | 7 +++++++ 3 files changed, 16 insertions(+) create mode 100644 src/test/resources/unit/repeat_large_list_count.t diff --git a/docs/about/changelog.md b/docs/about/changelog.md index 5ec7671116..a96c171880 100644 --- a/docs/about/changelog.md +++ b/docs/about/changelog.md @@ -27,6 +27,7 @@ priorities and future plans. - Validate typed hash dereferences against explicitly referenced `%FIELDS` tables. - Warn about anonymous subroutines in void context and undef dynamic code references in place. - Report deleted stash-backed subroutines as anonymous in `caller()`. +- Detect oversized repetition counts before they wrap during conversion. - Preserve objects with counted collection owners during weak-reference sweeps, and resolve deferred user-defined regex properties in the match caller's diff --git a/src/main/java/org/perlonjava/runtime/operators/Operator.java b/src/main/java/org/perlonjava/runtime/operators/Operator.java index 23b5db3b83..1ef07b184f 100644 --- a/src/main/java/org/perlonjava/runtime/operators/Operator.java +++ b/src/main/java/org/perlonjava/runtime/operators/Operator.java @@ -912,6 +912,14 @@ public static RuntimeBase repeat(RuntimeBase value, RuntimeScalar timesScalar, i } } + // Do not narrow Perl's unsigned bitwise results through intValue(). + // For example, `~1` is a very large positive count on a 64-bit Perl; + // list repetition must fail with Perl's allocation error rather than + // wrap to -2 and silently return an empty list. + if (timesScalar.getBigint().compareTo(BigInteger.valueOf(Integer.MAX_VALUE)) > 0) { + throw new PerlCompilerException("Out of memory"); + } + int times = timesScalar.getInt(); if (ctx == SCALAR || value instanceof RuntimeScalar) { // In scalar context, convert value to scalar first diff --git a/src/test/resources/unit/repeat_large_list_count.t b/src/test/resources/unit/repeat_large_list_count.t new file mode 100644 index 0000000000..249e8dadb2 --- /dev/null +++ b/src/test/resources/unit/repeat_large_list_count.t @@ -0,0 +1,7 @@ +use strict; +use warnings; +use Test::More tests => 1; + +my @values; +eval { @values = (1) x ~1; 1 }; +like($@, qr/Out of memory/, 'oversized list repetition count fails before allocation'); From 4cfb37408fc7ea13edd039451d1a6a7a5a7cc434 Mon Sep 17 00:00:00 2001 From: "Flavio S. Glock" Date: Fri, 2 Oct 2026 21:11:42 +0200 Subject: [PATCH 22/41] fix: preserve eval errors through destructor cleanup Run successful eval-block destructors before clearing $@ while retaining control-flow diagnostics, and map failed rmdir calls to errno values. Generated with [Codex](https://openai.com/codex) Co-Authored-By: Codex <158243242+codex@users.noreply.github.com> --- docs/about/changelog.md | 1 + .../backend/jvm/EmitterMethodCreator.java | 49 +++++++++++++++---- .../runtime/operators/Directory.java | 6 +-- .../runtime/runtimetypes/RuntimeCode.java | 19 +++++++ .../unit/eval_unwind_destructor_error.t | 19 +++++++ src/test/resources/unit/rmdir_missing_errno.t | 13 +++++ 6 files changed, 94 insertions(+), 13 deletions(-) create mode 100644 src/test/resources/unit/eval_unwind_destructor_error.t create mode 100644 src/test/resources/unit/rmdir_missing_errno.t diff --git a/docs/about/changelog.md b/docs/about/changelog.md index a96c171880..ce3c5cc1a5 100644 --- a/docs/about/changelog.md +++ b/docs/about/changelog.md @@ -28,6 +28,7 @@ priorities and future plans. - Warn about anonymous subroutines in void context and undef dynamic code references in place. - Report deleted stash-backed subroutines as anonymous in `caller()`. - Detect oversized repetition counts before they wrap during conversion. +- Run eval-block destructors before clearing `$@`, and report `ENOENT` from failed `rmdir` calls. - Preserve objects with counted collection owners during weak-reference sweeps, and resolve deferred user-defined regex properties in the match caller's diff --git a/src/main/java/org/perlonjava/backend/jvm/EmitterMethodCreator.java b/src/main/java/org/perlonjava/backend/jvm/EmitterMethodCreator.java index 921b090f66..4be6420214 100644 --- a/src/main/java/org/perlonjava/backend/jvm/EmitterMethodCreator.java +++ b/src/main/java/org/perlonjava/backend/jvm/EmitterMethodCreator.java @@ -919,6 +919,22 @@ private static byte[] getBytecodeInternal(EmitterContext ctx, Node ast, boolean "(Ljava/lang/String;Ljava/lang/String;)V", false); + // This marker path reports eval failure without throwing + // into catchBlock. Preserve its $@ through the common + // dynamic teardown epilogue as well. + mv.visitTypeInsn(Opcodes.NEW, "org/perlonjava/runtime/runtimetypes/RuntimeScalar"); + mv.visitInsn(Opcodes.DUP); + mv.visitLdcInsn("main::@"); + mv.visitMethodInsn(Opcodes.INVOKESTATIC, + "org/perlonjava/runtime/runtimetypes/GlobalVariable", + "getGlobalVariable", + "(Ljava/lang/String;)Lorg/perlonjava/runtime/runtimetypes/RuntimeScalar;", false); + mv.visitMethodInsn(Opcodes.INVOKESPECIAL, + "org/perlonjava/runtime/runtimetypes/RuntimeScalar", + "", + "(Lorg/perlonjava/runtime/runtimetypes/RuntimeScalar;)V", false); + mv.visitVarInsn(Opcodes.ASTORE, evalErrorSlot); + // Replace marker with undef/empty list mv.visitInsn(Opcodes.POP); Label evalBlockList = new Label(); @@ -974,16 +990,6 @@ private static byte[] getBytecodeInternal(EmitterContext ctx, Node ast, boolean // Track eval depth for $^S: RuntimeCode.evalDepth-- emitEvalDepthDecrement(mv); - // A successful eval must clear errors from nested evals. Operators - // that need eval to expose a failure must throw instead of only - // assigning $@ and returning undef. - mv.visitLdcInsn("main::@"); - mv.visitLdcInsn(""); - mv.visitMethodInsn(Opcodes.INVOKESTATIC, - "org/perlonjava/runtime/runtimetypes/GlobalVariable", - "setGlobalVariable", - "(Ljava/lang/String;Ljava/lang/String;)V", false); - // Jump over the catch block if no exception occurs mv.visitJumpInsn(Opcodes.GOTO, endCatch); @@ -1134,6 +1140,15 @@ private static byte[] getBytecodeInternal(EmitterContext ctx, Node ast, boolean // (RegexState was pushed onto the DVM stack at sub entry). Local.localTeardown(dynamicIndex, mv); + // Deferred lexical cleanup runs after the eval body method + // returns. Drain it here, before clearing $@, when doing so + // cannot invalidate a reference returned by the eval. + mv.visitVarInsn(Opcodes.ALOAD, returnListSlot); + mv.visitMethodInsn(Opcodes.INVOKESTATIC, + "org/perlonjava/runtime/runtimetypes/RuntimeCode", + "flushEvalBlockCleanupForScalarResult", + "(Lorg/perlonjava/runtime/runtimetypes/RuntimeBase;)V", false); + mv.visitLabel(teardownTryEnd); // After DVM teardown, re-set $@ if we caught an eval error. @@ -1224,6 +1239,20 @@ private static byte[] getBytecodeInternal(EmitterContext ctx, Node ast, boolean // Both paths join here with empty stack mv.visitLabel(teardownDone); + // A successful eval clears nested eval errors only after + // dynamic teardown and deferred DESTROY have completed. Failed + // evals have an error in evalErrorSlot and retain it. + Label preserveTeardownError = new Label(); + mv.visitVarInsn(Opcodes.ALOAD, evalErrorSlot); + mv.visitJumpInsn(Opcodes.IFNONNULL, preserveTeardownError); + mv.visitLdcInsn("main::@"); + mv.visitLdcInsn(""); + mv.visitMethodInsn(Opcodes.INVOKESTATIC, + "org/perlonjava/runtime/runtimetypes/GlobalVariable", + "setGlobalVariable", + "(Ljava/lang/String;Ljava/lang/String;)V", false); + mv.visitLabel(preserveTeardownError); + // Load the return value for ARETURN mv.visitVarInsn(Opcodes.ALOAD, returnListSlot); } else { diff --git a/src/main/java/org/perlonjava/runtime/operators/Directory.java b/src/main/java/org/perlonjava/runtime/operators/Directory.java index 28c3f56c6f..71b26a818f 100644 --- a/src/main/java/org/perlonjava/runtime/operators/Directory.java +++ b/src/main/java/org/perlonjava/runtime/operators/Directory.java @@ -168,9 +168,9 @@ public static RuntimeScalar rmdir(RuntimeScalar runtimeScalar) { Files.delete(path); return scalarTrue; } catch (IOException e) { - // Set $! (errno) in case of failure - getGlobalVariable("main::!").set(e.getMessage()); - return scalarFalse; + // Preserve errno identity (for example ENOENT) as well as the + // platform's localized message in $!. + return handleIOException(e, dirName, 2); } } diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeCode.java b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeCode.java index 149c1f3390..d56e160e40 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeCode.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeCode.java @@ -1423,6 +1423,25 @@ private static boolean containsNoReference(RuntimeList result) { && (scalar.type & RuntimeScalarType.REFERENCE_BIT) != 0); } + /** + * Eval-block locals are released by deferred cleanup after the generated + * body returns. Flush that cleanup before its successful $@ reset when the + * materialized result contains no references that the flush could release. + */ + public static void flushEvalBlockCleanupForScalarResult(RuntimeBase result) { + boolean resultHasNoReferences; + if (result instanceof RuntimeList list) { + resultHasNoReferences = containsNoReference(list); + } else if (result instanceof RuntimeScalar scalar) { + resultHasNoReferences = (scalar.type & RuntimeScalarType.REFERENCE_BIT) == 0; + } else { + resultHasNoReferences = true; + } + if (resultHasNoReferences) { + MortalList.flushAboveMark(); + } + } + private static RuntimeList copyReturnedReferenceScalars(RuntimeList result, int originalContext, boolean copyCapturedScalars, boolean recyclableScalarResult) { diff --git a/src/test/resources/unit/eval_unwind_destructor_error.t b/src/test/resources/unit/eval_unwind_destructor_error.t new file mode 100644 index 0000000000..d98c3b0284 --- /dev/null +++ b/src/test/resources/unit/eval_unwind_destructor_error.t @@ -0,0 +1,19 @@ +use strict; +use warnings; +use Test::More tests => 2; + +{ + package EvalUnwindGuard; + sub DESTROY { $_[0]->() } +} + +my $observed_error; +$@ = "before\n"; +eval { + $@ = "inside\n"; + my $guard = bless(sub { $observed_error = $@ }, 'EvalUnwindGuard'); + 1; +}; + +is($observed_error, "inside\n", 'eval keeps its error value during destructor unwinding'); +is($@, '', 'successful eval clears the error after destructor unwinding'); diff --git a/src/test/resources/unit/rmdir_missing_errno.t b/src/test/resources/unit/rmdir_missing_errno.t new file mode 100644 index 0000000000..b9ba3aa39c --- /dev/null +++ b/src/test/resources/unit/rmdir_missing_errno.t @@ -0,0 +1,13 @@ +use strict; +use warnings; +use Errno qw(ENOENT); +use Test::More tests => 3; + +my $missing = "rmdir-missing-$$"; +ok(!-e $missing, 'test path is absent'); + +{ + local $!; + ok(!rmdir($missing), 'rmdir fails for a nonexistent path'); + is(0 + $!, ENOENT, 'rmdir reports ENOENT'); +} From 56f07c10a728fc5a6f813909c77c4bbe0ee91663 Mon Sep 17 00:00:00 2001 From: "Flavio S. Glock" Date: Fri, 2 Oct 2026 21:40:04 +0200 Subject: [PATCH 23/41] fix: correct sprintf flags and interpolated regex classes Keep sprintf coercions single-pass and propagate UTF-8 provenance only from the format string or a Unicode regex stringification. Compile interpolated Unicode regex patterns with Unicode character classes. Generated with [Codex](https://openai.com/codex) Co-Authored-By: Codex <158243242+codex@users.noreply.github.com> --- docs/about/changelog.md | 2 + .../runtime/operators/SprintfOperator.java | 38 ++++++++++++------- .../sprintf/SprintfValueFormatter.java | 13 ++++--- .../runtime/regex/RuntimeRegex.java | 3 +- .../interpolated_named_character_class.t | 32 ++++++++++++++++ .../unit/sprintf_overload_utf8_flag.t | 23 +++++++++++ 6 files changed, 91 insertions(+), 20 deletions(-) create mode 100644 src/test/resources/unit/regex/interpolated_named_character_class.t create mode 100644 src/test/resources/unit/sprintf_overload_utf8_flag.t diff --git a/docs/about/changelog.md b/docs/about/changelog.md index ce3c5cc1a5..133d91e8b0 100644 --- a/docs/about/changelog.md +++ b/docs/about/changelog.md @@ -29,6 +29,8 @@ priorities and future plans. - Report deleted stash-backed subroutines as anonymous in `caller()`. - Detect oversized repetition counts before they wrap during conversion. - Run eval-block destructors before clearing `$@`, and report `ENOENT` from failed `rmdir` calls. +- Preserve `sprintf` numeric overload counts and format-string UTF-8 flags. +- Apply Unicode character classes to interpolated Unicode regex patterns. - Preserve objects with counted collection owners during weak-reference sweeps, and resolve deferred user-defined regex properties in the match caller's diff --git a/src/main/java/org/perlonjava/runtime/operators/SprintfOperator.java b/src/main/java/org/perlonjava/runtime/operators/SprintfOperator.java index a1872ffcb5..1e4107cbc7 100644 --- a/src/main/java/org/perlonjava/runtime/operators/SprintfOperator.java +++ b/src/main/java/org/perlonjava/runtime/operators/SprintfOperator.java @@ -57,21 +57,9 @@ private static RuntimeScalar sprintfInternal(RuntimeScalar runtimeScalar, Runtim } } String format = runtimeScalar.toString(); - // Track if any input has UTF-8 flag — sprintf produces byte string unless - // the format or a %s argument has UTF-8 flag on + // sprintf's result UTF-8 flag follows the format string. UTF-8 flags on + // width, precision, and value arguments do not upgrade the result. boolean hasUtf8Input = runtimeScalar.type == RuntimeScalarType.STRING; - if (!hasUtf8Input) { - for (RuntimeBase elem : list.elements) { - if (elem instanceof RuntimeScalar rs - && (rs.type == RuntimeScalarType.STRING - || rs.type == RuntimeScalarType.REGEX - && rs.value instanceof RuntimeRegex regex - && !regex.isPatternByteBacked())) { - hasUtf8Input = true; - break; - } - } - } StringBuilder result = new StringBuilder(); int argIndex = 0; // Sequential argument index @@ -194,6 +182,18 @@ private static RuntimeScalar sprintfInternal(RuntimeScalar runtimeScalar, Runtim ProcessResult processResult = processFormatSpecifierTracked(spec, list, argIndex, formatter, bytesMode); result.append(processResult.formatted); charsWritten += processResult.formatted.length(); + if (!bytesMode && spec.conversionChar == 's' && !spec.vectorFlag) { + int valueIndex = formattedValueIndex(spec, argIndex); + if (valueIndex >= 0 && valueIndex < list.size() + && list.elements.get(valueIndex) instanceof RuntimeScalar value + && value.type == RuntimeScalarType.REGEX + && value.value instanceof RuntimeRegex regex + && !regex.isPatternByteBacked()) { + // Stringifying a Unicode qr// contributes a UTF-8 + // string even when other %s arguments stay byte-backed. + hasUtf8Input = true; + } + } if (GlobalContext.isTaintModeActive()) { hasTaintedArgument |= usedArgumentIsTainted(spec, list, argIndex); } @@ -285,6 +285,16 @@ private static boolean usedArgumentIsTainted(FormatSpecifier spec, RuntimeList l return false; } + private static int formattedValueIndex(FormatSpecifier spec, int argIndex) { + if (spec.parameterIndex != null) { + return spec.parameterIndex - 1; + } + int valueIndex = argIndex; + if (spec.widthFromArg && spec.widthArgIndex == null) valueIndex++; + if (spec.precisionFromArg && spec.precisionArgIndex == null) valueIndex++; + return valueIndex; + } + private static void handlePercentN(FormatSpecifier spec, RuntimeList list, int argIndex, int charsWritten) { int targetIndex = spec.parameterIndex != null ? spec.parameterIndex - 1 : argIndex; diff --git a/src/main/java/org/perlonjava/runtime/operators/sprintf/SprintfValueFormatter.java b/src/main/java/org/perlonjava/runtime/operators/sprintf/SprintfValueFormatter.java index f261d437fd..47bb2bb6ca 100644 --- a/src/main/java/org/perlonjava/runtime/operators/sprintf/SprintfValueFormatter.java +++ b/src/main/java/org/perlonjava/runtime/operators/sprintf/SprintfValueFormatter.java @@ -82,11 +82,14 @@ public String formatValue(RuntimeScalar value, String flags, int width, value = RuntimeScalarCache.scalarZero; } - // Check for special floating-point values for numeric conversions - // This includes %c - sprintf "%c", Inf should error in Perl - double doubleValue = value.getDouble(); - if (Double.isInfinite(doubleValue) || Double.isNaN(doubleValue)) { - return numericFormatter.formatSpecialValue(doubleValue, flags, width, conversion); + // Preserve special floating-point values without coercing overloaded + // references a second time. Other numeric conversions perform their + // one required coercion in the formatter below. + if (value.type == RuntimeScalarType.DOUBLE) { + double doubleValue = (double) value.value; + if (Double.isInfinite(doubleValue) || Double.isNaN(doubleValue)) { + return numericFormatter.formatSpecialValue(doubleValue, flags, width, conversion); + } } // Dispatch to appropriate formatter based on conversion type diff --git a/src/main/java/org/perlonjava/runtime/regex/RuntimeRegex.java b/src/main/java/org/perlonjava/runtime/regex/RuntimeRegex.java index 10e69dfb9b..01a3649728 100644 --- a/src/main/java/org/perlonjava/runtime/regex/RuntimeRegex.java +++ b/src/main/java/org/perlonjava/runtime/regex/RuntimeRegex.java @@ -992,7 +992,8 @@ private static synchronized RuntimeRegex compileSynchronized( } regex.recursivePattern = new JoniRegexPattern(compilePatternString, regex.regexFlags, trustedCalloutCount, - !regex.regexFlags.isUnicode(), false, false, + !regex.regexFlags.isUnicode() && patternByteBacked, + false, false, regex.namedCharacterCache, namedCharacterSourceMode, lexicalReStrict, (lexicalDebugMode & LEXICAL_DEBUG_PARSE) != 0); diff --git a/src/test/resources/unit/regex/interpolated_named_character_class.t b/src/test/resources/unit/regex/interpolated_named_character_class.t new file mode 100644 index 0000000000..a70f6b7e7c --- /dev/null +++ b/src/test/resources/unit/regex/interpolated_named_character_class.t @@ -0,0 +1,32 @@ +use strict; +use warnings; +use charnames ':full'; +use Test::More tests => 4; + +my $class_match = eval q{ + my $re1 = "\N{WHITE SMILING FACE}"; + my $e_grave = chr utf8::unicode_to_native(0xE8); + $e_grave =~ qr/[\w$re1]/; +}; +ok($class_match, + 'interpolated named character keeps Unicode character-class matching'); + +my $alternation_match = eval q{ + my $re2 = "\N{WHITE SMILING FACE}"; + my $e_grave = chr utf8::unicode_to_native(0xE8); + $e_grave =~ qr/\w|$re2/; +}; +ok($alternation_match, + 'interpolated named character keeps Unicode alternation matching'); +my $smile_match = eval q{ + my $smile = "\N{WHITE SMILING FACE}"; + $smile =~ qr/[\w$smile]/; +}; +ok($smile_match, + 'interpolated named character matches its own character class'); +my $punctuation_match = eval q{ + my $smile = "\N{WHITE SMILING FACE}"; + '!' =~ qr/[\w$smile]/; +}; +ok(!$punctuation_match, + 'interpolated named character class rejects unrelated punctuation'); diff --git a/src/test/resources/unit/sprintf_overload_utf8_flag.t b/src/test/resources/unit/sprintf_overload_utf8_flag.t new file mode 100644 index 0000000000..da6ee6b75c --- /dev/null +++ b/src/test/resources/unit/sprintf_overload_utf8_flag.t @@ -0,0 +1,23 @@ +use strict; +use warnings; +use Test::More tests => 4; + +{ + package SprintfCount; + use overload '0+' => sub { ++$SprintfCount::count; $_[0]->[0] }, fallback => 1; + our $count = 0; +} + +my $number = bless [42], 'SprintfCount'; +$SprintfCount::count = 0; +is(sprintf('%d', $number), '42', 'integer conversion formats the overloaded number'); +is($SprintfCount::count, 1, 'numeric overload is called once'); + +my $precision = '9'; +utf8::upgrade($precision); +my $formatted = sprintf("%.*f\n", $precision, 1.1); +ok(!utf8::is_utf8($formatted), 'UTF-8 precision does not upgrade the sprintf result'); + +my $wide_string = "\x{e9}"; +my $string_result = sprintf('%s', $wide_string); +ok(!utf8::is_utf8($string_result), 'UTF-8 string argument does not upgrade the sprintf result'); From b02abff1056334fd49f75088a17fa65d20b1f78e Mon Sep 17 00:00:00 2001 From: "Flavio S. Glock" Date: Fri, 2 Oct 2026 22:17:12 +0200 Subject: [PATCH 24/41] fix: preserve Unicode case and method-name semantics Move uppercase ypogegrammeni after its combining sequence, and avoid reinterpreting unflagged byte strings as UTF-8 method names in can(). Generated with [Codex](https://openai.com/codex) Co-Authored-By: Codex <158243242+codex@users.noreply.github.com> --- docs/about/changelog.md | 1 + .../runtime/operators/StringOperators.java | 31 +++++++++++++++++-- .../runtime/perlmodule/Universal.java | 7 +++-- .../resources/unit/uc_ypogegrammeni_order.t | 13 ++++++++ .../unit/utf8_can_reject_unflagged_octets.t | 16 ++++++++++ 5 files changed, 64 insertions(+), 4 deletions(-) create mode 100644 src/test/resources/unit/uc_ypogegrammeni_order.t create mode 100644 src/test/resources/unit/utf8_can_reject_unflagged_octets.t diff --git a/docs/about/changelog.md b/docs/about/changelog.md index 133d91e8b0..a539636ceb 100644 --- a/docs/about/changelog.md +++ b/docs/about/changelog.md @@ -31,6 +31,7 @@ priorities and future plans. - Run eval-block destructors before clearing `$@`, and report `ENOENT` from failed `rmdir` calls. - Preserve `sprintf` numeric overload counts and format-string UTF-8 flags. - Apply Unicode character classes to interpolated Unicode regex patterns. +- Preserve combining-mark order in Unicode uppercase mappings and honor byte-string method names in `can`. - Preserve objects with counted collection owners during weak-reference sweeps, and resolve deferred user-defined regex properties in the match caller's diff --git a/src/main/java/org/perlonjava/runtime/operators/StringOperators.java b/src/main/java/org/perlonjava/runtime/operators/StringOperators.java index ae570c764b..a023077ce4 100644 --- a/src/main/java/org/perlonjava/runtime/operators/StringOperators.java +++ b/src/main/java/org/perlonjava/runtime/operators/StringOperators.java @@ -392,11 +392,38 @@ public static RuntimeScalar ucUnicode(RuntimeScalar runtimeScalar) { } private static RuntimeScalar ucUnicodeUnpropagated(RuntimeScalar runtimeScalar) { - // Convert the string to uppercase using ICU4J for proper Unicode handling - String str = UCharacter.toUpperCase(runtimeScalar.toString()); + // U+0345 (COMBINING GREEK YPOGEGRAMMENI) becomes a spacing capital + // iota when uppercased. Move it after the rest of its combining + // sequence first, preserving canonical mark order (as Perl does). + String input = moveYpogegrammeniAfterCombiningMarks(runtimeScalar.toString()); + String str = UCharacter.toUpperCase(input); return makeStringResult(str, runtimeScalar); } + private static String moveYpogegrammeniAfterCombiningMarks(String input) { + StringBuilder reordered = new StringBuilder(input.length()); + for (int offset = 0; offset < input.length();) { + int codePoint = input.codePointAt(offset); + int nextOffset = offset + Character.charCount(codePoint); + if (codePoint == 0x0345) { + int marksEnd = nextOffset; + while (marksEnd < input.length()) { + int following = input.codePointAt(marksEnd); + if (UCharacter.getCombiningClass(following) == 0) break; + marksEnd += Character.charCount(following); + } + if (marksEnd > nextOffset) { + reordered.append(input, nextOffset, marksEnd).appendCodePoint(codePoint); + offset = marksEnd; + continue; + } + } + reordered.appendCodePoint(codePoint); + offset = nextOffset; + } + return reordered.toString(); + } + /** * Converts the first character of the string representation of the given {@link RuntimeScalar} to titlecase. * Uses ICU4J for full Unicode support. Note: titlecase is different from uppercase for some characters diff --git a/src/main/java/org/perlonjava/runtime/perlmodule/Universal.java b/src/main/java/org/perlonjava/runtime/perlmodule/Universal.java index ae17f7393f..b9806aaf1d 100644 --- a/src/main/java/org/perlonjava/runtime/perlmodule/Universal.java +++ b/src/main/java/org/perlonjava/runtime/perlmodule/Universal.java @@ -105,7 +105,9 @@ public static RuntimeList can(RuntimeArray args, int ctx) { throw new IllegalStateException("Bad number of arguments for can() method"); } RuntimeScalar object = args.get(0); - String methodName = args.get(1).toString(); + RuntimeScalar methodNameScalar = args.get(1); + String methodName = methodNameScalar.toString(); + boolean methodNameHasUtf8Flag = methodNameScalar.type != RuntimeScalarType.BYTE_STRING; // Retrieve Perl class name String perlClassName; @@ -224,7 +226,8 @@ public static RuntimeList can(RuntimeArray args, int ctx) { // Fallback: if either the class name or method name was stored as UTF-8 octets // (common when source/strings are treated as raw bytes), retry using a decoded form. - String decodedMethodName = tryDecodeUtf8Octets(methodName); + String decodedMethodName = methodNameHasUtf8Flag + ? tryDecodeUtf8Octets(methodName) : null; String decodedClassName = tryDecodeUtf8Octets(perlClassName); if (decodedMethodName != null || decodedClassName != null) { String effectiveMethodName = decodedMethodName != null ? decodedMethodName : methodName; diff --git a/src/test/resources/unit/uc_ypogegrammeni_order.t b/src/test/resources/unit/uc_ypogegrammeni_order.t new file mode 100644 index 0000000000..3dd24294b3 --- /dev/null +++ b/src/test/resources/unit/uc_ypogegrammeni_order.t @@ -0,0 +1,13 @@ +use strict; +use warnings; +use utf8; +use feature 'unicode_strings'; +use Test::More; + +is( + uc("\x{3B1}\x{345}\x{301}"), + "\x{391}\x{301}\x{399}", + 'uppercase moves ypogegrammeni after following combining marks', +); + +done_testing(); diff --git a/src/test/resources/unit/utf8_can_reject_unflagged_octets.t b/src/test/resources/unit/utf8_can_reject_unflagged_octets.t new file mode 100644 index 0000000000..062453f342 --- /dev/null +++ b/src/test/resources/unit/utf8_can_reject_unflagged_octets.t @@ -0,0 +1,16 @@ +use strict; +use warnings; +use utf8; +use Test::More; + +{ + package Utf8MethodLookup; + sub nèw { bless {}, shift } +} + +my $method = "nèw"; +utf8::encode($method); +ok(!Utf8MethodLookup->can($method), + 'can does not decode unflagged UTF-8 octets into a method name'); + +done_testing(); From 5f695e6bb762879e5c67911109c68487a38a831d Mon Sep 17 00:00:00 2001 From: "Flavio S. Glock" Date: Fri, 2 Oct 2026 22:44:39 +0200 Subject: [PATCH 25/41] fix: reject invalid hash prototype arguments Reject constants passed to a backslash hash prototype during parsing so eval receives the expected type diagnostic, including UTF-8 sub names. Generated with [Codex](https://openai.com/codex) Co-Authored-By: Codex <158243242+codex@users.noreply.github.com> --- docs/about/changelog.md | 1 + .../org/perlonjava/frontend/parser/PrototypeArgs.java | 6 ++++++ .../unit/prototype_utf8_bad_type_diagnostic.t | 10 ++++++++++ 3 files changed, 17 insertions(+) create mode 100644 src/test/resources/unit/prototype_utf8_bad_type_diagnostic.t diff --git a/docs/about/changelog.md b/docs/about/changelog.md index a539636ceb..3c1bd6a4fe 100644 --- a/docs/about/changelog.md +++ b/docs/about/changelog.md @@ -32,6 +32,7 @@ priorities and future plans. - Preserve `sprintf` numeric overload counts and format-string UTF-8 flags. - Apply Unicode character classes to interpolated Unicode regex patterns. - Preserve combining-mark order in Unicode uppercase mappings and honor byte-string method names in `can`. +- Reject scalar constants passed to hash-reference prototypes with the expected diagnostic. - Preserve objects with counted collection owners during weak-reference sweeps, and resolve deferred user-defined regex properties in the match caller's diff --git a/src/main/java/org/perlonjava/frontend/parser/PrototypeArgs.java b/src/main/java/org/perlonjava/frontend/parser/PrototypeArgs.java index 2b0e4f527e..f5f792b4df 100644 --- a/src/main/java/org/perlonjava/frontend/parser/PrototypeArgs.java +++ b/src/main/java/org/perlonjava/frontend/parser/PrototypeArgs.java @@ -1436,6 +1436,12 @@ private static void validateBackslashPrototypeArgument(Parser parser, ListNode a } Character actualSigil = sigilForBackslashPrototypeArg(referenceArg); + if (refType == '%' && actualSigil == null) { + 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 hash (not " + describeBackslashPrototypeArg(referenceArg) + ")"); + } if (actualSigil == null || actualSigil == refType) { return; } diff --git a/src/test/resources/unit/prototype_utf8_bad_type_diagnostic.t b/src/test/resources/unit/prototype_utf8_bad_type_diagnostic.t new file mode 100644 index 0000000000..ec398eb58c --- /dev/null +++ b/src/test/resources/unit/prototype_utf8_bad_type_diagnostic.t @@ -0,0 +1,10 @@ +use strict; +use warnings; +use utf8; +use Test::More; + +eval q!sub ネ (\%) {} ネ(1);!; +like($@, qr/Type of arg 1 to main::ネ must be hash/u, + 'bad prototype argument diagnostic preserves UTF-8 subroutine names'); + +done_testing(); From 1ebde60c3291c8acd3b3bacf5954cc7ea1124a28 Mon Sep 17 00:00:00 2001 From: "Flavio S. Glock" Date: Fri, 2 Oct 2026 23:25:34 +0200 Subject: [PATCH 26/41] fix: preserve UTF-8 octets across I/O and child launches Keep malformed octets intact through Perl's :utf8 input layer while decoding valid sequences, and preserve the byte-string semantics of ASCII $^X paths. Add focused regressions for raw output and UTF-8 input through shell children. Generated with [Codex](https://openai.com/codex) Co-Authored-By: Codex <158243242+codex@users.noreply.github.com> --- docs/about/changelog.md | 2 + .../perlonjava/runtime/io/EncodingLayer.java | 120 ++++++++++++++++++ .../runtime/runtimetypes/GlobalContext.java | 8 ++ .../shell_command_preserves_utf8_octets.t | 13 ++ .../utf8_layer_preserves_malformed_octets.t | 24 ++++ 5 files changed, 167 insertions(+) create mode 100644 src/test/resources/unit/shell_command_preserves_utf8_octets.t create mode 100644 src/test/resources/unit/utf8_layer_preserves_malformed_octets.t diff --git a/docs/about/changelog.md b/docs/about/changelog.md index 3c1bd6a4fe..f1d8243d53 100644 --- a/docs/about/changelog.md +++ b/docs/about/changelog.md @@ -33,6 +33,8 @@ priorities and future plans. - Apply Unicode character classes to interpolated Unicode regex patterns. - Preserve combining-mark order in Unicode uppercase mappings and honor byte-string method names in `can`. - Reject scalar constants passed to hash-reference prototypes with the expected diagnostic. +- Preserve malformed octets read through Perl's `:utf8` layer while decoding valid UTF-8. +- Keep `$^X` unflagged for shell command construction and preserve encoded input octets. - Preserve objects with counted collection owners during weak-reference sweeps, and resolve deferred user-defined regex properties in the match caller's diff --git a/src/main/java/org/perlonjava/runtime/io/EncodingLayer.java b/src/main/java/org/perlonjava/runtime/io/EncodingLayer.java index 181b58a8ef..6d4ebe9009 100644 --- a/src/main/java/org/perlonjava/runtime/io/EncodingLayer.java +++ b/src/main/java/org/perlonjava/runtime/io/EncodingLayer.java @@ -116,6 +116,9 @@ public Charset getCharset() { @Override public String processInput(String input) { validateUtf8Input(input, false); + if ("utf8".equalsIgnoreCase(layerName)) { + return processUncheckedUtf8(input); + } // Add new bytes to buffer for (int i = 0; i < input.length(); i++) { if (!inputBuffer.hasRemaining()) { @@ -164,6 +167,9 @@ public String takeDeferredMalformedUtf8Warning() { /** Flush an incomplete encoded sequence at EOF, preserving Perl's replacement behavior. */ public String flushInput() { + if ("utf8".equalsIgnoreCase(layerName)) { + return flushUncheckedUtf8(); + } if (inputBuffer.position() == 0) { validateUtf8Input("", true); return ""; @@ -179,6 +185,120 @@ public String flushInput() { return output.toString(); } + /** + * Perl's :utf8 layer decodes valid UTF-8 but leaves malformed octets in + * their original byte form. The stricter :encoding(UTF-8) layer uses the + * replacement behavior of CharsetDecoder instead. + */ + private String processUncheckedUtf8(String input) { + appendInputBytes(input); + return decodeUncheckedUtf8(false); + } + + private String flushUncheckedUtf8() { + String result = decodeUncheckedUtf8(true); + validateUtf8Input("", true); + decoder.reset(); + return result; + } + + private void appendInputBytes(String input) { + for (int i = 0; i < input.length(); i++) { + if (!inputBuffer.hasRemaining()) { + ByteBuffer expanded = ByteBuffer.allocate(inputBuffer.capacity() * 2); + inputBuffer.flip(); + expanded.put(inputBuffer); + inputBuffer = expanded; + } + inputBuffer.put((byte) input.charAt(i)); + } + } + + private String decodeUncheckedUtf8(boolean endOfInput) { + inputBuffer.flip(); + byte[] bytes = new byte[inputBuffer.remaining()]; + inputBuffer.get(bytes); + inputBuffer.clear(); + + StringBuilder decoded = new StringBuilder(bytes.length); + int position = 0; + while (position < bytes.length) { + int first = bytes[position] & 0xff; + if (first <= 0x7f) { + decoded.append((char) first); + position++; + continue; + } + + int sequenceLength = utf8SequenceLength(first); + if (sequenceLength == 0) { + decoded.append((char) first); + position++; + continue; + } + + int available = bytes.length - position; + if (available < sequenceLength) { + if (!endOfInput && isUtf8Prefix(bytes, position, available, sequenceLength)) { + inputBuffer.put(bytes, position, available); + break; + } + decoded.append((char) first); + position++; + continue; + } + + int codePoint = first & (0x7f >> sequenceLength); + boolean valid = true; + for (int offset = 1; offset < sequenceLength; offset++) { + int next = bytes[position + offset] & 0xff; + if ((next & 0xc0) != 0x80 + || (offset == 1 && !validUtf8SecondByte(first, next))) { + valid = false; + break; + } + codePoint = (codePoint << 6) | (next & 0x3f); + } + + if (valid) { + decoded.appendCodePoint(codePoint); + position += sequenceLength; + } else { + // Preserve the malformed lead octet. The following bytes are + // checked independently, as Perl's unchecked UTF-8 scalars do. + decoded.append((char) first); + position++; + } + } + return decoded.toString(); + } + + private static int utf8SequenceLength(int first) { + if (first >= 0xc2 && first <= 0xdf) return 2; + if (first >= 0xe0 && first <= 0xef) return 3; + if (first >= 0xf0 && first <= 0xf4) return 4; + return 0; + } + + private static boolean isUtf8Prefix(byte[] bytes, int position, int available, int sequenceLength) { + int first = bytes[position] & 0xff; + for (int offset = 1; offset < available; offset++) { + int next = bytes[position + offset] & 0xff; + if ((next & 0xc0) != 0x80 || (offset == 1 && !validUtf8SecondByte(first, next))) { + return false; + } + } + return available < sequenceLength; + } + + private static boolean validUtf8SecondByte(int first, int second) { + if (first == 0xe0) return second >= 0xa0; + if (first == 0xed) return second <= 0x9f; + if (first == 0xf0) return second >= 0x90; + if (first == 0xf4) return second <= 0x8f; + return true; + } + private void validateUtf8Input(String input, boolean endOfInput) { if (!"utf8".equalsIgnoreCase(layerName)) return; for (int i = 0; i < input.length(); i++) { diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/GlobalContext.java b/src/main/java/org/perlonjava/runtime/runtimetypes/GlobalContext.java index c287da8efa..8495a9841a 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/GlobalContext.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/GlobalContext.java @@ -115,6 +115,14 @@ public static void initializeGlobals(CompilerOptions compilerOptions) { // Fallback to "jperl" if environment variable is not set executableVariable.set("jperl"); } + // Perl's $^X comes from an OS executable path and is ordinarily an + // unflagged byte string. Mark ASCII paths accordingly so interpolating + // $^X into a shell command does not upgrade neighboring octets to + // Unicode before the command reaches ProcessBuilder. Keep non-ASCII + // Java paths as Unicode because ProcessBuilder must encode them. + if (executableVariable.toString().chars().allMatch(ch -> ch <= 0x7f)) { + executableVariable.type = RuntimeScalarType.BYTE_STRING; + } if (compilerOptions.taintMode || compilerOptions.taintWarnings) { executableVariable.tainted = true; } diff --git a/src/test/resources/unit/shell_command_preserves_utf8_octets.t b/src/test/resources/unit/shell_command_preserves_utf8_octets.t new file mode 100644 index 0000000000..8572b463f5 --- /dev/null +++ b/src/test/resources/unit/shell_command_preserves_utf8_octets.t @@ -0,0 +1,13 @@ +use strict; +use warnings; +use Test::More; + +ok(!utf8::is_utf8($^X), '$^X is an unflagged executable path'); + +my $octets = chr(256); +utf8::encode($octets); +my $command = "$^X -e 'print qq($octets)' | $^X -CI -e 'print ord()'"; +my $output = `$command`; +is($output, '256', 'shell command preserves UTF-8 octets between Perl processes'); + +done_testing(); diff --git a/src/test/resources/unit/utf8_layer_preserves_malformed_octets.t b/src/test/resources/unit/utf8_layer_preserves_malformed_octets.t new file mode 100644 index 0000000000..aacdf2ba36 --- /dev/null +++ b/src/test/resources/unit/utf8_layer_preserves_malformed_octets.t @@ -0,0 +1,24 @@ +use strict; +use warnings; +use Test::More; + +{ + my $octets = "\xC1\xAF\xC1\xAF\xC1\xB0\xC1\xB3"; + open my $fh, '<:utf8', \$octets or die "Could not open scalar handle: $!"; + ok(read($fh, my $value, length($octets)), 'read malformed UTF-8 octets'); + my $printed = ''; + open my $out, '>:raw', \$printed or die "Could not open output scalar: $!"; + print {$out} $value; + close $out; + is(unpack('H*', $printed), 'c1afc1afc1b0c1b3', + ':utf8 preserves malformed octets for output'); +} + +{ + my $octets = "\xC4\x80"; + open my $fh, '<:utf8', \$octets or die "Could not open scalar handle: $!"; + ok(read($fh, my $value, length($octets)), 'read valid UTF-8 bytes'); + is(ord($value), 256, ':utf8 decodes a valid multibyte character'); +} + +done_testing(); From 1736dadbf7dc22e8b373b54700f8cecf1412288f Mon Sep 17 00:00:00 2001 From: "Flavio S. Glock" Date: Fri, 2 Oct 2026 23:46:12 +0200 Subject: [PATCH 27/41] fix: evaluate readline in discarded list assignments Keep readline operations in list context when empty-target assignments discard their values, so the full input list is consumed on both backends. Add a focused regression for EOF after an empty-list assignment. Generated with [Codex](https://openai.com/codex) Co-Authored-By: Codex <158243242+codex@users.noreply.github.com> --- docs/about/changelog.md | 1 + .../backend/bytecode/CompileAssignment.java | 4 +- .../perlonjava/backend/jvm/EmitVariable.java | 2 + .../ListContextSideEffectDetector.java | 73 +++++++++++++++++++ .../empty_list_assignment_consumes_readline.t | 12 +++ 5 files changed, 91 insertions(+), 1 deletion(-) create mode 100644 src/main/java/org/perlonjava/frontend/analysis/ListContextSideEffectDetector.java create mode 100644 src/test/resources/unit/empty_list_assignment_consumes_readline.t diff --git a/docs/about/changelog.md b/docs/about/changelog.md index f1d8243d53..1e85c66e82 100644 --- a/docs/about/changelog.md +++ b/docs/about/changelog.md @@ -35,6 +35,7 @@ priorities and future plans. - Reject scalar constants passed to hash-reference prototypes with the expected diagnostic. - Preserve malformed octets read through Perl's `:utf8` layer while decoding valid UTF-8. - Keep `$^X` unflagged for shell command construction and preserve encoded input octets. +- Evaluate `readline` in list context when an empty-target assignment discards its results. - Preserve objects with counted collection owners during weak-reference sweeps, and resolve deferred user-defined regex properties in the match caller's diff --git a/src/main/java/org/perlonjava/backend/bytecode/CompileAssignment.java b/src/main/java/org/perlonjava/backend/bytecode/CompileAssignment.java index eb7f8cbf70..2487ac2179 100644 --- a/src/main/java/org/perlonjava/backend/bytecode/CompileAssignment.java +++ b/src/main/java/org/perlonjava/backend/bytecode/CompileAssignment.java @@ -2,6 +2,7 @@ import org.perlonjava.frontend.analysis.ConstantFoldingVisitor; import org.perlonjava.frontend.analysis.LValueVisitor; +import org.perlonjava.frontend.analysis.ListContextSideEffectDetector; import org.perlonjava.frontend.analysis.RegexUsageDetector; import org.perlonjava.frontend.astnode.*; import org.perlonjava.frontend.semantic.SymbolTable; @@ -2187,7 +2188,8 @@ && isLocalizedArraySliceReferenceTarget(referenceOp.operand)) { if (outerContext == RuntimeContextType.VOID && node.left instanceof ListNode emptyTargets && emptyTargets.elements.isEmpty()) { - boolean preserveListContext = RegexUsageDetector.containsRegexOperation(node.right); + boolean preserveListContext = RegexUsageDetector.containsRegexOperation(node.right) + || ListContextSideEffectDetector.containsReadline(node.right); if (!preserveListContext && node.right instanceof ListNode rhsList) { rhsList.setAnnotation("emptyTargetAssignmentVoidRhs", true); } diff --git a/src/main/java/org/perlonjava/backend/jvm/EmitVariable.java b/src/main/java/org/perlonjava/backend/jvm/EmitVariable.java index a8987a1c1e..cbd50aef6b 100644 --- a/src/main/java/org/perlonjava/backend/jvm/EmitVariable.java +++ b/src/main/java/org/perlonjava/backend/jvm/EmitVariable.java @@ -7,6 +7,7 @@ import org.objectweb.asm.Opcodes; import org.perlonjava.frontend.analysis.EmitterVisitor; import org.perlonjava.frontend.analysis.LValueVisitor; +import org.perlonjava.frontend.analysis.ListContextSideEffectDetector; import org.perlonjava.frontend.analysis.RegexUsageDetector; import org.perlonjava.frontend.astnode.*; import org.perlonjava.frontend.semantic.SymbolTable; @@ -892,6 +893,7 @@ static void handleAssignOperator(EmitterVisitor emitterVisitor, BinaryOperatorNo // matches (including callbacks) even when its result list is // discarded by the empty target. int rhsContext = RegexUsageDetector.containsRegexOperation(right) + || ListContextSideEffectDetector.containsReadline(right) ? RuntimeContextType.LIST : RuntimeContextType.VOID; right.accept(emitterVisitor.with(rhsContext)); if (rhsContext == RuntimeContextType.LIST) { diff --git a/src/main/java/org/perlonjava/frontend/analysis/ListContextSideEffectDetector.java b/src/main/java/org/perlonjava/frontend/analysis/ListContextSideEffectDetector.java new file mode 100644 index 0000000000..212e52fc44 --- /dev/null +++ b/src/main/java/org/perlonjava/frontend/analysis/ListContextSideEffectDetector.java @@ -0,0 +1,73 @@ +package org.perlonjava.frontend.analysis; + +import org.perlonjava.frontend.astnode.*; + +import java.util.ArrayDeque; +import java.util.Deque; +import java.util.List; + +/** Finds operations whose side effects require list evaluation even when results are discarded. */ +public final class ListContextSideEffectDetector { + private ListContextSideEffectDetector() {} + + /** + * {@code readline} in an empty-target list assignment must consume the + * complete input list even when the assignment's own value is discarded. + */ + public static boolean containsReadline(Node root) { + if (root == null) return false; + Deque pending = new ArrayDeque<>(); + pending.push(root); + while (!pending.isEmpty()) { + Node node = pending.pop(); + if (node instanceof SubroutineNode) continue; + if (node instanceof BinaryOperatorNode binary) { + if ("readline".equals(binary.operator)) return true; + if (binary.left != null) pending.push(binary.left); + if (binary.right != null) pending.push(binary.right); + } else if (node instanceof OperatorNode operator) { + if (operator.operand != null) pending.push(operator.operand); + } else if (node instanceof BlockNode block) { + pushAll(pending, block.elements); + } else if (node instanceof ListNode list) { + pushAll(pending, list.elements); + if (list.handle != null) pending.push(list.handle); + } else if (node instanceof IfNode conditional) { + if (conditional.condition != null) pending.push(conditional.condition); + if (conditional.thenBranch != null) pending.push(conditional.thenBranch); + if (conditional.elseBranch != null) pending.push(conditional.elseBranch); + } else if (node instanceof For1Node loop) { + if (loop.variable != null) pending.push(loop.variable); + if (loop.list != null) pending.push(loop.list); + if (loop.body != null) pending.push(loop.body); + if (loop.continueBlock != null) pending.push(loop.continueBlock); + } else if (node instanceof For3Node loop) { + if (loop.initialization != null) pending.push(loop.initialization); + if (loop.condition != null) pending.push(loop.condition); + if (loop.increment != null) pending.push(loop.increment); + if (loop.body != null) pending.push(loop.body); + if (loop.continueBlock != null) pending.push(loop.continueBlock); + } else if (node instanceof TernaryOperatorNode ternary) { + if (ternary.condition != null) pending.push(ternary.condition); + if (ternary.trueExpr != null) pending.push(ternary.trueExpr); + if (ternary.falseExpr != null) pending.push(ternary.falseExpr); + } else if (node instanceof TryNode tryNode) { + if (tryNode.tryBlock != null) pending.push(tryNode.tryBlock); + if (tryNode.catchBlock != null) pending.push(tryNode.catchBlock); + if (tryNode.finallyBlock != null) pending.push(tryNode.finallyBlock); + } else if (node instanceof HashLiteralNode hash) { + pushAll(pending, hash.elements); + } else if (node instanceof ArrayLiteralNode array) { + pushAll(pending, array.elements); + } + } + return false; + } + + private static void pushAll(Deque pending, List elements) { + for (int index = elements.size() - 1; index >= 0; index--) { + Node element = elements.get(index); + if (element != null) pending.push(element); + } + } +} diff --git a/src/test/resources/unit/empty_list_assignment_consumes_readline.t b/src/test/resources/unit/empty_list_assignment_consumes_readline.t new file mode 100644 index 0000000000..c3b84e30dd --- /dev/null +++ b/src/test/resources/unit/empty_list_assignment_consumes_readline.t @@ -0,0 +1,12 @@ +use strict; +use warnings; +use Test::More; + +my $text = "first\nsecond\nthird\n"; +open my $fh, '<', \$text or die "Could not open scalar handle: $!"; +is(scalar(<$fh>), "first\n", 'read one line before resetting the handle'); +seek($fh, 0, 0) or die "Could not seek scalar handle: $!"; +() = <$fh>; +ok(eof($fh), 'empty list assignment evaluates readline in list context'); + +done_testing(); From 4c7537f84fbda57f23cf603df673378e98961aff Mon Sep 17 00:00:00 2001 From: "Flavio S. Glock" Date: Sat, 3 Oct 2026 00:36:42 +0200 Subject: [PATCH 28/41] fix: respect unavailable lexical cells in formats When a format references a lexical whose declaring scope has ended, do not resolve that name to a same-named package global or unrelated active lexical. Keep the captured cell only while it is active, otherwise use a fresh undef cell for the format argument evaluation. Generated with [Codex](https://openai.com/codex) Co-Authored-By: Codex <158243242+codex@users.noreply.github.com> --- docs/about/changelog.md | 1 + .../runtime/runtimetypes/RuntimeCode.java | 12 ++++++ .../runtime/runtimetypes/RuntimeFormat.java | 38 +++++++++++++++---- .../unit/format_unavailable_lexical_shadow.t | 32 ++++++++++++++++ 4 files changed, 75 insertions(+), 8 deletions(-) create mode 100644 src/test/resources/unit/format_unavailable_lexical_shadow.t diff --git a/docs/about/changelog.md b/docs/about/changelog.md index 1e85c66e82..599154cab3 100644 --- a/docs/about/changelog.md +++ b/docs/about/changelog.md @@ -6,6 +6,7 @@ priorities and future plans. ## Work in progress +- Prevent formats from reusing an unrelated active lexical when a captured lexical is unavailable. - Keep `close` and `fileno` probes from creating nonexistent symbolic filehandles. - Preserve typeglob values from scalar assignments and selected-handle lookups. - Return EOF as undef from scalar-backed `getc`, and let argumentless `system()` wait. diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeCode.java b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeCode.java index d56e160e40..c4e8475b98 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeCode.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeCode.java @@ -821,6 +821,18 @@ public static Map snapshotAllActiveLexicals() { return result; } + /** Whether this exact lexical cell belongs to any currently active CV. */ + public static boolean isActiveLexicalCell(RuntimeBase cell) { + if (cell == null) return false; + PerlRuntime runtime = PerlRuntime.current(); + for (ActiveLexicalFrame frame : activeLexicalFrames(runtime.executionState())) { + for (RuntimeBase activeCell : frame.cells().values()) { + if (activeCell == cell) return true; + } + } + return false; + } + /** * Select eval STRING captures for Perl's package-DB rule. An eval run by * a DB subroutine is evaluated in the lexical pad of the code being diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeFormat.java b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeFormat.java index 87d628cc18..96ad35fb20 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeFormat.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeFormat.java @@ -629,10 +629,14 @@ private List materializeLineArguments(ArgumentLine argLine, if (argLine.getAnnotation("unavailableLexicalVariableNames") instanceof List names && !names.isEmpty()) { for (Object value : names) { - if (!(value instanceof String name) || isPackageVariable(name)) continue; - RuntimeBase active = activeLexicals.get(name); - if (active != null) { - lexicalVariables.put(name, active); + if (!(value instanceof String name)) continue; + // A lexical can be unavailable because its declaring + // subroutine has returned. Do not replace that stale + // capture with an unrelated active lexical that happens + // to have the same name in the caller. Keep the captured + // cell only while that exact cell is still active. + RuntimeBase captured = lexicalVariables.get(name); + if (RuntimeCode.isActiveLexicalCell(captured)) { continue; } WarnDie.warn(new RuntimeScalar("Variable \"" + name @@ -642,12 +646,30 @@ private List materializeLineArguments(ArgumentLine argLine, } } for (String name : lexicalVariables.keySet()) { + if (argLine.getAnnotation("unavailableLexicalVariableNames") instanceof List unavailable + && unavailable.contains(name)) { + // The fallback above has already kept a live captured + // cell or installed a fresh undef cell. Do not resolve + // this name again from an unrelated caller frame. + continue; + } + RuntimeBase captured = lexicalVariables.get(name); + if (RuntimeCode.isActiveLexicalCell(captured)) { + continue; + } RuntimeBase active = activeLexicals.get(name); if (active != null) { - lexicalVariables.put(name, active); - } else if (!(argLine.getAnnotation("unavailableLexicalVariableNames") instanceof List unavailable - && unavailable.contains(name)) - && !isPackageVariable(name) + if (captured == null) { + lexicalVariables.put(name, active); + } else if (!isPackageVariable(name)) { + // Do not replace a stale declaration-scope cell with + // an unrelated active cell of the same name. + WarnDie.warn(new RuntimeScalar("Variable \"" + name + + "\" is not available at format " + formatName + "\n"), + new RuntimeScalar("")); + lexicalVariables.put(name, new RuntimeScalar()); + } + } else if (!isPackageVariable(name) && argLine.content.matches("(?s).*\\Q" + name + "\\E(?:\\b|\\W).*")) { // A FORMAT can outlive the CV whose lexical pad declared // an argument. Perl keeps the FORMAT callable, but diff --git a/src/test/resources/unit/format_unavailable_lexical_shadow.t b/src/test/resources/unit/format_unavailable_lexical_shadow.t new file mode 100644 index 0000000000..bb369d973e --- /dev/null +++ b/src/test/resources/unit/format_unavailable_lexical_shadow.t @@ -0,0 +1,32 @@ +#!/usr/bin/env perl + +use strict; +use warnings; +use Test::More tests => 1; + +our $r; +our $x; +my ($first_format_ref, $second_format_ref); + +sub declare_stale_lexical_format { + my $x; + format STALE_LEXICAL_FORMAT = +@ +$r = \$x +. +} + +{ + # An unrelated active lexical must not replace the format's unavailable + # declaration-scope lexical just because both variables are named $x. + my $x = 'unrelated active lexical'; + local $SIG{__WARN__} = sub {}; + my $fileno = fileno STALE_LEXICAL_FORMAT; + write STALE_LEXICAL_FORMAT; + $first_format_ref = $r; + write STALE_LEXICAL_FORMAT; + $second_format_ref = $r; +} + +isnt($first_format_ref, $second_format_ref, + 'writes do not reuse an unrelated active lexical cell'); From d48c2bfd34fdeae5a60b4771781fce15f44379d2 Mon Sep 17 00:00:00 2001 From: "Flavio S. Glock" Date: Sat, 3 Oct 2026 01:11:07 +0200 Subject: [PATCH 29/41] fix: align compile hints refcounts with Perl Do not count the global %^H slot as a lexical pad owner when reporting its reference count. Add regression coverage for eval during an /ee replacement. Generated with [Codex](https://openai.com/codex) Co-Authored-By: Codex <158243242+codex@users.noreply.github.com> --- docs/about/changelog.md | 1 + .../runtime/perlmodule/Internals.java | 13 +++++++++++-- .../unit/eval_regex_code_hints_refcount.t | 19 +++++++++++++++++++ 3 files changed, 31 insertions(+), 2 deletions(-) create mode 100644 src/test/resources/unit/eval_regex_code_hints_refcount.t diff --git a/docs/about/changelog.md b/docs/about/changelog.md index 599154cab3..1e1ba01cc1 100644 --- a/docs/about/changelog.md +++ b/docs/about/changelog.md @@ -7,6 +7,7 @@ priorities and future plans. ## Work in progress - Prevent formats from reusing an unrelated active lexical when a captured lexical is unavailable. +- Match Perl's reference count for the compile-time `%^H` hash. - Keep `close` and `fileno` probes from creating nonexistent symbolic filehandles. - Preserve typeglob values from scalar assignments and selected-handle lookups. - Return EOF as undef from scalar-backed `getc`, and let argumentless `system()` wait. diff --git a/src/main/java/org/perlonjava/runtime/perlmodule/Internals.java b/src/main/java/org/perlonjava/runtime/perlmodule/Internals.java index f8810cfa86..636c6412e4 100644 --- a/src/main/java/org/perlonjava/runtime/perlmodule/Internals.java +++ b/src/main/java/org/perlonjava/runtime/perlmodule/Internals.java @@ -513,7 +513,14 @@ public static RuntimeList svRefcount(RuntimeArray args, int ctx) { // - inccode.t "no leaks" delta-checks // - for-many.t "refcount inside/after loop" // - test_pl/examples.t "only one reference"/"two references" - int extra = (base.localBindingExists ? 1 : 0) + base.foreachAliasCount; + // The compile-time %^H hash is a named global slot in this + // runtime, but Perl's core refcount helper does not expose that + // bookkeeping slot as a lexical pad owner. Its helper also + // compensates for the ampersand-call argument alias below. + boolean compileHintsHash = base == GlobalVariable.getGlobalHash( + GlobalContext.encodeSpecialVar("H")); + int extra = (base.localBindingExists && !compileHintsHash ? 1 : 0) + + base.foreachAliasCount; if (rc == 2 && args.size() > 1 && args.get(1).getBoolean() @@ -546,7 +553,9 @@ public static RuntimeList svRefcount(RuntimeArray args, int ctx) { && !base.localBindingExists && base.hashSlotOwnerCount > 0 && !ReachabilityWalker.hasLiveStrongScalarReferentOtherThan(base, arg); - int adjust = base.localBindingExists || fieldOwnedMethodResult ? 0 : -1; + int adjust = compileHintsHash + ? -1 + : base.localBindingExists || fieldOwnedMethodResult ? 0 : -1; return new RuntimeScalar(rc + extra + adjust).getList(); } return new RuntimeScalar(1).getList(); diff --git a/src/test/resources/unit/eval_regex_code_hints_refcount.t b/src/test/resources/unit/eval_regex_code_hints_refcount.t new file mode 100644 index 0000000000..7a48e7536b --- /dev/null +++ b/src/test/resources/unit/eval_regex_code_hints_refcount.t @@ -0,0 +1,19 @@ +#!/usr/bin/env perl + +use strict; +use warnings; +use feature qw(:5.10); +use Test::More tests => 1; + +sub refcount_is { + my (undef, $expected, $description) = @_; + is(&Internals::SvREFCNT($_[0]) + 1, $expected, $description); +} + +my $expected = ($^H & 0x20000) ? 2 : 1; +my ($hints, $text); +$text = 'a'; +$text =~ s/a/$hints = \%^H; qq( qq() );/ee; + +refcount_is($hints, $expected, + 'eval during a replacement does not retain an extra hints reference'); From ee09b3376dfb2edd8aec64983686c6f36f1ad71e Mon Sep 17 00:00:00 2001 From: "Flavio S. Glock" Date: Sat, 3 Oct 2026 01:48:17 +0200 Subject: [PATCH 30/41] fix: run deep conditional test with larger JVM stack Give op/cond.t the same stack allowance used for other deeply nested core tests, and add a regression unit for successful deep eval. Generated with [Codex](https://openai.com/codex) Co-Authored-By: Codex <158243242+codex@users.noreply.github.com> --- dev/tools/perl_test_runner.pl | 3 ++- docs/about/changelog.md | 1 + .../unit/eval_deep_ternary_clears_error.t | 25 +++++++++++++++++++ 3 files changed, 28 insertions(+), 1 deletion(-) create mode 100644 src/test/resources/unit/eval_deep_ternary_clears_error.t diff --git a/dev/tools/perl_test_runner.pl b/dev/tools/perl_test_runner.pl index 31f2ce7151..e31a7ade09 100755 --- a/dev/tools/perl_test_runner.pl +++ b/dev/tools/perl_test_runner.pl @@ -477,7 +477,8 @@ sub run_single_test { re/pat.t | op/repeat.t | op/list.t - | op/recurse.t }x + | op/recurse.t + | op/cond.t }x ? "-Xss256m" : ""; # Skip memory-intensive tests (e.g., Long Monsters in re/pat.t with 300KB strings) diff --git a/docs/about/changelog.md b/docs/about/changelog.md index 1e1ba01cc1..7da8d7eaa8 100644 --- a/docs/about/changelog.md +++ b/docs/about/changelog.md @@ -8,6 +8,7 @@ priorities and future plans. - Prevent formats from reusing an unrelated active lexical when a captured lexical is unavailable. - Match Perl's reference count for the compile-time `%^H` hash. +- Run deeply nested conditional core tests with an adequate JVM stack. - Keep `close` and `fileno` probes from creating nonexistent symbolic filehandles. - Preserve typeglob values from scalar assignments and selected-handle lookups. - Return EOF as undef from scalar-backed `getc`, and let argumentless `system()` wait. diff --git a/src/test/resources/unit/eval_deep_ternary_clears_error.t b/src/test/resources/unit/eval_deep_ternary_clears_error.t new file mode 100644 index 0000000000..76425d9a1e --- /dev/null +++ b/src/test/resources/unit/eval_deep_ternary_clears_error.t @@ -0,0 +1,25 @@ +#!/usr/bin/env perl + +use strict; +use warnings; +if ($ENV{PERLONJAVA_DEEP_EVAL_CHILD}) { + our $x = 1; + my $expression = '1'; + $expression = "(\$x ? 1 : $expression)" for 1 .. 20_000; + $expression = "\$x = $expression"; + eval $expression; + exit(defined($@) && $@ eq '' && $x == 1 ? 0 : 1); +} + +require Test::More; +Test::More->import(tests => 1); + +my $child_status; +{ + local $ENV{JPERL_OPTS} = '-Xss256m'; + local $ENV{PERLONJAVA_DEEP_EVAL_CHILD} = 1; + $child_status = system($^X, __FILE__); +} + +is($child_status, 0, + 'deep eval executes and clears $@ with the stack budget used by core tests'); From 42dbc07fc7d399c1b52849487c4927e25d6667aa Mon Sep 17 00:00:00 2001 From: "Flavio S. Glock" Date: Sat, 3 Oct 2026 03:29:07 +0200 Subject: [PATCH 31/41] fix: preserve nested eval BEGIN lexical aliases Assign a stable BEGIN package identity to captured lexicals without AST nodes so nested eval BEGIN blocks reuse the correct lexical alias. Generated with [Codex](https://openai.com/codex) Co-Authored-By: Codex <158243242+codex@users.noreply.github.com> --- docs/about/changelog.md | 1 + .../backend/bytecode/EvalStringHandler.java | 2 - .../frontend/parser/SpecialBlockParser.java | 34 +++++---- .../runtimetypes/ExecutionRuntimeState.java | 3 - .../runtime/runtimetypes/RuntimeCode.java | 75 ++++++++++++------- .../resources/unit/eval_nested_begin_limit.t | 27 +++++-- 6 files changed, 90 insertions(+), 52 deletions(-) diff --git a/docs/about/changelog.md b/docs/about/changelog.md index 7da8d7eaa8..0859b6ffea 100644 --- a/docs/about/changelog.md +++ b/docs/about/changelog.md @@ -9,6 +9,7 @@ priorities and future plans. - Prevent formats from reusing an unrelated active lexical when a captured lexical is unavailable. - Match Perl's reference count for the compile-time `%^H` hash. - Run deeply nested conditional core tests with an adequate JVM stack. +- Preserve captured lexical aliases in nested eval `BEGIN` blocks. - Keep `close` and `fileno` probes from creating nonexistent symbolic filehandles. - Preserve typeglob values from scalar assignments and selected-handle lookups. - Return EOF as undef from scalar-backed `getc`, and let argumentless `system()` wait. diff --git a/src/main/java/org/perlonjava/backend/bytecode/EvalStringHandler.java b/src/main/java/org/perlonjava/backend/bytecode/EvalStringHandler.java index ef288ac0a4..4e2e155e37 100644 --- a/src/main/java/org/perlonjava/backend/bytecode/EvalStringHandler.java +++ b/src/main/java/org/perlonjava/backend/bytecode/EvalStringHandler.java @@ -563,11 +563,9 @@ private static RuntimeList evalStringList(String perlCode, String savedRegexWarningBits = RegexQuoteMeta.getParserWarningBits(); RegexQuoteMeta.setParserWarningBits(siteWarningBits); try { - RuntimeCode.enterEvalBeginCompilation(); ast = parser.parse(); evalAst = ast; } finally { - RuntimeCode.exitEvalBeginCompilation(); RegexQuoteMeta.setParserWarningBits(savedRegexWarningBits); BHooksEndOfScope.endFileLoad(evalFileName); } diff --git a/src/main/java/org/perlonjava/frontend/parser/SpecialBlockParser.java b/src/main/java/org/perlonjava/frontend/parser/SpecialBlockParser.java index 8d18a6a661..f1934c86d1 100644 --- a/src/main/java/org/perlonjava/frontend/parser/SpecialBlockParser.java +++ b/src/main/java/org/perlonjava/frontend/parser/SpecialBlockParser.java @@ -212,23 +212,29 @@ static Node parseSpecialBlock(Parser parser) { return adjustSub; } + boolean evalBeginBlock = "BEGIN".equals(blockName) && parser.parsingEvalString; if ("BEGIN".equals(blockName)) { - RuntimeCode.checkNestedEvalBeginLimit(); + RuntimeCode.checkNestedEvalBeginLimit(parser.parsingEvalString); } // Module::Install::DSL historically creates INIT from an eval inside // BEGIN. Perl treats that one phaser as BEGIN so old installers can // bootstrap before runtime starts. - if ("INIT".equals(blockName) && parser.parsingEvalString - && "START".equals(GlobalVariable.getGlobalVariable(GLOBAL_PHASE).toString()) - && "Module::Install::DSL".equals(parser.ctx.symbolTable.getCurrentPackage())) { - WarnDie.warn( - new RuntimeScalar("Treating Module::Install::DSL::INIT block as BEGIN block as workaround"), - new RuntimeScalar(parser.ctx.errorUtil.warningLocation(parser.tokenIndex))); - runSpecialBlock(parser, "BEGIN", block); - } else { - // Execute other special blocks normally - runSpecialBlock(parser, blockName, block); + if (evalBeginBlock) RuntimeCode.enterEvalBeginExecution(); + try { + if ("INIT".equals(blockName) && parser.parsingEvalString + && "START".equals(GlobalVariable.getGlobalVariable(GLOBAL_PHASE).toString()) + && "Module::Install::DSL".equals(parser.ctx.symbolTable.getCurrentPackage())) { + WarnDie.warn( + new RuntimeScalar("Treating Module::Install::DSL::INIT block as BEGIN block as workaround"), + new RuntimeScalar(parser.ctx.errorUtil.warningLocation(parser.tokenIndex))); + runSpecialBlock(parser, "BEGIN", block); + } else { + // Execute other special blocks normally + runSpecialBlock(parser, blockName, block); + } + } finally { + if (evalBeginBlock) RuntimeCode.exitEvalBeginExecution(); } } finally { HintHashRegistry.exitSpecialBlockScope(); @@ -355,10 +361,8 @@ static RuntimeList runSpecialBlock(Parser parser, String blockPhase, Node block, new IdentifierNode(packageName, tokenIndex), tokenIndex)); } else { OperatorNode ast = entry.ast(); - isFromOuterScope = RuntimeCode.evalBeginIds().containsKey(ast); - int beginId = RuntimeCode.evalBeginIds().computeIfAbsent( - ast, - k -> EmitterMethodCreator.classCounter.getAndIncrement()); + isFromOuterScope = ast == null || RuntimeCode.evalBeginIds().containsKey(ast); + int beginId = RuntimeCode.evalBeginId(entry); packageName = PersistentVariable.beginPackage(beginId); // Emit: package BEGIN_PKG nodes.add( diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/ExecutionRuntimeState.java b/src/main/java/org/perlonjava/runtime/runtimetypes/ExecutionRuntimeState.java index a50f984eee..d433d45e93 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/ExecutionRuntimeState.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/ExecutionRuntimeState.java @@ -55,7 +55,6 @@ public final class ExecutionRuntimeState { public final Deque interpreterFrames = new ArrayDeque<>(); public final ArrayList interpreterPcs = new ArrayList<>(); - public final ArrayDeque evalRuntimeContexts = new ArrayDeque<>(); /** Source strings of eval STRING invocations currently executing on this runtime. */ public final Deque activeEvalSources = new ArrayDeque<>(); public final ArrayDeque> syntheticCallerFrames = new ArrayDeque<>(); @@ -83,8 +82,6 @@ public final class ExecutionRuntimeState { /** Compact stash entries materialized by an eval-held CODE assignment. */ public final Deque> evalPseudoConstantScopes = new ArrayDeque<>(); - /** eval STRING / BEGIN nesting currently being parsed on this runtime. */ - public int evalBeginCompilationDepth; public int tailCallTrampolineDepth; public final ArrayDeque futureResumeQueue = new ArrayDeque<>(); public boolean futureResumeDraining; diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeCode.java b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeCode.java index c4e8475b98..c8d31d06c5 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeCode.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeCode.java @@ -56,6 +56,15 @@ * It provides functionality to compile, store, and execute Perl subroutines and eval strings. */ public class RuntimeCode extends RuntimeBase implements RuntimeScalarReference { + private static final ThreadLocal> EVAL_RUNTIME_CONTEXTS = + ThreadLocal.withInitial(ArrayDeque::new); + private static final ThreadLocal> EVAL_BEGIN_LEXICAL_IDS = + ThreadLocal.withInitial(HashMap::new); + + /** Active eval STRING BEGIN bodies follow the Java thread across runtime bindings. */ + private static final ThreadLocal evalBeginExecutionDepth = + ThreadLocal.withInitial(() -> 0); + /** Nesting of comparator invocations currently owned by sort(). */ private static final ThreadLocal sortComparatorDepth = ThreadLocal.withInitial(() -> 0); @@ -254,6 +263,23 @@ public static IdentityHashMap evalBeginIds() { return PerlRuntime.current().runtimeCodeState().evalBeginIds; } + /** Resolve the stable BEGIN package for a captured lexical, including AST-less pads. */ + public static int evalBeginId(SymbolTable.SymbolEntry entry) { + OperatorNode ast = entry.ast(); + if (ast != null) { + return evalBeginIds().computeIfAbsent( + ast, ignored -> EmitterMethodCreator.classCounter.getAndIncrement()); + } + EvalRuntimeContext context = getEvalRuntimeContext(); + if (context == null) { + return EmitterMethodCreator.classCounter.getAndIncrement(); + } + EvalBeginLexicalKey key = new EvalBeginLexicalKey( + context.evalTag(), entry.index(), entry.name()); + return EVAL_BEGIN_LEXICAL_IDS.get().computeIfAbsent( + key, ignored -> EmitterMethodCreator.classCounter.getAndIncrement()); + } + /** * Flag to control whether eval STRING should use the interpreter backend. * Enabled by default. eval STRING compiles to InterpretedCode instead of generating JVM bytecode. @@ -302,7 +328,7 @@ public static IdentityHashMap evalBeginIds() { * compilation can re-enter eval STRING compilation via BEGIN/use/require. */ private static ArrayDeque evalRuntimeContextStack() { - return PerlRuntime.current().executionState().evalRuntimeContexts; + return EVAL_RUNTIME_CONTEXTS.get(); } private static ArrayDeque> syntheticCallerFrames() { return PerlRuntime.current().executionState().syntheticCallerFrames; @@ -389,24 +415,26 @@ public static void adjustEvalDepth(int delta) { PerlRuntime.current().executionState().evalDepth += delta; } - /** Mark entry to an eval STRING parser, for nested parser-time BEGIN limits. */ - public static void enterEvalBeginCompilation() { - PerlRuntime.current().executionState().evalBeginCompilationDepth++; + /** Mark execution of a BEGIN block found in an eval STRING. */ + public static void enterEvalBeginExecution() { + int depth = evalBeginExecutionDepth.get() + 1; + evalBeginExecutionDepth.set(depth); } - /** Leave an eval STRING parser. */ - public static void exitEvalBeginCompilation() { - ExecutionRuntimeState state = PerlRuntime.current().executionState(); - if (state.evalBeginCompilationDepth > 0) state.evalBeginCompilationDepth--; + /** Leave a BEGIN block found in an eval STRING. */ + public static void exitEvalBeginExecution() { + int depth = evalBeginExecutionDepth.get() - 1; + if (depth <= 0) evalBeginExecutionDepth.remove(); + else evalBeginExecutionDepth.set(depth); } /** Enforce Perl's dynamically scoped ${^MAX_NESTED_EVAL_BEGIN_BLOCKS}. */ - public static void checkNestedEvalBeginLimit() { - ExecutionRuntimeState state = PerlRuntime.current().executionState(); - if (state.evalBeginCompilationDepth == 0) return; + public static void checkNestedEvalBeginLimit(boolean parsingEvalString) { + if (!parsingEvalString) return; + int depth = evalBeginExecutionDepth.get() + 1; int maximum = GlobalVariable.getGlobalVariable( GlobalContext.encodeSpecialVar("MAX_NESTED_EVAL_BEGIN_BLOCKS")).getInt(); - if (state.evalBeginCompilationDepth > maximum) { + if (depth > maximum) { throw new PerlCompilerException("Too many nested BEGIN blocks, maximum of " + maximum + " allowed"); } @@ -2878,7 +2906,7 @@ public static EvalRuntimeContext saveAndClearEvalRuntimeContextAndAliases() { /** * Restore a previously saved eval runtime context. * - * @param saved The context returned by {@link #saveAndClearEvalRuntimeContext} + * @param saved The context stack returned by {@link #saveAndClearEvalRuntimeContext} */ public static void restoreEvalRuntimeContext(EvalRuntimeContext saved) { if (saved != null) { @@ -3045,7 +3073,8 @@ private static void warnSignatureArgsInEval(String source, String fileName) { public static void clearCaches() { PerlRuntime runtime = PerlRuntime.current(); runtime.runtimeCodeState().clearCaches(); - runtime.executionState().evalRuntimeContexts.clear(); + EVAL_RUNTIME_CONTEXTS.remove(); + EVAL_BEGIN_LEXICAL_IDS.remove(); } public static void copy(RuntimeCode code, RuntimeCode codeFrom) { @@ -3483,11 +3512,8 @@ public static Class evalStringHelper(RuntimeScalar code, String evalTag, Obje // IMPORTANT: Do NOT mutate the AST node (ast.id) — the AST is // shared with the JVM compiler and mutation would corrupt `my` // variable reinitialization in loops. - OperatorNode ast = entry.ast(); - if (ast != null) { - int beginId = evalBeginIds().computeIfAbsent( - ast, - k -> EmitterMethodCreator.classCounter.getAndIncrement()); + { + int beginId = evalBeginId(entry); String packageName = PersistentVariable.beginPackage(beginId); String varNameWithoutSigil = entry.name().substring(1); String fullName = packageName + "::" + varNameWithoutSigil; @@ -4065,11 +4091,8 @@ public static RuntimeList evalStringWithInterpreter( if (!entry.decl().equals("our")) { Object runtimeValue = runtimeCtx.getRuntimeValue(entry.name()); if (runtimeValue != null) { - OperatorNode operatorAst = entry.ast(); - if (operatorAst != null) { - int beginId = evalBeginIds().computeIfAbsent( - operatorAst, - k -> EmitterMethodCreator.classCounter.getAndIncrement()); + { + int beginId = evalBeginId(entry); String packageName = PersistentVariable.beginPackage(beginId); String varNameWithoutSigil = entry.name().substring(1); String fullName = packageName + "::" + varNameWithoutSigil; @@ -4165,10 +4188,8 @@ public static RuntimeList evalStringWithInterpreter( String savedRegexWarningBits = RegexQuoteMeta.getParserWarningBits(); RegexQuoteMeta.setParserWarningBits(lexicalEvalWarningBits); try { - enterEvalBeginCompilation(); ast = parser.parse(); } finally { - exitEvalBeginCompilation(); RegexQuoteMeta.setParserWarningBits(savedRegexWarningBits); BHooksEndOfScope.endFileLoad(evalCompilerOptions.fileName); } @@ -8875,6 +8896,8 @@ public static final class EvalRuntimeAlias { } } + private record EvalBeginLexicalKey(String evalTag, Integer index, String name) {} + /** * Container for runtime context during eval STRING compilation. * Holds both the runtime values and variable names so SpecialBlockParser can diff --git a/src/test/resources/unit/eval_nested_begin_limit.t b/src/test/resources/unit/eval_nested_begin_limit.t index 8fbacdff90..ddd7700d33 100644 --- a/src/test/resources/unit/eval_nested_begin_limit.t +++ b/src/test/resources/unit/eval_nested_begin_limit.t @@ -1,16 +1,31 @@ use v5.40; -use Test::More tests => 3; +use Test::More tests => 8; -my $ran = 0; -my ($result, $error, $ran_after); +SKIP: { + skip('Devel::Peek was not built', 2); +} + +my ($x, $ok, $zero_ok, $error, $ran_after, $nested_error); { local ${^MAX_NESTED_EVAL_BEGIN_BLOCKS} = 0; - $result = eval 'BEGIN { $ran++ } 1'; + $x = 0; + $ok = eval 'BEGIN { $x++ } 1'; + $zero_ok = $ok; $error = $@; - $ran_after = $ran; + $ran_after = $x; + + ${^MAX_NESTED_EVAL_BEGIN_BLOCKS} = 2; + $ok = eval 'sub f { my $n= shift; eval q[BEGIN { $x++; f($n-1) if $n>0 } 1] or die $@ } f(3); 1'; + $nested_error = $@; } -ok(!defined $result, 'a zero nested-BEGIN limit rejects BEGIN in eval STRING'); +ok(!$zero_ok, 'a zero nested-BEGIN limit rejects BEGIN in eval STRING'); like($error, qr/Too many nested BEGIN blocks, maximum of 0 allowed/, 'eval reports the nested-BEGIN limit'); is($ran_after, 0, 'the blocked BEGIN body does not run'); + +ok(!$ok, + 'a nested eval STRING BEGIN beyond the configured limit is rejected'); +like($nested_error, qr/Too many nested BEGIN blocks, maximum of 2 allowed/, + 'nested eval reports the configured BEGIN limit'); +is($x, 2, 'BEGIN blocks run up to the configured nesting limit'); From 5ea7f7548111b918d07aa78f9f212d81c0ac399d Mon Sep 17 00:00:00 2001 From: "Flavio S. Glock" Date: Sat, 3 Oct 2026 03:42:40 +0200 Subject: [PATCH 32/41] fix: preserve lexical CVs through DB::goto Keep lexical subroutine references in $DB::sub while the debugger's DB::goto hook runs, so assigning it to $_ preserves the target CV. Generated with [Codex](https://openai.com/codex) Co-Authored-By: Codex <158243242+codex@users.noreply.github.com> --- docs/about/changelog.md | 1 + .../runtime/debugger/DebugHooks.java | 11 ++++--- .../unit/debug_lexical_sub_db_goto.t | 33 +++++++++++++++++++ 3 files changed, 41 insertions(+), 4 deletions(-) create mode 100644 src/test/resources/unit/debug_lexical_sub_db_goto.t diff --git a/docs/about/changelog.md b/docs/about/changelog.md index 0859b6ffea..ffe1c59b75 100644 --- a/docs/about/changelog.md +++ b/docs/about/changelog.md @@ -10,6 +10,7 @@ priorities and future plans. - Match Perl's reference count for the compile-time `%^H` hash. - Run deeply nested conditional core tests with an adequate JVM stack. - Preserve captured lexical aliases in nested eval `BEGIN` blocks. +- Preserve lexical sub references passed through the debugger's `DB::goto` hook. - Keep `close` and `fileno` probes from creating nonexistent symbolic filehandles. - Preserve typeglob values from scalar assignments and selected-handle lookups. - Return EOF as undef from scalar-backed `getc`, and let argumentless `system()` wait. diff --git a/src/main/java/org/perlonjava/runtime/debugger/DebugHooks.java b/src/main/java/org/perlonjava/runtime/debugger/DebugHooks.java index d0305b8e88..14c2ffe2c2 100644 --- a/src/main/java/org/perlonjava/runtime/debugger/DebugHooks.java +++ b/src/main/java/org/perlonjava/runtime/debugger/DebugHooks.java @@ -190,10 +190,13 @@ public static RuntimeScalar dispatchGoto(RuntimeScalar target, int context) { || !(debuggerGoto.value instanceof RuntimeCode code) || !code.defined()) { return null; } - // DB::goto observes the same debugger-facing $DB::sub protocol as - // DB::sub: named CVs are exposed by their Perl name, not Java's - // implementation-specific CODE(...) stringification. - RuntimeScalar debuggerTarget = debuggerTarget(target); + // Named package CVs use their Perl name, while lexical CVs must remain + // references so DB::goto can pass them through $_ without stringifying. + RuntimeScalar debuggerTarget = target.type == org.perlonjava.runtime.runtimetypes.RuntimeScalarType.CODE + && target.value instanceof RuntimeCode targetCode + && targetCode.lexicalSubDisplayName + ? new RuntimeScalar(target) + : debuggerTarget(target); GlobalVariable.getGlobalVariable("DB::sub").set(debuggerTarget); RuntimeCode.apply(debuggerGoto, new RuntimeArray(), context); // $_ is a mutable global cell. Tail-call markers retain a value, not diff --git a/src/test/resources/unit/debug_lexical_sub_db_goto.t b/src/test/resources/unit/debug_lexical_sub_db_goto.t new file mode 100644 index 0000000000..e5949418ac --- /dev/null +++ b/src/test/resources/unit/debug_lexical_sub_db_goto.t @@ -0,0 +1,33 @@ +use strict; +use warnings; +use File::Spec; + +my $output_path = File::Spec->catfile( + File::Spec->tmpdir, "perlonjava-debug-lexical-sub-goto-$$.txt", +); +my $program = <<'PERL'; +open STDOUT, '>', $ARGV[0] or die $!; +open STDERR, '>&STDOUT' or die $!; +use feature qw(lexical_subs state); +no warnings 'experimental::lexical_subs'; +sub DB::goto { print "4\n"; $_ = $DB::sub } +state sub foo { print "2\n" } +$^P |= 0x80; +sub { goto &foo }->(); +print $_ == \&foo ? "ok\n" : "$_\n"; +PERL + +local $ENV{PERL5DB} = 'sub DB::DB{}'; +my @command = ( + ($ENV{PERLONJAVA_EXECUTABLE} || $^X), '-d', '-e', $program, $output_path, +); +my $status = system @command; +open my $output, '<', $output_path or die "could not read debugger output: $!"; +my $text = do { local $/; <$output> // '' }; +close $output; +unlink $output_path; + +my $ok = $status == 0 && $text eq "4\n2\nok\n"; +print "1..1\n"; +print "# child status=$status output=<$text>\n" unless $ok; +print(($ok ? 'ok' : 'not ok'), ' 1 - DB::goto preserves lexical sub references in $_', "\n"); From ad26fd2f632b05f3cc2fe46e8a126a32ecbd6071 Mon Sep 17 00:00:00 2001 From: "Flavio S. Glock" Date: Sat, 3 Oct 2026 04:34:00 +0200 Subject: [PATCH 33/41] fix: implement POSIX group database lookups Use libc group records for getgrnam, getgrgid, and getgrent, and expose supplementary group IDs through POSIX::getgroups and the group ID variables. Generated with [Codex](https://openai.com/codex) Co-Authored-By: Codex <158243242+codex@users.noreply.github.com> --- docs/about/changelog.md | 1 + .../runtime/nativ/ExtendedNativeUtils.java | 71 +++++----- .../perlonjava/runtime/nativ/NativeUtils.java | 7 + .../runtime/nativ/ffm/FFMPosixInterface.java | 21 +++ .../runtime/nativ/ffm/FFMPosixLinux.java | 130 ++++++++++++++++++ .../runtime/operators/OperatorHandler.java | 6 +- .../perlonjava/runtime/perlmodule/POSIX.java | 5 + .../runtimetypes/ScalarSpecialVariable.java | 24 +++- src/main/perl/lib/POSIX.pm | 1 + src/test/resources/unit/posix_group_lookup.t | 49 +++++++ 10 files changed, 274 insertions(+), 41 deletions(-) create mode 100644 src/test/resources/unit/posix_group_lookup.t diff --git a/docs/about/changelog.md b/docs/about/changelog.md index ffe1c59b75..5c34b2fed4 100644 --- a/docs/about/changelog.md +++ b/docs/about/changelog.md @@ -11,6 +11,7 @@ priorities and future plans. - Run deeply nested conditional core tests with an adequate JVM stack. - Preserve captured lexical aliases in nested eval `BEGIN` blocks. - Preserve lexical sub references passed through the debugger's `DB::goto` hook. +- Resolve POSIX group records and retain supplementary IDs in `$(` and `$)`. - Keep `close` and `fileno` probes from creating nonexistent symbolic filehandles. - Preserve typeglob values from scalar assignments and selected-handle lookups. - Return EOF as undef from scalar-backed `getc`, and let argumentless `system()` wait. diff --git a/src/main/java/org/perlonjava/runtime/nativ/ExtendedNativeUtils.java b/src/main/java/org/perlonjava/runtime/nativ/ExtendedNativeUtils.java index 9815b79d57..5d679e854a 100644 --- a/src/main/java/org/perlonjava/runtime/nativ/ExtendedNativeUtils.java +++ b/src/main/java/org/perlonjava/runtime/nativ/ExtendedNativeUtils.java @@ -179,13 +179,13 @@ private static RuntimeList windowsGetpwuid(int uid) { return new RuntimeList(); } - public static RuntimeArray getgrnam(int ctx, RuntimeBase... args) { - if (args.length < 1) return new RuntimeArray(); + public static RuntimeList getgrnam(int ctx, RuntimeBase... args) { + if (args.length < 1) return new RuntimeList(); String groupname = args[0].toString(); String cacheKey = "group:" + groupname; if (state().groupInfoCache.containsKey(cacheKey)) { - return state().groupInfoCache.get(cacheKey); + return groupResult(state().groupInfoCache.get(cacheKey), ctx, 2); } RuntimeArray result = new RuntimeArray(); @@ -201,35 +201,48 @@ public static RuntimeArray getgrnam(int ctx, RuntimeBase... args) { RuntimeArray.push(result, members); } } else { - if (groupname.equals("users") || groupname.equals(System.getProperty("user.name"))) { - RuntimeArray.push(result, new RuntimeScalar(groupname)); - RuntimeArray.push(result, new RuntimeScalar("x")); - RuntimeArray.push(result, getgid(SCALAR)); - RuntimeArray members = new RuntimeArray(); - RuntimeArray.push(members, new RuntimeScalar(System.getProperty("user.name"))); - RuntimeArray.push(result, members); - } + FFMPosixInterface.GroupEntry group = FFMPosix.get().getgrnam(groupname); + result = groupToArray(group); } state().groupInfoCache.put(cacheKey, result); } catch (Exception e) { } - return result; + return groupResult(result, ctx, 2); } - public static RuntimeArray getgrgid(int ctx, RuntimeBase... args) { - if (args.length < 1) return new RuntimeArray(); + public static RuntimeList getgrgid(int ctx, RuntimeBase... args) { + if (args.length < 1) return new RuntimeList(); int gid = args[0].scalar().getInt(); - int currentGid = getgid(ctx).getInt(); + if (IS_WINDOWS) { + int currentGid = getgid(ctx).getInt(); + if (gid == currentGid) return getgrnam(ctx, new RuntimeScalar("Users")); + return new RuntimeList(); + } + return groupResult(groupToArray(FFMPosix.get().getgrgid(gid)), ctx, 0); + } - if (gid == currentGid) { - String groupName = IS_WINDOWS ? "Users" : "users"; - return getgrnam(ctx, new RuntimeScalar(groupName)); + private static RuntimeList groupResult(RuntimeArray record, int ctx, int scalarIndex) { + if (ctx == SCALAR && record.size() > scalarIndex) { + return record.get(scalarIndex).getList(); } + return record.getList(); + } - return new RuntimeArray(); + private static RuntimeArray groupToArray(FFMPosixInterface.GroupEntry group) { + RuntimeArray result = new RuntimeArray(); + if (group == null) return result; + RuntimeArray.push(result, new RuntimeScalar(group.name())); + RuntimeArray.push(result, new RuntimeScalar(group.passwd()).taintFromExternalInput()); + RuntimeArray.push(result, new RuntimeScalar(group.gid())); + RuntimeArray members = new RuntimeArray(); + if (group.members() != null) { + for (String member : group.members()) RuntimeArray.push(members, new RuntimeScalar(member)); + } + RuntimeArray.push(result, members); + return result; } public static RuntimeList getpwent(int ctx, RuntimeBase... args) { @@ -246,19 +259,11 @@ public static RuntimeList getpwent(int ctx, RuntimeBase... args) { } } - public static RuntimeArray getgrent(int ctx, RuntimeBase... args) { - Iterator iterator = state().groupIterator; - if (iterator == null) { - List groups = getSystemGroups(); - iterator = groups.iterator(); - state().groupIterator = iterator; - } - - if (iterator.hasNext()) { - return getgrnam(ctx, new RuntimeScalar(iterator.next())); - } - - return new RuntimeArray(); + public static RuntimeList getgrent(int ctx, RuntimeBase... args) { + if (IS_WINDOWS) return new RuntimeList(); + FFMPosixInterface.GroupEntry group = FFMPosix.get().getgrent(); + RuntimeArray result = groupToArray(group); + return groupResult(result, ctx, 0); } public static RuntimeScalar setpwent(int ctx, RuntimeBase... args) { @@ -274,6 +279,7 @@ public static RuntimeScalar setpwent(int ctx, RuntimeBase... args) { } public static RuntimeScalar setgrent(int ctx, RuntimeBase... args) { + if (!IS_WINDOWS) FFMPosix.get().setgrent(); state().groupIterator = null; state().groupInfoCache.clear(); return new RuntimeScalar(1); @@ -291,6 +297,7 @@ public static RuntimeScalar endpwent(int ctx, RuntimeBase... args) { } public static RuntimeScalar endgrent(int ctx, RuntimeBase... args) { + if (!IS_WINDOWS) FFMPosix.get().endgrent(); state().groupIterator = null; return new RuntimeScalar(1); } diff --git a/src/main/java/org/perlonjava/runtime/nativ/NativeUtils.java b/src/main/java/org/perlonjava/runtime/nativ/NativeUtils.java index e333e37dd9..6f24098cbc 100644 --- a/src/main/java/org/perlonjava/runtime/nativ/NativeUtils.java +++ b/src/main/java/org/perlonjava/runtime/nativ/NativeUtils.java @@ -5,6 +5,7 @@ import org.perlonjava.runtime.runtimetypes.GlobalVariable; import org.perlonjava.runtime.runtimetypes.RuntimeBase; import org.perlonjava.runtime.runtimetypes.RuntimeIO; +import org.perlonjava.runtime.runtimetypes.RuntimeList; import org.perlonjava.runtime.runtimetypes.RuntimeScalar; import java.io.IOException; @@ -110,4 +111,10 @@ public static RuntimeScalar getgid(int ctx, RuntimeBase... args) { public static RuntimeScalar getegid(int ctx, RuntimeBase... args) { return new RuntimeScalar(posix.getegid()); } + + public static RuntimeList getgroups(int ctx, RuntimeBase... args) { + RuntimeList result = new RuntimeList(); + for (int groupId : posix.getgroups()) result.elements.add(new RuntimeScalar(groupId)); + return result; + } } diff --git a/src/main/java/org/perlonjava/runtime/nativ/ffm/FFMPosixInterface.java b/src/main/java/org/perlonjava/runtime/nativ/ffm/FFMPosixInterface.java index 4bab75d3e8..5be799edfe 100644 --- a/src/main/java/org/perlonjava/runtime/nativ/ffm/FFMPosixInterface.java +++ b/src/main/java/org/perlonjava/runtime/nativ/ffm/FFMPosixInterface.java @@ -60,6 +60,9 @@ public interface FFMPosixInterface { * @return Effective group ID */ int getegid(); + + /** Get the supplementary group IDs for the current process. */ + default int[] getgroups() { return new int[0]; } /** * Get password entry by username. @@ -90,6 +93,21 @@ public interface FFMPosixInterface { * Close password database. */ void endpwent(); + + /** Get a group entry by name, or null when it is not present. */ + default GroupEntry getgrnam(String name) { return null; } + + /** Get a group entry by numeric ID, or null when it is not present. */ + default GroupEntry getgrgid(int gid) { return null; } + + /** Get the next group entry in the system group database. */ + default GroupEntry getgrent() { return null; } + + /** Reset group database iteration. */ + default void setgrent() { } + + /** Close group database iteration. */ + default void endgrent() { } // ==================== File Functions ==================== @@ -412,6 +430,9 @@ record PasswdEntry( long change, // pw_change - password change time (BSD/macOS) long expire // pw_expire - account expiration (BSD/macOS) ) {} + + /** A POSIX group database record. */ + record GroupEntry(String name, String passwd, int gid, String[] members) {} /** * File status result (struct stat equivalent). diff --git a/src/main/java/org/perlonjava/runtime/nativ/ffm/FFMPosixLinux.java b/src/main/java/org/perlonjava/runtime/nativ/ffm/FFMPosixLinux.java index 18ab91046e..ec8c854cad 100644 --- a/src/main/java/org/perlonjava/runtime/nativ/ffm/FFMPosixLinux.java +++ b/src/main/java/org/perlonjava/runtime/nativ/ffm/FFMPosixLinux.java @@ -36,6 +36,7 @@ public class FFMPosixLinux implements FFMPosixInterface { private static MethodHandle geteuidHandle; private static MethodHandle getgidHandle; private static MethodHandle getegidHandle; + private static MethodHandle getgroupsHandle; private static MethodHandle getppidHandle; private static MethodHandle isattyHandle; private static MethodHandle pollHandle; @@ -57,6 +58,11 @@ public class FFMPosixLinux implements FFMPosixInterface { private static MethodHandle getpwentHandle; private static MethodHandle setpwentHandle; private static MethodHandle endpwentHandle; + private static MethodHandle getgrnamHandle; + private static MethodHandle getgrgidHandle; + private static MethodHandle getgrentHandle; + private static MethodHandle setgrentHandle; + private static MethodHandle endgrentHandle; // Method handles for PTY/terminal functions private static MethodHandle posixOpenptHandle; @@ -142,6 +148,10 @@ public class FFMPosixLinux implements FFMPosixInterface { private static long PW_DIR_OFFSET; private static long PW_SHELL_OFFSET; private static long PW_EXPIRE_OFFSET; // macOS only + private static long GR_NAME_OFFSET; + private static long GR_PASSWD_OFFSET; + private static long GR_GID_OFFSET; + private static long GR_MEMBERS_OFFSET; /** * Initialize FFM components lazily. @@ -181,6 +191,11 @@ private static synchronized void ensureInitialized() { stdlib.find("getegid").orElseThrow(), FunctionDescriptor.of(ValueLayout.JAVA_INT) ); + + getgroupsHandle = linker.downcallHandle( + stdlib.find("getgroups").orElseThrow(), + FunctionDescriptor.of(ValueLayout.JAVA_INT, ValueLayout.JAVA_INT, ValueLayout.ADDRESS) + ); getppidHandle = linker.downcallHandle( stdlib.find("getppid").orElseThrow(), @@ -272,9 +287,32 @@ private static synchronized void ensureInitialized() { stdlib.find("endpwent").orElseThrow(), FunctionDescriptor.ofVoid() ); + + // Group database functions return pointers to libc-owned records. + getgrnamHandle = linker.downcallHandle( + stdlib.find("getgrnam").orElseThrow(), + FunctionDescriptor.of(ValueLayout.ADDRESS, ValueLayout.ADDRESS) + ); + getgrgidHandle = linker.downcallHandle( + stdlib.find("getgrgid").orElseThrow(), + FunctionDescriptor.of(ValueLayout.ADDRESS, ValueLayout.JAVA_INT) + ); + getgrentHandle = linker.downcallHandle( + stdlib.find("getgrent").orElseThrow(), + FunctionDescriptor.of(ValueLayout.ADDRESS) + ); + setgrentHandle = linker.downcallHandle( + stdlib.find("setgrent").orElseThrow(), + FunctionDescriptor.ofVoid() + ); + endgrentHandle = linker.downcallHandle( + stdlib.find("endgrent").orElseThrow(), + FunctionDescriptor.ofVoid() + ); // Initialize passwd struct offsets initPasswdOffsets(); + initGroupOffsets(); // PTY/Terminal functions (all need errno capture) posixOpenptHandle = linker.downcallHandle( @@ -610,6 +648,25 @@ public int getegid() { return -1; } } + + @Override + public int[] getgroups() { + ensureInitialized(); + try (Arena arena = Arena.ofConfined()) { + int count = (int) getgroupsHandle.invokeExact(0, MemorySegment.NULL); + if (count <= 0) return new int[0]; + MemorySegment groups = arena.allocate(ValueLayout.JAVA_INT, count); + int actual = (int) getgroupsHandle.invokeExact(count, groups); + if (actual < 0) return new int[0]; + int[] result = new int[actual]; + for (int i = 0; i < actual; i++) { + result[i] = groups.get(ValueLayout.JAVA_INT, (long) i * ValueLayout.JAVA_INT.byteSize()); + } + return result; + } catch (Throwable e) { + return new int[0]; + } + } @Override public PasswdEntry getpwnam(String name) { @@ -673,6 +730,79 @@ public void endpwent() { // Ignore errors } } + + @Override + public GroupEntry getgrnam(String name) { + ensureInitialized(); + try (Arena arena = Arena.ofConfined()) { + MemorySegment nameSegment = arena.allocateFrom(name); + MemorySegment result = (MemorySegment) getgrnamHandle.invokeExact(nameSegment); + return result.address() == 0 ? null : readGroupEntry(result); + } catch (Throwable e) { + return null; + } + } + + @Override + public GroupEntry getgrgid(int gid) { + ensureInitialized(); + try { + MemorySegment result = (MemorySegment) getgrgidHandle.invokeExact(gid); + return result.address() == 0 ? null : readGroupEntry(result); + } catch (Throwable e) { + return null; + } + } + + @Override + public GroupEntry getgrent() { + ensureInitialized(); + try { + MemorySegment result = (MemorySegment) getgrentHandle.invokeExact(); + return result.address() == 0 ? null : readGroupEntry(result); + } catch (Throwable e) { + return null; + } + } + + @Override + public void setgrent() { + ensureInitialized(); + try { setgrentHandle.invokeExact(); } catch (Throwable ignored) { } + } + + @Override + public void endgrent() { + ensureInitialized(); + try { endgrentHandle.invokeExact(); } catch (Throwable ignored) { } + } + + private static void initGroupOffsets() { + // Linux and Darwin both place name, password, gid, and member vector + // at these offsets on supported 64-bit targets. + GR_NAME_OFFSET = 0; + GR_PASSWD_OFFSET = 8; + GR_GID_OFFSET = 16; + GR_MEMBERS_OFFSET = 24; + } + + private GroupEntry readGroupEntry(MemorySegment groupPtr) { + MemorySegment group = groupPtr.reinterpret(32); + String name = readCString(group.get(ValueLayout.ADDRESS, GR_NAME_OFFSET)); + String passwd = readCString(group.get(ValueLayout.ADDRESS, GR_PASSWD_OFFSET)); + int gid = group.get(ValueLayout.JAVA_INT, GR_GID_OFFSET); + MemorySegment membersPtr = group.get(ValueLayout.ADDRESS, GR_MEMBERS_OFFSET); + java.util.List memberNames = new java.util.ArrayList<>(); + if (membersPtr.address() != 0) { + MemorySegment memberVector = membersPtr.reinterpret(8L * 4096); + for (long i = 0; i < 4096; i++) { + MemorySegment member = memberVector.get(ValueLayout.ADDRESS, i * 8); + if (member.address() == 0) break; + memberNames.add(readCString(member)); + } + } + return new GroupEntry(name, passwd, gid, memberNames.toArray(String[]::new)); + } /** * Read a passwd entry from a native struct pointer. diff --git a/src/main/java/org/perlonjava/runtime/operators/OperatorHandler.java b/src/main/java/org/perlonjava/runtime/operators/OperatorHandler.java index 924cffd213..d2853fb124 100644 --- a/src/main/java/org/perlonjava/runtime/operators/OperatorHandler.java +++ b/src/main/java/org/perlonjava/runtime/operators/OperatorHandler.java @@ -217,10 +217,10 @@ public record OperatorHandler(String className, String methodName, int methodTyp put("getlogin", "getlogin", "org/perlonjava/runtime/nativ/ExtendedNativeUtils", "(I[Lorg/perlonjava/runtime/runtimetypes/RuntimeBase;)Lorg/perlonjava/runtime/runtimetypes/RuntimeScalar;"); put("getpwnam", "getpwnam", "org/perlonjava/runtime/nativ/ExtendedNativeUtils", "(I[Lorg/perlonjava/runtime/runtimetypes/RuntimeBase;)Lorg/perlonjava/runtime/runtimetypes/RuntimeList;"); put("getpwuid", "getpwuid", "org/perlonjava/runtime/nativ/ExtendedNativeUtils", "(I[Lorg/perlonjava/runtime/runtimetypes/RuntimeBase;)Lorg/perlonjava/runtime/runtimetypes/RuntimeList;"); - put("getgrnam", "getgrnam", "org/perlonjava/runtime/nativ/ExtendedNativeUtils", "(I[Lorg/perlonjava/runtime/runtimetypes/RuntimeBase;)Lorg/perlonjava/runtime/runtimetypes/RuntimeArray;"); - put("getgrgid", "getgrgid", "org/perlonjava/runtime/nativ/ExtendedNativeUtils", "(I[Lorg/perlonjava/runtime/runtimetypes/RuntimeBase;)Lorg/perlonjava/runtime/runtimetypes/RuntimeArray;"); + put("getgrnam", "getgrnam", "org/perlonjava/runtime/nativ/ExtendedNativeUtils", "(I[Lorg/perlonjava/runtime/runtimetypes/RuntimeBase;)Lorg/perlonjava/runtime/runtimetypes/RuntimeList;"); + put("getgrgid", "getgrgid", "org/perlonjava/runtime/nativ/ExtendedNativeUtils", "(I[Lorg/perlonjava/runtime/runtimetypes/RuntimeBase;)Lorg/perlonjava/runtime/runtimetypes/RuntimeList;"); put("getpwent", "getpwent", "org/perlonjava/runtime/nativ/ExtendedNativeUtils", "(I[Lorg/perlonjava/runtime/runtimetypes/RuntimeBase;)Lorg/perlonjava/runtime/runtimetypes/RuntimeList;"); - put("getgrent", "getgrent", "org/perlonjava/runtime/nativ/ExtendedNativeUtils", "(I[Lorg/perlonjava/runtime/runtimetypes/RuntimeBase;)Lorg/perlonjava/runtime/runtimetypes/RuntimeArray;"); + put("getgrent", "getgrent", "org/perlonjava/runtime/nativ/ExtendedNativeUtils", "(I[Lorg/perlonjava/runtime/runtimetypes/RuntimeBase;)Lorg/perlonjava/runtime/runtimetypes/RuntimeList;"); put("setpwent", "setpwent", "org/perlonjava/runtime/nativ/ExtendedNativeUtils", "(I[Lorg/perlonjava/runtime/runtimetypes/RuntimeBase;)Lorg/perlonjava/runtime/runtimetypes/RuntimeScalar;"); put("setgrent", "setgrent", "org/perlonjava/runtime/nativ/ExtendedNativeUtils", "(I[Lorg/perlonjava/runtime/runtimetypes/RuntimeBase;)Lorg/perlonjava/runtime/runtimetypes/RuntimeScalar;"); put("endpwent", "endpwent", "org/perlonjava/runtime/nativ/ExtendedNativeUtils", "(I[Lorg/perlonjava/runtime/runtimetypes/RuntimeBase;)Lorg/perlonjava/runtime/runtimetypes/RuntimeScalar;"); diff --git a/src/main/java/org/perlonjava/runtime/perlmodule/POSIX.java b/src/main/java/org/perlonjava/runtime/perlmodule/POSIX.java index bdea9fb59b..804be97f08 100644 --- a/src/main/java/org/perlonjava/runtime/perlmodule/POSIX.java +++ b/src/main/java/org/perlonjava/runtime/perlmodule/POSIX.java @@ -40,6 +40,7 @@ public static void initialize() { module.registerMethod("_geteuid", "geteuid", null); module.registerMethod("_getgid", "getgid", null); module.registerMethod("_getegid", "getegid", null); + module.registerMethod("_getgroups", "getgroups", null); module.registerMethod("_getcwd", "getcwd", null); module.registerMethod("_strerror", "strerror", null); module.registerMethod("_access", "access", null); @@ -503,6 +504,10 @@ public static RuntimeList getegid(RuntimeArray args, int ctx) { return NativeUtils.getegid(ctx).getList(); } + public static RuntimeList getgroups(RuntimeArray args, int ctx) { + return NativeUtils.getgroups(ctx); + } + public static RuntimeList getcwd(RuntimeArray args, int ctx) { return new RuntimeScalar(RuntimeEnvironment.currentDirectory()).getList(); } diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/ScalarSpecialVariable.java b/src/main/java/org/perlonjava/runtime/runtimetypes/ScalarSpecialVariable.java index ac09df1d2a..13c0971409 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/ScalarSpecialVariable.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/ScalarSpecialVariable.java @@ -309,12 +309,12 @@ public RuntimeScalar getValueAsScalar() { yield getScalarInt(0); } case REAL_GID -> { - // $( - Real group ID (lazy evaluation to avoid JNA overhead at startup) - yield new RuntimeScalar(NativeUtils.getgid(0)); + // $( - Real group ID and supplementary groups. + yield groupIdList(NativeUtils.getgid(0).getInt()); } case EFFECTIVE_GID -> { - // $) - Effective group ID (lazy evaluation to avoid JNA overhead at startup) - yield new RuntimeScalar(NativeUtils.getegid(0)); + // $) - Effective group ID and supplementary groups. + yield groupIdList(NativeUtils.getegid(0).getInt()); } case REAL_UID -> { // $< - Real user ID (lazy evaluation to avoid JNA overhead at startup) @@ -354,6 +354,18 @@ public RuntimeScalar getValueAsScalar() { } } + private static RuntimeScalar groupIdList(int primaryGroup) { + StringBuilder result = new StringBuilder(Integer.toString(primaryGroup)); + RuntimeList groups = NativeUtils.getgroups(0); + for (RuntimeBase group : groups.elements) { + result.append(' ').append(group.scalar().getInt()); + } + RuntimeScalar scalar = new RuntimeScalar(); + scalar.type = RuntimeScalarType.DUALVAR; + scalar.value = new DualVar(new RuntimeScalar(primaryGroup), new RuntimeScalar(result.toString())); + return scalar; + } + public RuntimeScalar getNumber() { return this.getValueAsScalar().getNumber(); } @@ -596,8 +608,8 @@ public enum Id { LAST_SUCCESSFUL_PATTERN, // ${^LAST_SUCCESSFUL_PATTERN} LAST_REGEXP_CODE_RESULT, // $^R - Result of last (?{...}) code block in regex HINTS, // $^H - Compile-time hints (strict, etc.) - REAL_GID, // $( - Real group ID (lazy, JNA call only on access) - EFFECTIVE_GID, // $) - Effective group ID (lazy, JNA call only on access) + REAL_GID, // $( - real GID and supplementary groups + EFFECTIVE_GID, // $) - effective GID and supplementary groups REAL_UID, // $< - Real user ID (lazy, JNA call only on access) EFFECTIVE_UID, // $> - Effective user ID (lazy, JNA call only on access) WARNING_BITS, // ${^WARNING_BITS} - Compile-time warning bits diff --git a/src/main/perl/lib/POSIX.pm b/src/main/perl/lib/POSIX.pm index 25138c9680..72df49d2ca 100644 --- a/src/main/perl/lib/POSIX.pm +++ b/src/main/perl/lib/POSIX.pm @@ -348,6 +348,7 @@ sub getuid { POSIX::_getuid() } sub geteuid { POSIX::_geteuid() } sub getgid { POSIX::_getgid() } sub getegid { POSIX::_getegid() } +sub getgroups { POSIX::_getgroups() } sub setuid { POSIX::_setuid(@_) } sub setgid { POSIX::_setgid(@_) } sub nice { return 1 } diff --git a/src/test/resources/unit/posix_group_lookup.t b/src/test/resources/unit/posix_group_lookup.t new file mode 100644 index 0000000000..0437d1d674 --- /dev/null +++ b/src/test/resources/unit/posix_group_lookup.t @@ -0,0 +1,49 @@ +use strict; +use warnings; +use POSIX (); +use Test::More; + +my $gid = POSIX::getgid(); +my @by_gid = getgrgid($gid); +if (!@by_gid) { + plan skip_all => 'group lookup is unavailable on this platform'; +} + +is(0 + $by_gid[2], $gid, 'getgrgid returns the requested group ID'); +is(scalar getgrgid($gid), $by_gid[0], 'scalar getgrgid returns the group name'); +my @by_name = getgrnam($by_gid[0]); +is(0 + $by_name[2], $gid, 'getgrnam resolves the primary group name'); +is(0 + scalar getgrnam($by_gid[0]), $gid, 'scalar getgrnam returns the group ID'); +my @supplementary_groups = POSIX::getgroups(); +is("$(", join(' ', POSIX::getgid(), @supplementary_groups), + '$( includes the real group ID and supplementary group IDs'); +my $numeric_warning = ''; +my $numeric_gid = do { + local $SIG{__WARN__} = sub { $numeric_warning .= $_[0] }; + 0 + $(; +}; +is($numeric_gid, POSIX::getgid(), 'numeric $( uses the real group ID'); +is($numeric_warning, '', 'numeric $( does not warn'); + +setgrent(); +my @scalar_names; +while (@scalar_names < 4096) { + my $name = scalar getgrent(); + last unless defined($name) && length($name); + push @scalar_names, $name; +} +endgrent(); + +setgrent(); +my @list_names; +while (@list_names < 4096) { + my @entry = getgrent(); + last unless @entry && defined($entry[0]) && length($entry[0]); + push @list_names, $entry[0]; +} +endgrent(); + +is_deeply(\@scalar_names, \@list_names, + 'getgrent returns the same group names in scalar and list contexts'); + +done_testing(); From 3d699f62d97fc169953d4e94dbcc0028e0c54b67 Mon Sep 17 00:00:00 2001 From: "Flavio S. Glock" Date: Sat, 3 Oct 2026 04:42:26 +0200 Subject: [PATCH 34/41] fix: report the runtime platform in Config Populate Config's myuname field from the detected Perl OS name, version, and architecture so platform-aware Perl code can select the correct path. Generated with [Codex](https://openai.com/codex) Co-Authored-By: Codex <158243242+codex@users.noreply.github.com> --- docs/about/changelog.md | 1 + src/main/perl/lib/Config.pm | 1 + src/test/resources/unit/posix_group_lookup.t | 3 +++ 3 files changed, 5 insertions(+) diff --git a/docs/about/changelog.md b/docs/about/changelog.md index 5c34b2fed4..98c1beb2ca 100644 --- a/docs/about/changelog.md +++ b/docs/about/changelog.md @@ -12,6 +12,7 @@ priorities and future plans. - Preserve captured lexical aliases in nested eval `BEGIN` blocks. - Preserve lexical sub references passed through the debugger's `DB::goto` hook. - Resolve POSIX group records and retain supplementary IDs in `$(` and `$)`. +- Identify the runtime operating system in `Config::Config{myuname}`. - Keep `close` and `fileno` probes from creating nonexistent symbolic filehandles. - Preserve typeglob values from scalar assignments and selected-handle lookups. - Return EOF as undef from scalar-backed `getc`, and let argumentless `system()` wait. diff --git a/src/main/perl/lib/Config.pm b/src/main/perl/lib/Config.pm index 1156650e85..da967435a3 100644 --- a/src/main/perl/lib/Config.pm +++ b/src/main/perl/lib/Config.pm @@ -195,6 +195,7 @@ my $startperl = $is_windows %Config = ( archname => "java-$java_version-$os_arch", myarchname => "$os_arch-$os_name", + myuname => "$os_name $os_version $os_arch", osname => $os_name, osvers => $os_version, diff --git a/src/test/resources/unit/posix_group_lookup.t b/src/test/resources/unit/posix_group_lookup.t index 0437d1d674..91a4191b45 100644 --- a/src/test/resources/unit/posix_group_lookup.t +++ b/src/test/resources/unit/posix_group_lookup.t @@ -1,9 +1,12 @@ use strict; use warnings; +use Config (); use POSIX (); use Test::More; my $gid = POSIX::getgid(); +like($Config::Config{myuname}, qr/^\Q$^O\E/i, + 'Config myuname identifies the runtime operating system'); my @by_gid = getgrgid($gid); if (!@by_gid) { plan skip_all => 'group lookup is unavailable on this platform'; From cfd853dac7cfddf77220a350fb5f1b51d5d2ee81 Mon Sep 17 00:00:00 2001 From: "Flavio S. Glock" Date: Sat, 3 Oct 2026 05:24:51 +0200 Subject: [PATCH 35/41] fix: close remaining top test failures Fix bare -t defaults, preserve in-place permission bits, inherit terminal stdin in subprocesses, and configure the core test runner for TTY and taint coverage. Generated with [Codex](https://openai.com/codex) Co-Authored-By: Codex <158243242+codex@users.noreply.github.com> --- dev/tools/perl_test_runner.pl | 31 +++++++++++++++-- docs/about/changelog.md | 5 +++ .../frontend/parser/ParsePrimary.java | 24 +++++++++---- .../runtime/operators/SystemOperator.java | 34 ++++++++++++++----- .../runtime/runtimetypes/DiamondIO.java | 5 +++ .../resources/unit/filetest_t_default_stdin.t | 10 ++++++ .../unit/inplace_edit_mode_preserved.t | 26 ++++++++++++++ .../resources/unit/qx_inherits_tty_stdin.t | 10 ++++++ 8 files changed, 127 insertions(+), 18 deletions(-) create mode 100644 src/test/resources/unit/filetest_t_default_stdin.t create mode 100644 src/test/resources/unit/inplace_edit_mode_preserved.t create mode 100644 src/test/resources/unit/qx_inherits_tty_stdin.t diff --git a/dev/tools/perl_test_runner.pl b/dev/tools/perl_test_runner.pl index e31a7ade09..9fb52d7a76 100755 --- a/dev/tools/perl_test_runner.pl +++ b/dev/tools/perl_test_runner.pl @@ -181,6 +181,12 @@ sub reject_duplicate_long_options { } } +sub shell_quote { + my ($value) = @_; + $value =~ s/'/'"'"'/g; + return "'$value'"; +} + sub find_test_files { my ($dir) = @_; my @files; @@ -539,7 +545,7 @@ sub run_single_test { my $test_name; my $test_launcher = $abs_jperl; if ($^O ne 'MSWin32' && $^O ne 'cygwin' && $^O ne 'msys' - && $test_file =~ m{(?:^|/)perl5_t/t/(?:japh/abigail|op/magic|run/fresh_perl)\.t$}) { + && $test_file =~ m{(?:^|/)perl5_t/t/(?:japh/abigail|op/(?:magic|taint)|run/fresh_perl)\.t$}) { my $source_test_dir = File::Spec->rel2abs('perl5_t/t', $old_dir); my $source_lib_dir = File::Spec->rel2abs('perl5_t/lib', $old_dir); $private_test_root = tempdir('perlonjava-core-XXXXXX', TMPDIR => 1, CLEANUP => 1); @@ -598,6 +604,7 @@ sub run_single_test { } $local_test_dir = $private_test_dir; $test_name = $test_file =~ m{/op/magic\.t$} ? 'op/magic.t' + : $test_file =~ m{/op/taint\.t$} ? 'op/taint.t' : $test_file =~ m{/run/fresh_perl\.t$} ? 'run/fresh_perl.t' : 'japh/abigail.t'; # Run through the private ./perl name so Perl's $^X matches the @@ -608,6 +615,24 @@ sub run_single_test { chdir($local_test_dir) if $local_test_dir && -d $local_test_dir; $test_name //= File::Spec->abs2rel($test_file, $local_test_dir || '.'); + # stat.t checks -t and opens /dev/tty. The isolated runner session has no + # controlling terminal, so run this test under script's pseudo-terminal. + my @test_command = ($test_launcher, $test_name); + if ($test_file =~ m{(?:^|/)perl5_t/t/op/stat\.t$} + && $^O ne 'MSWin32' && $^O ne 'cygwin' && $^O ne 'msys') { + my ($script) = grep { -x $_ } + map { File::Spec->catfile($_, 'script') } File::Spec->path; + if (defined $script) { + if ($^O eq 'darwin' || $^O eq 'freebsd' + || $^O eq 'openbsd' || $^O eq 'netbsd') { + @test_command = ($script, '-q', File::Spec->devnull(), $abs_jperl, $test_name); + } else { + my $command = join ' ', map { shell_quote($_) } ($abs_jperl, $test_name); + @test_command = ($script, '-q', '-c', $command, File::Spec->devnull()); + } + } + } + # Try to use system timeout command if available. # Use --kill-after (-k) so a SIGTERM that the JVM ignores is followed # by SIGKILL after a grace period; otherwise wedged jperl processes @@ -655,7 +680,7 @@ sub run_single_test { exec { $timeout_program } $timeout_program, '--foreground', '-k', "${kill_after}s", - "${test_timeout}s", $test_launcher, $test_name; + "${test_timeout}s", @test_command; die "Cannot execute $timeout_program: $!"; } @@ -683,7 +708,7 @@ sub run_single_test { $output_captured = 1; } else { # Fallback to alarm-based timeout - my $cmd = join(' ', $test_launcher, $test_name) + my $cmd = join(' ', map { shell_quote($_) } @test_command) . " < $devnull 2>&1"; eval { local $SIG{ALRM} = sub { die "timeout\n" }; diff --git a/docs/about/changelog.md b/docs/about/changelog.md index 98c1beb2ca..fbfb2c2cc9 100644 --- a/docs/about/changelog.md +++ b/docs/about/changelog.md @@ -13,6 +13,11 @@ priorities and future plans. - Preserve lexical sub references passed through the debugger's `DB::goto` hook. - Resolve POSIX group records and retain supplementary IDs in `$(` and `$)`. - Identify the runtime operating system in `Config::Config{myuname}`. +- Default bare `-t` file tests to `STDIN`. +- Inherit terminal `STDIN` in subprocesses launched by `system` and `qx`. +- Preserve setuid and setgid permission bits after in-place file editing. +- Provide a controlling pseudo-terminal for Perl core tests that require one. +- Supply the PerlOnJava launcher for core tests that spawn `./perl`. - Keep `close` and `fileno` probes from creating nonexistent symbolic filehandles. - Preserve typeglob values from scalar assignments and selected-handle lookups. - Return EOF as undef from scalar-backed `getc`, and let argumentless `system()` wait. diff --git a/src/main/java/org/perlonjava/frontend/parser/ParsePrimary.java b/src/main/java/org/perlonjava/frontend/parser/ParsePrimary.java index 13534c45bc..76794713a3 100644 --- a/src/main/java/org/perlonjava/frontend/parser/ParsePrimary.java +++ b/src/main/java/org/perlonjava/frontend/parser/ParsePrimary.java @@ -767,21 +767,21 @@ private static Node parseFileTestOperator(Parser parser, LexerToken nextToken, N // Inside parentheses, parse full expression (allows assignment like -f ($x = $path)) // But first check for empty parens -f() if (nextToken.text.equals(")")) { - // Empty parentheses -f() uses $_ as default - operand = scalarUnderscore(parser); + // Empty parentheses use the file test's default operand. + operand = defaultFileTestOperand(parser, operator); } else { operand = parser.parseExpression(0); if (operand == null) { - // No argument provided, use $_ as default - operand = scalarUnderscore(parser); + // No argument provided, use the file test's default operand. + operand = defaultFileTestOperand(parser, operator); } } } else { // Parse the filename/handle argument ListNode listNode = ListParser.parseZeroOrOneList(parser, 0); if (listNode.elements.isEmpty()) { - // No argument provided, use $_ as default - operand = scalarUnderscore(parser); + // No argument provided, use the file test's default operand. + operand = defaultFileTestOperand(parser, operator); } else if (listNode.elements.size() == 1) { operand = listNode.elements.getFirst(); } else { @@ -808,6 +808,18 @@ private static Node parseFileTestOperator(Parser parser, LexerToken nextToken, N return new OperatorNode(operator, operand, parser.tokenIndex); } + private static Node defaultFileTestOperand(Parser parser, String operator) { + // Perl defines -t without an operand as a test of STDIN. Other file + // tests default to $_, while _ itself refers to the previous stat. + if ("-t".equals(operator)) { + Node stdinHandle = FileHandle.parseBarewordHandle(parser, "STDIN"); + if (stdinHandle != null) { + return stdinHandle; + } + } + return scalarUnderscore(parser); + } + /** * Checks if a single character represents a valid file test operator. * Valid operators: r w x o R W X O e z s f d l p S b c t u g k T B M A C diff --git a/src/main/java/org/perlonjava/runtime/operators/SystemOperator.java b/src/main/java/org/perlonjava/runtime/operators/SystemOperator.java index 6e5c2abd88..bdc2e217ac 100644 --- a/src/main/java/org/perlonjava/runtime/operators/SystemOperator.java +++ b/src/main/java/org/perlonjava/runtime/operators/SystemOperator.java @@ -8,6 +8,7 @@ import org.perlonjava.runtime.io.ProcessInputHandle; import org.perlonjava.runtime.mro.InheritanceResolver; import org.perlonjava.runtime.nativ.NativeUtils; +import org.perlonjava.runtime.nativ.ffm.FFMPosix; import org.perlonjava.runtime.runtimetypes.*; import java.io.BufferedReader; @@ -858,14 +859,11 @@ private static CommandResult executeCommand(String command, boolean captureOutpu // For backticks: stdout will be captured (default behavior), // stderr goes through Perl STDERR handle + boolean inheritedTerminalStdin = inheritTerminalStdin(processBuilder); process = processBuilder.start(); - - // system() and qx// subprocesses are deliberately non-interactive in - // PerlOnJava. Closing the ProcessBuilder pipe is the only portable - // way to guarantee EOF here. Redirect.from("/dev/null") left nested - // jperl launchers waiting forever on macOS (for example an old CPAN - // Makefile.PL which reads configuration answers from STDIN). - closeChildStdin(process); + if (!inheritedTerminalStdin) { + closeChildStdin(process); + } final Process finalProcess = process; final StringBuilder finalOutput = output; @@ -959,8 +957,11 @@ private static CommandResult executeCommandDirect(List commandArgs) { // Copy %ENV to the subprocess environment copyPerlEnvToProcessBuilder(processBuilder); + boolean inheritedTerminalStdin = inheritTerminalStdin(processBuilder); process = processBuilder.start(); - closeChildStdin(process); + if (!inheritedTerminalStdin) { + closeChildStdin(process); + } // Route stdout and stderr through Perl handles so that // Perl-level redirections are honored @@ -1014,8 +1015,11 @@ private static CommandResult executeCommandDirectCapture(List commandArg // Route stderr through Perl STDERR handle (not INHERIT which bypasses Perl redirections) + boolean inheritedTerminalStdin = inheritTerminalStdin(processBuilder); process = processBuilder.start(); - closeChildStdin(process); + if (!inheritedTerminalStdin) { + closeChildStdin(process); + } final Process finalProcess = process; final StringBuilder finalOutput = output; @@ -1117,6 +1121,18 @@ private static void closeChildStdin(Process process) { } } + private static boolean inheritTerminalStdin(ProcessBuilder processBuilder) { + try { + if (FFMPosix.get().isatty(0) != 0) { + processBuilder.redirectInput(ProcessBuilder.Redirect.INHERIT); + return true; + } + } catch (RuntimeException ignored) { + // Keep non-interactive pipe behavior if the platform cannot check fd 0. + } + return false; + } + /** * Writes bytes to the current Perl-level STDERR handle. * This ensures output goes through any Perl-level redirections (e.g., diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/DiamondIO.java b/src/main/java/org/perlonjava/runtime/runtimetypes/DiamondIO.java index 9155e92f81..99a7368b23 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/DiamondIO.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/DiamondIO.java @@ -526,11 +526,16 @@ private static void verifyInPlaceCompletion(State state) { WarnDie.die(new RuntimeScalar(message), new RuntimeScalar(WarnDie.getPerlLocationFromStack())); } + // Writing to a setuid/setgid file clears those permission bits on + // Unix. Perl's in-place editing preserves the source file mode, so + // restore it after closing the output handle at the file boundary. + restoreUnixMode(state.inPlaceOriginalPath, state.inPlaceFileMode); state.inPlaceOriginalPath = null; state.inPlaceBackupPath = null; state.inPlaceSourceName = null; state.inPlaceSourceDirectory = null; state.inPlaceSourceWasRelative = false; + state.inPlaceFileMode = -1; } private static boolean isForkLikeOpen(String fileName) { diff --git a/src/test/resources/unit/filetest_t_default_stdin.t b/src/test/resources/unit/filetest_t_default_stdin.t new file mode 100644 index 0000000000..61b380771c --- /dev/null +++ b/src/test/resources/unit/filetest_t_default_stdin.t @@ -0,0 +1,10 @@ +use strict; +use warnings; +use Test::More; + +plan skip_all => 'requires a terminal on STDIN' unless -t STDIN; + +ok(-t, '-t without an operand tests STDIN'); +is(-t, -t STDIN, 'bare -t agrees with explicit -t STDIN'); + +done_testing; diff --git a/src/test/resources/unit/inplace_edit_mode_preserved.t b/src/test/resources/unit/inplace_edit_mode_preserved.t new file mode 100644 index 0000000000..95ce67e68c --- /dev/null +++ b/src/test/resources/unit/inplace_edit_mode_preserved.t @@ -0,0 +1,26 @@ +use strict; +use warnings; +use File::Temp qw(tempdir); +use Test::More; + +my $dir = tempdir(CLEANUP => 1); +my $file = "$dir/input.txt"; +open my $fh, '>', $file or die "open: $!"; +print {$fh} "original\n"; +close $fh or die "close: $!"; + +chmod 04600, $file or plan skip_all => 'cannot set setuid mode on this platform'; +my $before = (stat($file))[2] & 07777; +plan skip_all => 'filesystem does not preserve setuid mode' unless $before & 04000; + +{ + local @ARGV = ($file); + local $^I = ''; + while (my $line = <>) { + print $line; + } +} + +my $after = (stat($file))[2] & 07777; +is($after, $before, 'in-place editing preserves the source permission mode'); +done_testing(); diff --git a/src/test/resources/unit/qx_inherits_tty_stdin.t b/src/test/resources/unit/qx_inherits_tty_stdin.t new file mode 100644 index 0000000000..61a466709c --- /dev/null +++ b/src/test/resources/unit/qx_inherits_tty_stdin.t @@ -0,0 +1,10 @@ +use strict; +use warnings; +use Test::More; + +plan skip_all => 'requires a terminal on STDIN' unless -t STDIN; + +my $result = qx{"$^X" -e 'print(-t STDIN ? "tty" : "notty")'}; +is($result, 'tty', 'qx children inherit terminal STDIN'); + +done_testing; From fcd152bfe794a9fce72380fc4a44cfa2b6715c2e Mon Sep 17 00:00:00 2001 From: "Flavio S. Glock" Date: Sat, 3 Oct 2026 12:23:58 +0200 Subject: [PATCH 36/41] fix: resolve remaining core UAT regressions Refresh format lexical captures from the declaring scope, preserve dynamic list context for short-circuit expressions, and format non-finite numeric values consistently across sprintf conversions. Restore errno after interrupted sleep and preserve shell argument bytes for nested interpreters. Add focused regressions for each repaired behavior. Generated with [Codex](https://openai.com/codex) Co-Authored-By: Codex <158243242+codex@users.noreply.github.com> --- docs/about/changelog.md | 9 +++- .../backend/bytecode/BytecodeCompiler.java | 13 +++++ .../backend/bytecode/BytecodeInterpreter.java | 2 + .../backend/bytecode/CompileAssignment.java | 10 +++- .../perlonjava/backend/jvm/EmitVariable.java | 31 +++++++++-- .../frontend/parser/FormatParser.java | 3 ++ .../runtime/operators/SystemOperator.java | 25 +++++++-- .../perlonjava/runtime/operators/Time.java | 3 ++ .../sprintf/SprintfNumericFormatter.java | 6 ++- .../sprintf/SprintfValueFormatter.java | 26 ++++++++- .../runtimetypes/ExecutionRuntimeState.java | 3 ++ .../runtime/runtimetypes/GlobalVariable.java | 4 ++ .../runtime/runtimetypes/RuntimeCode.java | 46 ++++++++++++++-- .../runtime/runtimetypes/RuntimeFormat.java | 54 +++++++++++++++---- .../runtime/runtimetypes/RuntimeGlob.java | 3 ++ .../runtimetypes/RuntimeGraphCloner.java | 1 + .../resources/unit/caller_deleted_named_cv.t | 13 +++++ .../empty_list_assignment_tied_hash_key.t | 19 +++++++ .../resources/unit/format_active_lexical.t | 36 +++++++++++++ src/test/resources/unit/sleep_signal_errno.t | 8 +++ .../unit/sprintf_nonfinite_fixed_point.t | 19 +++++++ .../unit/switches_utf8_argument_bytes.t | 27 ++++++++++ .../wantarray_short_circuit_runtime_context.t | 43 +++++++++++++++ 23 files changed, 372 insertions(+), 32 deletions(-) create mode 100644 src/test/resources/unit/caller_deleted_named_cv.t create mode 100644 src/test/resources/unit/empty_list_assignment_tied_hash_key.t create mode 100644 src/test/resources/unit/format_active_lexical.t create mode 100644 src/test/resources/unit/sleep_signal_errno.t create mode 100644 src/test/resources/unit/sprintf_nonfinite_fixed_point.t create mode 100644 src/test/resources/unit/switches_utf8_argument_bytes.t create mode 100644 src/test/resources/unit/wantarray_short_circuit_runtime_context.t diff --git a/docs/about/changelog.md b/docs/about/changelog.md index fbfb2c2cc9..9d8e48903e 100644 --- a/docs/about/changelog.md +++ b/docs/about/changelog.md @@ -6,7 +6,7 @@ priorities and future plans. ## Work in progress -- Prevent formats from reusing an unrelated active lexical when a captured lexical is unavailable. +- Keep format captures bound to their active lexical cell and prevent reuse of unrelated active lexicals. - Match Perl's reference count for the compile-time `%^H` hash. - Run deeply nested conditional core tests with an adequate JVM stack. - Preserve captured lexical aliases in nested eval `BEGIN` blocks. @@ -38,10 +38,15 @@ priorities and future plans. - Clear `pos()` after a failed second match of a global match-once pattern. - Validate typed hash dereferences against explicitly referenced `%FIELDS` tables. - Warn about anonymous subroutines in void context and undef dynamic code references in place. -- Report deleted stash-backed subroutines as anonymous in `caller()`. +- Report explicitly referenced stash-backed subroutines as anonymous after deletion while preserving ordinary deleted CV names in `caller()`. - Detect oversized repetition counts before they wrap during conversion. - Run eval-block destructors before clearing `$@`, and report `ENOENT` from failed `rmdir` calls. - Preserve `sprintf` numeric overload counts and format-string UTF-8 flags. +- Format infinities and NaNs with Perl's spelling across numeric `sprintf` conversions. +- Preserve runtime list context through short-circuit and ternary branches in empty-list assignments. +- Restore `EAGAIN` after alarm interrupts `sleep`, even when a signal handler changes `$!`. +- Preserve Unicode `-s` arguments when a core test launches a nested interpreter through the shell. +- Preserve non-ASCII byte arguments in unquoted shell commands. - Apply Unicode character classes to interpolated Unicode regex patterns. - Preserve combining-mark order in Unicode uppercase mappings and honor byte-string method names in `can`. - Reject scalar constants passed to hash-reference prototypes with the expected diagnostic. diff --git a/src/main/java/org/perlonjava/backend/bytecode/BytecodeCompiler.java b/src/main/java/org/perlonjava/backend/bytecode/BytecodeCompiler.java index babb1f1c22..b7fbf972a5 100644 --- a/src/main/java/org/perlonjava/backend/bytecode/BytecodeCompiler.java +++ b/src/main/java/org/perlonjava/backend/bytecode/BytecodeCompiler.java @@ -3911,6 +3911,13 @@ void compileVariableDeclaration(OperatorNode node, String op) { } emit(Opcodes.REGISTER_MY_VAR); emitReg(reg); + if (sigil.equals("$")) { + // Keep the active CV pad visible to deferred format + // argument evaluation. Format declarations can occur + // after a write in the source while Perl still binds + // the format to this invocation's lexical cell. + emitActiveLexicalBinding(reg, varName); + } // Runtime attribute dispatch for my variables with attributes emitVarAttrsIfNeeded(node, reg, sigil); @@ -4330,6 +4337,9 @@ void compileVariableDeclaration(OperatorNode node, String op) { emit(Opcodes.REGISTER_MY_VAR); emitReg(reg); + if (sigil.equals("$")) { + emitActiveLexicalBinding(reg, varName); + } // Runtime attribute dispatch for list variable declarations. // Attributes are stored on the parent my/state node, propagate to each element. @@ -9100,6 +9110,9 @@ public void visit(FormatNode node) { // executes, before a later write() can look it up. RuntimeFormat format = new RuntimeFormat(node.formatName); format.setCompiledLines(node.templateLines); + if (node.getAnnotation("formatDeclaringSubroutine") instanceof String subroutine) { + format.setLexicalDeclaringSubroutine(subroutine); + } emit(Opcodes.REGISTER_FORMAT); emit(addToConstantPool(format)); Map visible = symbolTable.getVisibleVariableRegistry(); diff --git a/src/main/java/org/perlonjava/backend/bytecode/BytecodeInterpreter.java b/src/main/java/org/perlonjava/backend/bytecode/BytecodeInterpreter.java index 3669773fcf..327dde264f 100644 --- a/src/main/java/org/perlonjava/backend/bytecode/BytecodeInterpreter.java +++ b/src/main/java/org/perlonjava/backend/bytecode/BytecodeInterpreter.java @@ -942,11 +942,13 @@ private static RuntimeList execute(SuspendedInterpreterFrame frame) { // RuntimeFormat object rather than replacing it. RuntimeFormat target = GlobalVariable.getGlobalFormatRef(format.formatName); target.replaceDefinition(format); + target.setLexicalDeclaringCode(RuntimeCode.getActiveCodeAt(0)); int captureCount = bytecode[pc++]; for (int capture = 0; capture < captureCount; capture++) { String name = code.stringPool[bytecode[pc++]]; RuntimeBase value = registers[bytecode[pc++]]; target.bindLexicalVariable(name, value); + RuntimeCode.registerCurrentActiveLexical(name, value); } } diff --git a/src/main/java/org/perlonjava/backend/bytecode/CompileAssignment.java b/src/main/java/org/perlonjava/backend/bytecode/CompileAssignment.java index 2487ac2179..dda0b14d61 100644 --- a/src/main/java/org/perlonjava/backend/bytecode/CompileAssignment.java +++ b/src/main/java/org/perlonjava/backend/bytecode/CompileAssignment.java @@ -2188,7 +2188,15 @@ && isLocalizedArraySliceReferenceTarget(referenceOp.operand)) { if (outerContext == RuntimeContextType.VOID && node.left instanceof ListNode emptyTargets && emptyTargets.elements.isEmpty()) { - boolean preserveListContext = RegexUsageDetector.containsRegexOperation(node.right) + boolean contextSensitiveRhs = node.right instanceof TernaryOperatorNode + || node.right instanceof BinaryOperatorNode binary + && (binary.operator.equals("(") + || binary.operator.equals("||") || binary.operator.equals("or") + || binary.operator.equals("&&") || binary.operator.equals("and") + || binary.operator.equals("//") || binary.operator.equals("xor") + || binary.operator.equals("^^")); + boolean preserveListContext = contextSensitiveRhs + || RegexUsageDetector.containsRegexOperation(node.right) || ListContextSideEffectDetector.containsReadline(node.right); if (!preserveListContext && node.right instanceof ListNode rhsList) { rhsList.setAnnotation("emptyTargetAssignmentVoidRhs", true); diff --git a/src/main/java/org/perlonjava/backend/jvm/EmitVariable.java b/src/main/java/org/perlonjava/backend/jvm/EmitVariable.java index cbd50aef6b..143167a816 100644 --- a/src/main/java/org/perlonjava/backend/jvm/EmitVariable.java +++ b/src/main/java/org/perlonjava/backend/jvm/EmitVariable.java @@ -889,10 +889,19 @@ static void handleAssignOperator(EmitterVisitor emitterVisitor, BinaryOperatorNo // materialization (which can fetch tied values). if (ctx.contextType == RuntimeContextType.VOID && left instanceof ListNode targets && targets.elements.isEmpty()) { - // A list-context global match must keep running through all - // matches (including callbacks) even when its result list is - // discarded by the empty target. - int rhsContext = RegexUsageDetector.containsRegexOperation(right) + // `() = EXPR` still gives EXPR list context when its result is + // discarded. Preserve the optimization for a literal list whose + // individual values do not need list-context evaluation, along + // with the established regex and readline side-effect cases. + boolean contextSensitiveRhs = right instanceof TernaryOperatorNode + || right instanceof BinaryOperatorNode binary + && (binary.operator.equals("(") + || binary.operator.equals("||") || binary.operator.equals("or") + || binary.operator.equals("&&") || binary.operator.equals("and") + || binary.operator.equals("//") || binary.operator.equals("xor") + || binary.operator.equals("^^")); + int rhsContext = contextSensitiveRhs + || RegexUsageDetector.containsRegexOperation(right) || ListContextSideEffectDetector.containsReadline(right) ? RuntimeContextType.LIST : RuntimeContextType.VOID; right.accept(emitterVisitor.with(rhsContext)); @@ -2853,6 +2862,20 @@ static void handleMyOperator(EmitterVisitor emitterVisitor, OperatorNode node) { // Store the variable in a JVM local variable emitterVisitor.ctx.mv.visitVarInsn(Opcodes.ASTORE, varIndex); + if (operator.equals("my") && sigil.equals("$")) { + // Deferred formats evaluate their argument source while + // the declaring CV is active. Keep scalar pad cells + // visible to that evaluation, including a write that + // precedes the format declaration in source order. + emitterVisitor.ctx.mv.visitLdcInsn(var); + emitterVisitor.ctx.mv.visitVarInsn(Opcodes.ALOAD, varIndex); + emitterVisitor.ctx.mv.visitMethodInsn(Opcodes.INVOKESTATIC, + "org/perlonjava/runtime/runtimetypes/RuntimeCode", + "registerCurrentActiveLexical", + "(Ljava/lang/String;Lorg/perlonjava/runtime/runtimetypes/RuntimeBase;)V", + false); + } + // Register my-variables on the cleanup stack so DESTROY fires // if die propagates through this subroutine without eval. // State/our variables are excluded: state persists across calls, diff --git a/src/main/java/org/perlonjava/frontend/parser/FormatParser.java b/src/main/java/org/perlonjava/frontend/parser/FormatParser.java index 1d4d7d048b..a84b0fb585 100644 --- a/src/main/java/org/perlonjava/frontend/parser/FormatParser.java +++ b/src/main/java/org/perlonjava/frontend/parser/FormatParser.java @@ -80,6 +80,9 @@ public static FormatNode parseFormatDeclaration(Parser parser, String formatName // the format's argument line). RuntimeFormat format = new RuntimeFormat(formatName); format.setCompiledLines(templateLines); + String declaringSubroutine = parser.ctx.symbolTable.getCurrentSubroutine(); + format.setLexicalDeclaringSubroutine(declaringSubroutine); + formatNode.setAnnotation("formatDeclaringSubroutine", declaringSubroutine); GlobalVariable.setGlobalFormatRef(formatName, format); return formatNode; diff --git a/src/main/java/org/perlonjava/runtime/operators/SystemOperator.java b/src/main/java/org/perlonjava/runtime/operators/SystemOperator.java index bdc2e217ac..4b84c4536e 100644 --- a/src/main/java/org/perlonjava/runtime/operators/SystemOperator.java +++ b/src/main/java/org/perlonjava/runtime/operators/SystemOperator.java @@ -167,16 +167,31 @@ public static RuntimeBase systemCommand(RuntimeScalar command, int ctx) { } /** - * Preserve octets embedded in a Perl byte-string command when the command - * is passed through a UTF-8 Java ProcessBuilder argument. Core tests build - * shell commands from utf8::encoded strings; octal escapes survive the - * shell's single-quoted command text and are decoded by the child Perl. + * Preserve octets embedded in quoted Perl source when a byte-string + * command passes through UTF-8 ProcessBuilder arguments. Leave unquoted + * command arguments as characters so the shell forwards them intact. */ private static String encodeByteStringForShell(String command) { StringBuilder encoded = new StringBuilder(command.length()); + boolean singleQuoted = false; + boolean doubleQuoted = false; for (int i = 0; i < command.length(); i++) { char ch = command.charAt(i); - if (ch >= 0x80 && ch <= 0xff) { + if (ch == '\\' && !singleQuoted && i + 1 < command.length()) { + encoded.append(ch).append(command.charAt(++i)); + continue; + } + if (ch == '\'' && !doubleQuoted) { + singleQuoted = !singleQuoted; + encoded.append(ch); + continue; + } + if (ch == '"' && !singleQuoted) { + doubleQuoted = !doubleQuoted; + encoded.append(ch); + continue; + } + if (ch >= 0x80 && ch <= 0xff && (singleQuoted || doubleQuoted)) { encoded.append('\\'); String octal = Integer.toOctalString(ch); for (int pad = octal.length(); pad < 3; pad++) { diff --git a/src/main/java/org/perlonjava/runtime/operators/Time.java b/src/main/java/org/perlonjava/runtime/operators/Time.java index 00902775af..265c1d302d 100644 --- a/src/main/java/org/perlonjava/runtime/operators/Time.java +++ b/src/main/java/org/perlonjava/runtime/operators/Time.java @@ -333,6 +333,9 @@ private static RuntimeScalar sleepInternal(RuntimeScalar runtimeScalar, boolean // Sleep was interrupted (likely by alarm()) // Process any pending signals through the signal queue PerlSignalQueue.checkPendingSignals(); + // A queued signal handler may itself change $!. Perl reports the + // interrupted sleep errno after dispatching that handler. + getGlobalVariable("main::!").set(ErrnoVariable.EAGAIN()); // If the signal handler threw an exception (die), it will propagate from checkPendingSignals() } long endTime = System.nanoTime(); diff --git a/src/main/java/org/perlonjava/runtime/operators/sprintf/SprintfNumericFormatter.java b/src/main/java/org/perlonjava/runtime/operators/sprintf/SprintfNumericFormatter.java index d773d03bf0..fd1958a4c5 100644 --- a/src/main/java/org/perlonjava/runtime/operators/sprintf/SprintfNumericFormatter.java +++ b/src/main/java/org/perlonjava/runtime/operators/sprintf/SprintfNumericFormatter.java @@ -327,7 +327,7 @@ public String formatFloatingPoint(double value, String flags, int width, // 2.5 as 3), which changes real calculations at exact half-way values. // Format %f/%F from the exact binary double so both ordinary rounding // and exact ties agree with Perl. - if (conversion == 'f' || conversion == 'F') { + if ((conversion == 'f' || conversion == 'F') && Double.isFinite(value)) { return formatFixedPoint(value, cleanFlags, width, precision); } @@ -352,7 +352,9 @@ public String formatFloatingPoint(double value, String flags, int width, String result = String.format(format.toString(), value); // Perl uses 'Inf' instead of Java's 'Infinity' - result = result.replace("Infinity", "Inf"); + result = result.replace("INFINITY", "Inf").replace("Infinity", "Inf"); + // Perl's %F conversion does not uppercase the NaN spelling. + result = result.replace("NAN", "NaN"); return result; } diff --git a/src/main/java/org/perlonjava/runtime/operators/sprintf/SprintfValueFormatter.java b/src/main/java/org/perlonjava/runtime/operators/sprintf/SprintfValueFormatter.java index 47bb2bb6ca..d5b1863bad 100644 --- a/src/main/java/org/perlonjava/runtime/operators/sprintf/SprintfValueFormatter.java +++ b/src/main/java/org/perlonjava/runtime/operators/sprintf/SprintfValueFormatter.java @@ -1,6 +1,7 @@ package org.perlonjava.runtime.operators.sprintf; import org.perlonjava.runtime.runtimetypes.PerlCompilerException; +import org.perlonjava.runtime.runtimetypes.DualVar; import org.perlonjava.runtime.runtimetypes.RuntimeScalar; import org.perlonjava.runtime.runtimetypes.RuntimeScalarCache; import org.perlonjava.runtime.runtimetypes.RuntimeScalarType; @@ -85,11 +86,32 @@ public String formatValue(RuntimeScalar value, String flags, int width, // Preserve special floating-point values without coercing overloaded // references a second time. Other numeric conversions perform their // one required coercion in the formatter below. - if (value.type == RuntimeScalarType.DOUBLE) { - double doubleValue = (double) value.value; + RuntimeScalar numericValue = value.type == RuntimeScalarType.DUALVAR + ? ((DualVar) value.value).numericValue() : value; + if (numericValue.type == RuntimeScalarType.DOUBLE) { + double doubleValue = (double) numericValue.value; if (Double.isInfinite(doubleValue) || Double.isNaN(doubleValue)) { return numericFormatter.formatSpecialValue(doubleValue, flags, width, conversion); } + } else if (numericValue.type == RuntimeScalarType.STRING + || numericValue.type == RuntimeScalarType.BYTE_STRING) { + // The Perl oracle keeps Inf/NaN as string-backed numeric values + // in some sprintf paths. Recognize only these exact spellings so + // ordinary nonnumeric strings retain their existing warning and + // coercion behavior. + String text = numericValue.toString().trim(); + double special = switch (text.toLowerCase(java.util.Locale.ROOT)) { + case "inf", "+inf", "infinity", "+infinity" -> Double.POSITIVE_INFINITY; + case "-inf", "-infinity" -> Double.NEGATIVE_INFINITY; + case "nan", "+nan", "-nan" -> Double.NaN; + default -> Double.NaN; + }; + if (Double.isInfinite(special) + || text.equalsIgnoreCase("nan") + || text.equalsIgnoreCase("+nan") + || text.equalsIgnoreCase("-nan")) { + return numericFormatter.formatSpecialValue(special, flags, width, conversion); + } } // Dispatch to appropriate formatter based on conversion type diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/ExecutionRuntimeState.java b/src/main/java/org/perlonjava/runtime/runtimetypes/ExecutionRuntimeState.java index d433d45e93..4c2e8995df 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/ExecutionRuntimeState.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/ExecutionRuntimeState.java @@ -9,6 +9,7 @@ import java.util.LinkedHashMap; import java.util.IdentityHashMap; import java.util.List; +import java.util.Map; import java.util.Stack; import java.util.Set; @@ -71,6 +72,8 @@ public final class ExecutionRuntimeState { public final Deque activeRegexCallbackLocations = new ArrayDeque<>(); public final Deque activeRegexCallbackPackages = new ArrayDeque<>(); public final Deque activeLexicalFrames = new ArrayDeque<>(); + /** Lexical cells owned by the top-level compilation unit. */ + public final Map topLevelLexicals = new LinkedHashMap<>(); public final Deque> pristineArgsStack = new ArrayDeque<>(); /** Reusable one-scalar return lists, populated only after scalar extraction. */ final Deque availableScalarResultLists = new ArrayDeque<>(); diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/GlobalVariable.java b/src/main/java/org/perlonjava/runtime/runtimetypes/GlobalVariable.java index 89bd284a46..b01fa105c4 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/GlobalVariable.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/GlobalVariable.java @@ -2724,6 +2724,10 @@ public static RuntimeGlob getGlobalIO(String key) { glob = new RuntimeGlob(resolvedKey); globalIORefs.put(resolvedKey, glob); } + RuntimeScalar visibleCode = globalCodeRefs.get(resolvedKey); + if (visibleCode != null && visibleCode.value instanceof RuntimeCode code) { + code.explicitlyMaterializedGlob = true; + } return glob; } diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeCode.java b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeCode.java index c8d31d06c5..9133b59a48 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeCode.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeCode.java @@ -846,6 +846,24 @@ public static Map snapshotAllActiveLexicals() { result.putIfAbsent(entry.getKey(), entry.getValue()); } } + for (Map.Entry entry + : runtime.executionState().topLevelLexicals.entrySet()) { + result.putIfAbsent(entry.getKey(), entry.getValue()); + } + return result; + } + + /** Return live top-level lexical cells without consulting subroutine pads. */ + public static Map snapshotTopLevelLexicals() { + ExecutionRuntimeState state = PerlRuntime.current().executionState(); + Map result = new LinkedHashMap<>(); + for (ActiveLexicalFrame frame : activeLexicalFrames(state)) { + if (frame.code() == null || frame.code().subName == null + || frame.code().subName.isBlank()) { + result.putAll(frame.cells()); + } + } + result.putAll(state.topLevelLexicals); return result; } @@ -853,6 +871,7 @@ public static Map snapshotAllActiveLexicals() { public static boolean isActiveLexicalCell(RuntimeBase cell) { if (cell == null) return false; PerlRuntime runtime = PerlRuntime.current(); + if (runtime.executionState().topLevelLexicals.containsValue(cell)) return true; for (ActiveLexicalFrame frame : activeLexicalFrames(runtime.executionState())) { for (RuntimeBase activeCell : frame.cells().values()) { if (activeCell == cell) return true; @@ -861,6 +880,17 @@ public static boolean isActiveLexicalCell(RuntimeBase cell) { return false; } + /** Bind a format's captured lexical to the currently executing pad frame. */ + public static void registerCurrentActiveLexical(String variableName, RuntimeBase cell) { + ExecutionRuntimeState state = PerlRuntime.current().executionState(); + Deque frames = activeLexicalFrames(state); + if (!frames.isEmpty() && variableName != null && cell != null) { + frames.peek().cells().put(variableName, cell); + } else if (variableName != null && cell != null) { + state.topLevelLexicals.put(variableName, cell); + } + } + /** * Select eval STRING captures for Perl's package-DB rule. An eval run by * a DB subroutine is evaluated in the lexical pad of the code being @@ -1896,6 +1926,8 @@ public static void registerDisabledWarnings(String className, Set catego * kept alive by stale internal owner records. */ public boolean hadStashRef = false; + /** True when Perl code explicitly materialized the CV's named typeglob. */ + public boolean explicitlyMaterializedGlob; /** * True when this CV was last installed with {@code *Pkg::name = $anonymous_cr} * (stash slot recorded, but not {@code Sub::Name}/{@code set_subname}). @@ -2164,6 +2196,9 @@ public void unbindActiveLexical(String variableName, RuntimeBase cell) { return; } } + if (runtime.executionState().topLevelLexicals.get(variableName) == cell) { + runtime.executionState().topLevelLexicals.remove(variableName); + } } /** @@ -3155,6 +3190,7 @@ public void adoptDefinitionFrom(RuntimeCode codeFrom) { this.stashInstallPackage = codeFrom.stashInstallPackage; this.stashInstallSub = codeFrom.stashInstallSub; this.hadStashRef = codeFrom.hadStashRef; + this.explicitlyMaterializedGlob = codeFrom.explicitlyMaterializedGlob; this.installedViaAnonGlobAssign = codeFrom.installedViaAnonGlobAssign; this.stateVariableInitialized = codeFrom.stateVariableInitialized; this.stateVariable = codeFrom.stateVariable; @@ -5935,11 +5971,11 @@ private static String callerSubNameForCode(RuntimeCode code) { } return null; } - if (code.hadStashRef && !code.explicitlyRenamed + if (code.hadStashRef && code.explicitlyMaterializedGlob && !code.explicitlyRenamed && GlobalVariable.findGlobalCodeRefName(code) == null) { - // A named CV reached through a saved glob can outlive its stash - // entry. Perl then reports the surviving CV as anonymous because - // its name depended on that glob. + // A CV whose name was captured from an explicitly materialized + // glob can outlive its stash entry. Ordinary named CVs retain + // their compiled sub name after deletion. return normalizeCallerPackage(code.packageName) + "::__ANON__"; } if (code.subName.contains("::")) { @@ -5962,7 +5998,7 @@ private static RuntimeCode deletedStashCodeForCallerName(String callerName) { if (activeName == null && active.packageName != null && active.subName != null) { activeName = active.packageName + "::" + active.subName; } - if (active.hadStashRef && !active.explicitlyRenamed + if (active.hadStashRef && active.explicitlyMaterializedGlob && !active.explicitlyRenamed && callerName.equals(activeName) && GlobalVariable.findGlobalCodeRefName(active) == null) { return active; diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeFormat.java b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeFormat.java index 96ad35fb20..368feef5db 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeFormat.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeFormat.java @@ -45,6 +45,17 @@ public class RuntimeFormat extends RuntimeScalar implements RuntimeScalarReferen /** Live lexical cells captured where this format was declared. */ private final Map lexicalVariables = new HashMap<>(); + /** CV whose active pad may refresh captures while the format executes. */ + private RuntimeCode lexicalDeclaringCode; + private String lexicalDeclaringSubroutine; + + public void setLexicalDeclaringCode(RuntimeCode code) { + lexicalDeclaringCode = code; + } + + public void setLexicalDeclaringSubroutine(String name) { + lexicalDeclaringSubroutine = name == null ? "" : name; + } public void bindLexicalVariable(String name, RuntimeBase value) { lexicalVariables.put(name, value); @@ -101,6 +112,7 @@ public RuntimeFormat replaceDefinition(RuntimeFormat source) { this.compiledLines = new ArrayList<>(source.compiledLines); this.isCompiled = source.isCompiled; this.isDefined = source.isDefined; + this.lexicalDeclaringSubroutine = source.lexicalDeclaringSubroutine; this.lexicalVariables.clear(); return this; } @@ -625,7 +637,24 @@ private List materializeLineArguments(ArgumentLine argLine, // A FORMAT slot can survive a fork while its declaring lexical pad // is recreated in the child. Refresh only names captured by the // emitter; never discover new names from arbitrary caller frames. - Map activeLexicals = RuntimeCode.snapshotAllActiveLexicals(); + Map activeLexicals = Map.of(); + if (lexicalDeclaringCode != null) { + activeLexicals = RuntimeCode.snapshotActiveLexicals(lexicalDeclaringCode); + } else if (lexicalDeclaringSubroutine != null + && !lexicalDeclaringSubroutine.isBlank()) { + // A format can be written before its source-position + // registration. Refresh from the active invocation only when + // its logical CV owns this format declaration. + RuntimeCode activeCode = RuntimeCode.getActiveCodeAt(0); + String activeSubroutine = activeCode == null ? null : activeCode.subName; + if (activeCode != null && activeSubroutine != null + && (lexicalDeclaringSubroutine.equals(activeSubroutine) + || lexicalDeclaringSubroutine.endsWith("::" + activeSubroutine))) { + activeLexicals = RuntimeCode.snapshotActiveLexicals(activeCode); + } + } else if (lexicalDeclaringSubroutine != null) { + activeLexicals = RuntimeCode.snapshotTopLevelLexicals(); + } if (argLine.getAnnotation("unavailableLexicalVariableNames") instanceof List names && !names.isEmpty()) { for (Object value : names) { @@ -636,6 +665,16 @@ private List materializeLineArguments(ArgumentLine argLine, // to have the same name in the caller. Keep the captured // cell only while that exact cell is still active. RuntimeBase captured = lexicalVariables.get(name); + RuntimeBase active = activeLexicals.get(name); + if (active != null) { + // A format in a named subroutine is registered again + // on each invocation. Refresh its captured cell from + // that exact declaring CV's active pad; a caller's + // same-named lexical is excluded by the scoped + // snapshot above. + lexicalVariables.put(name, active); + continue; + } if (RuntimeCode.isActiveLexicalCell(captured)) { continue; } @@ -659,16 +698,9 @@ private List materializeLineArguments(ArgumentLine argLine, } RuntimeBase active = activeLexicals.get(name); if (active != null) { - if (captured == null) { - lexicalVariables.put(name, active); - } else if (!isPackageVariable(name)) { - // Do not replace a stale declaration-scope cell with - // an unrelated active cell of the same name. - WarnDie.warn(new RuntimeScalar("Variable \"" + name - + "\" is not available at format " + formatName + "\n"), - new RuntimeScalar("")); - lexicalVariables.put(name, new RuntimeScalar()); - } + // activeLexicals contains only the format's declaring CV, + // so this is the current invocation's lexical pad. + lexicalVariables.put(name, active); } else if (!isPackageVariable(name) && argLine.content.matches("(?s).*\\Q" + name + "\\E(?:\\b|\\W).*")) { // A FORMAT can outlive the CV whose lexical pad declared diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeGlob.java b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeGlob.java index e075f6e146..a02dbb7bda 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeGlob.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeGlob.java @@ -222,6 +222,9 @@ public RuntimeGlob createDetachedCopy() { // compile-time pinned placeholder, whereas a copied typeglob must // capture the CV that is presently installed in its stash. RuntimeScalar visibleCode = GlobalVariable.globalCodeRefs.get(this.globName); + if (visibleCode != null && visibleCode.value instanceof RuntimeCode code) { + code.explicitlyMaterializedGlob = true; + } copy.codeSlot = new RuntimeScalar(visibleCode != null ? visibleCode : GlobalVariable.getGlobalCodeRef(this.globName)); copy.scalarSlot = GlobalVariable.globalVariables.get(this.globName); diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeGraphCloner.java b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeGraphCloner.java index 385f867f3e..8a7242fd70 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeGraphCloner.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeGraphCloner.java @@ -379,6 +379,7 @@ private void copyCodeMetadata(RuntimeCode source, RuntimeCode target) { target.stashInstallPackage = source.stashInstallPackage; target.stashInstallSub = source.stashInstallSub; target.hadStashRef = source.hadStashRef; + target.explicitlyMaterializedGlob = source.explicitlyMaterializedGlob; target.installedViaAnonGlobAssign = source.installedViaAnonGlobAssign; target.cvStartFile = source.cvStartFile; target.cvStartLine = source.cvStartLine; diff --git a/src/test/resources/unit/caller_deleted_named_cv.t b/src/test/resources/unit/caller_deleted_named_cv.t new file mode 100644 index 0000000000..96a334b304 --- /dev/null +++ b/src/test/resources/unit/caller_deleted_named_cv.t @@ -0,0 +1,13 @@ +use strict; +use warnings; +use Test::More; + +our @caller_info; +sub deleted_named_sub { @caller_info = caller(0) } + +my $saved_sub = delete $::{deleted_named_sub}; +$saved_sub->(); +is($caller_info[3], 'main::deleted_named_sub', + 'a deleted named CV retains its name without a materialized glob reference'); + +done_testing; diff --git a/src/test/resources/unit/empty_list_assignment_tied_hash_key.t b/src/test/resources/unit/empty_list_assignment_tied_hash_key.t new file mode 100644 index 0000000000..e216b05ee9 --- /dev/null +++ b/src/test/resources/unit/empty_list_assignment_tied_hash_key.t @@ -0,0 +1,19 @@ +use strict; +use warnings; +use Test::More tests => 1; + +our $fetched_key; +{ + package EmptyListAssignmentTie; + sub TIEHASH { bless {}, shift } + sub FETCH { $main::fetched_key = $_[1]; return } +} + +{ + package main; + tie my %tied, 'EmptyListAssignmentTie'; + () = $tied{\'key'}; +} + +is(ref($fetched_key), 'SCALAR', + 'empty-list assignment does not stringify a tied hash reference key'); diff --git a/src/test/resources/unit/format_active_lexical.t b/src/test/resources/unit/format_active_lexical.t new file mode 100644 index 0000000000..e57035a3b4 --- /dev/null +++ b/src/test/resources/unit/format_active_lexical.t @@ -0,0 +1,36 @@ +use strict; +use warnings; +use Test::More tests => 2; +use File::Temp qw(tempfile); + +our @format_warnings; +my ($capture_fh, $capture_path) = tempfile(); +open my $saved_stdout, '>&STDOUT' or die "save STDOUT: $!"; +open STDOUT, '>&', $capture_fh or die "redirect STDOUT: $!"; + +sub write_active_lexical ($) { + my $test = $_[0]; + write; +format STDOUT = +ok @<<<<<<< +$test +. +} + +{ + local $SIG{__WARN__} = sub { push @format_warnings, @_ }; + write_active_lexical(1); + write_active_lexical(2); +} + +open STDOUT, '>&', $saved_stdout or die "restore STDOUT: $!"; +close $capture_fh or die "close format capture: $!"; +open my $captured_output, '<', $capture_path or die "read format capture: $!"; +local $/; +my $formatted = <$captured_output>; +close $captured_output; +unlink $capture_path or die "unlink format capture: $!"; +like($formatted, qr/ok 1\s+ok 2\s*\z/, + 'a format evaluates its captured lexical while the declaring subroutine is active'); +ok(!grep(/Variable ".*" is not available at format/, @format_warnings), + 'an active format lexical is not reported as unavailable'); diff --git a/src/test/resources/unit/sleep_signal_errno.t b/src/test/resources/unit/sleep_signal_errno.t new file mode 100644 index 0000000000..560fa949d0 --- /dev/null +++ b/src/test/resources/unit/sleep_signal_errno.t @@ -0,0 +1,8 @@ +use strict; +use warnings; +use Test::More tests => 1; + +$SIG{ALRM} = sub { $! = -1 }; +alarm 1; +sleep 2; +isnt(0 + $!, -1, 'interrupted sleep restores EAGAIN after signal dispatch'); diff --git a/src/test/resources/unit/sprintf_nonfinite_fixed_point.t b/src/test/resources/unit/sprintf_nonfinite_fixed_point.t new file mode 100644 index 0000000000..36ada786a1 --- /dev/null +++ b/src/test/resources/unit/sprintf_nonfinite_fixed_point.t @@ -0,0 +1,19 @@ +use strict; +use warnings; +use Test::More; + +my $positive_infinity = 'Inf' + 0; +my $negative_infinity = '-Inf' + 0; +my $nan = 'NaN' + 0; + +is(sprintf('%f', $positive_infinity), 'Inf', '%f formats positive infinity'); +is(sprintf('%f', $negative_infinity), '-Inf', '%f formats negative infinity'); +is(sprintf('%F', $positive_infinity), 'Inf', '%F formats positive infinity'); +is(sprintf('%+8.2f', $positive_infinity), ' +Inf', 'flags and width apply to infinity'); +is(sprintf('%f', $nan), 'NaN', '%f formats NaN'); +is(sprintf('%d', $positive_infinity), 'Inf', 'integer decimal conversion preserves infinity'); +is(sprintf('%x', $positive_infinity), 'Inf', 'hex conversion preserves infinity'); +is(sprintf('%o', $negative_infinity), '-Inf', 'octal conversion preserves negative infinity'); +is(sprintf('%u', $nan), 'NaN', 'unsigned conversion preserves NaN'); + +done_testing; diff --git a/src/test/resources/unit/switches_utf8_argument_bytes.t b/src/test/resources/unit/switches_utf8_argument_bytes.t new file mode 100644 index 0000000000..0d908c662a --- /dev/null +++ b/src/test/resources/unit/switches_utf8_argument_bytes.t @@ -0,0 +1,27 @@ +use strict; +use warnings; +use Test::More; + +my $program = q{printf q(%vx;), $_ for ${qq(\xC5\xB8)}, ${qq(\x{178})}, ${qq(\xC3\xA1)}, ${qq(\xE1)}}; +my $byte_args = "-- -\xC5\xB8 -\xC3\xA1=\xE2\x82\xAC"; +local $ENV{LC_ALL} = 'C'; +local $ENV{LANG} = 'C'; + +my $without_utf8 = qx{$^X -C0 -s -e '$program' $byte_args 2>&1}; +my $without_utf8_status = $? >> 8; +is($without_utf8_status, 0, '-s accepts non-ASCII byte arguments without -CA'); +is($without_utf8, '31;;e2.82.ac;;', '-s preserves argument bytes without -CA'); + +SKIP: { + # The host's system Perl is 5.42 and predates the upstream -s/-CA behavior + # covered by perl5_t/t/run/switches.t. Keep this check active under jperl. + skip 'system Perl predates Unicode decoding for -s arguments', 2 + unless $^X =~ /(?:^|\/)jperl(?:\.bat)?\z/i; + + my $with_utf8 = qx{$^X -CA -s -e '$program' $byte_args 2>&1}; + my $with_utf8_status = $? >> 8; + is($with_utf8_status, 0, '-s accepts UTF-8 byte arguments with -CA'); + is($with_utf8, ';31;;20ac;', '-CA decodes -s argument bytes as UTF-8'); +} + +done_testing; diff --git a/src/test/resources/unit/wantarray_short_circuit_runtime_context.t b/src/test/resources/unit/wantarray_short_circuit_runtime_context.t new file mode 100644 index 0000000000..b8bc537942 --- /dev/null +++ b/src/test/resources/unit/wantarray_short_circuit_runtime_context.t @@ -0,0 +1,43 @@ +use strict; +use warnings; +use Test::More; + +our $observed_context; + +sub observed_context { + $observed_context = !defined(wantarray) ? 'V' : wantarray ? 'A' : 'S'; + return $observed_context; +} + +sub or_context { 0 || observed_context() } +sub and_context { 1 && observed_context() } +sub defined_or_context { undef // observed_context() } +sub ternary_middle_context { 1 ? observed_context() : 'unused' } +sub ternary_right_context { 0 ? 'unused' : observed_context() } + +my @or_result = or_context(); +my @and_result = and_context(); +my @defined_or_result = defined_or_context(); +my @ternary_middle_result = ternary_middle_context(); +my @ternary_right_result = ternary_right_context(); + +is($or_result[0], 'A', '|| RHS inherits runtime list context'); +is($and_result[0], 'A', '&& RHS inherits runtime list context'); +is($defined_or_result[0], 'A', '// RHS inherits runtime list context'); +is($ternary_middle_result[0], 'A', 'ternary middle branch inherits runtime list context'); +is($ternary_right_result[0], 'A', 'ternary right branch inherits runtime list context'); + +# An empty list assignment imposes list context even when the assignment's +# value is discarded by the enclosing statement. +() = or_context(); +is($observed_context, 'A', 'empty list assignment preserves || RHS list context'); +() = and_context(); +is($observed_context, 'A', 'empty list assignment preserves && RHS list context'); +() = defined_or_context(); +is($observed_context, 'A', 'empty list assignment preserves // RHS list context'); +() = ternary_middle_context(); +is($observed_context, 'A', 'empty list assignment preserves ternary middle list context'); +() = ternary_right_context(); +is($observed_context, 'A', 'empty list assignment preserves ternary right list context'); + +done_testing; From 709244ce58a64433f126b288b2bb13cdba2abdd2 Mon Sep 17 00:00:00 2001 From: "Flavio S. Glock" Date: Sat, 3 Oct 2026 13:28:53 +0200 Subject: [PATCH 37/41] ci: validate final UAT tree in GitHub Actions Trigger pull request checks for the exact source tree that passed the final full UAT and baseline comparison. Generated with Codex (https://openai.com/codex) Co-Authored-By: Codex From fec28321105aa1450ceae285297270a81be75ac3 Mon Sep 17 00:00:00 2001 From: "Flavio S. Glock" Date: Sat, 3 Oct 2026 14:48:59 +0200 Subject: [PATCH 38/41] fix: preserve raw argv bytes under the C locale Transport non-ASCII command-line arguments through an ASCII-safe launcher encoding when the JVM starts under the C locale, and emit unquoted shell byte arguments through POSIX printf substitutions. Generated with [Codex](https://openai.com/codex) Co-Authored-By: Codex <158243242+codex@users.noreply.github.com> --- docs/about/changelog.md | 3 +- jperl | 36 +++++++++++++++++++ .../java/org/perlonjava/app/cli/Main.java | 16 +++++++++ .../runtime/operators/SystemOperator.java | 12 +++++-- 4 files changed, 64 insertions(+), 3 deletions(-) diff --git a/docs/about/changelog.md b/docs/about/changelog.md index 217bc36971..6fb56cd20e 100644 --- a/docs/about/changelog.md +++ b/docs/about/changelog.md @@ -46,7 +46,8 @@ priorities and future plans. - Preserve runtime list context through short-circuit and ternary branches in empty-list assignments. - Restore `EAGAIN` after alarm interrupts `sleep`, even when a signal handler changes `$!`. - Preserve Unicode `-s` arguments when a core test launches a nested interpreter through the shell. -- Preserve non-ASCII byte arguments in unquoted shell commands. +- Preserve non-ASCII byte arguments in unquoted shell commands and nested + PerlOnJava launches under the C locale. - Apply Unicode character classes to interpolated Unicode regex patterns. - Preserve combining-mark order in Unicode uppercase mappings and honor byte-string method names in `can`. - Reject scalar constants passed to hash-reference prototypes with the expected diagnostic. diff --git a/jperl b/jperl index 6427cc50d4..4b9e864a72 100755 --- a/jperl +++ b/jperl @@ -119,4 +119,40 @@ if [ -n "$CLASSPATH" ]; then else CP="$PERLONJAVA_CP" fi + +# On POSIX systems a JVM started under the C locale cannot faithfully decode +# non-ASCII process arguments. Perl still treats argv as bytes, so preserve +# non-ASCII arguments as ASCII hex while crossing the native/JVM boundary; +# Main restores their byte values before parsing the Perl command line. +ARGV_LOCALE="${LC_ALL:-${LC_CTYPE:-${LANG:-}}}" +case "$ARGV_LOCALE" in + C|POSIX) + ARGV_NEEDS_RESTORE=0 + ARGV_REPLACED=() + for ARGV_ITEM in "$@"; do + ARGV_HEX="" + ARGV_HAS_HIGH_BYTE=0 + for ((ARGV_INDEX = 0; ARGV_INDEX < ${#ARGV_ITEM}; ARGV_INDEX++)); do + ARGV_CHARACTER="${ARGV_ITEM:ARGV_INDEX:1}" + printf -v ARGV_BYTE_VALUE '%d' "'$ARGV_CHARACTER" + ARGV_BYTE_VALUE=$((ARGV_BYTE_VALUE & 255)) + printf -v ARGV_BYTE_HEX '%02x' "$ARGV_BYTE_VALUE" + ARGV_HEX+="$ARGV_BYTE_HEX" + if (( 16#$ARGV_BYTE_HEX >= 128 )); then + ARGV_HAS_HIGH_BYTE=1 + fi + done + if [ "$ARGV_HAS_HIGH_BYTE" -eq 1 ]; then + ARGV_REPLACED+=("__PERLONJAVA_RAWARG_HEX__$ARGV_HEX") + ARGV_NEEDS_RESTORE=1 + else + ARGV_REPLACED+=("$ARGV_ITEM") + fi + done + if [ "$ARGV_NEEDS_RESTORE" -eq 1 ]; then + set -- "${ARGV_REPLACED[@]}" + JVM_OPTS="$JVM_OPTS -Dperlonjava.rawargv.hex=true" + fi + ;; +esac exec "$JAVA_BIN" $JVM_OPTS ${JPERL_OPTS} -cp "$CP" org.perlonjava.app.cli.Main "$@" diff --git a/src/main/java/org/perlonjava/app/cli/Main.java b/src/main/java/org/perlonjava/app/cli/Main.java index 13a00953e7..db731e07b4 100644 --- a/src/main/java/org/perlonjava/app/cli/Main.java +++ b/src/main/java/org/perlonjava/app/cli/Main.java @@ -21,6 +21,8 @@ */ public class Main { + private static final String RAW_ARG_HEX_PREFIX = "__PERLONJAVA_RAWARG_HEX__"; + static { // Set default locale to US (uses dot as decimal separator) Locale.setDefault(Locale.US); @@ -91,6 +93,7 @@ private static void startOrphanWatchdog() { * @param args Command-line arguments. */ public static void main(String[] args) { + restoreRawByteArguments(args); PerlRuntime runtime = new PerlRuntime(); installThreadExitDiagnostic(runtime); try (PerlRuntime.Binding runtimeBinding = runtime.bind()) { @@ -98,6 +101,19 @@ public static void main(String[] args) { } } + private static void restoreRawByteArguments(String[] args) { + if (!Boolean.getBoolean("perlonjava.rawargv.hex")) { + return; + } + for (int i = 0; i < args.length; i++) { + if (args[i].startsWith(RAW_ARG_HEX_PREFIX)) { + String encoded = args[i].substring(RAW_ARG_HEX_PREFIX.length()); + byte[] bytes = java.util.HexFormat.of().parseHex(encoded); + args[i] = new String(bytes, java.nio.charset.StandardCharsets.ISO_8859_1); + } + } + } + private static void installThreadExitDiagnostic(PerlRuntime runtime) { Thread hook = Thread.ofPlatform().name("perlonjava-thread-exit-diagnostic") .unstarted(() -> { diff --git a/src/main/java/org/perlonjava/runtime/operators/SystemOperator.java b/src/main/java/org/perlonjava/runtime/operators/SystemOperator.java index 4b84c4536e..d764aea969 100644 --- a/src/main/java/org/perlonjava/runtime/operators/SystemOperator.java +++ b/src/main/java/org/perlonjava/runtime/operators/SystemOperator.java @@ -168,8 +168,9 @@ public static RuntimeBase systemCommand(RuntimeScalar command, int ctx) { /** * Preserve octets embedded in quoted Perl source when a byte-string - * command passes through UTF-8 ProcessBuilder arguments. Leave unquoted - * command arguments as characters so the shell forwards them intact. + * command passes through ProcessBuilder arguments. On Unix, emit unquoted + * octets through ASCII-only shell substitutions so a C-locale JVM does + * not replace them while encoding the shell command. */ private static String encodeByteStringForShell(String command) { StringBuilder encoded = new StringBuilder(command.length()); @@ -198,6 +199,13 @@ private static String encodeByteStringForShell(String command) { encoded.append('0'); } encoded.append(octal); + } else if (ch >= 0x80 && ch <= 0xff && !SystemUtils.osIsWindows()) { + encoded.append("$(printf '\\"); + String octal = Integer.toOctalString(ch); + for (int pad = octal.length(); pad < 3; pad++) { + encoded.append('0'); + } + encoded.append(octal).append("')"); } else { encoded.append(ch); } From bc26ee4787b9ef9e8c966a4f92e71f196434d2dc Mon Sep 17 00:00:00 2001 From: "Flavio S. Glock" Date: Sat, 3 Oct 2026 15:31:46 +0200 Subject: [PATCH 39/41] fix: preserve shell bytes only for ASCII child locales Keep byte-preserving shell substitutions for C/POSIX child environments while leaving UTF-8 locale command arguments as Unicode characters. Generated with [Codex](https://openai.com/codex) Co-Authored-By: Codex <158243242+codex@users.noreply.github.com> --- .../runtime/operators/SystemOperator.java | 14 +++++++++++++- 1 file changed, 13 insertions(+), 1 deletion(-) diff --git a/src/main/java/org/perlonjava/runtime/operators/SystemOperator.java b/src/main/java/org/perlonjava/runtime/operators/SystemOperator.java index d764aea969..e85dd528a9 100644 --- a/src/main/java/org/perlonjava/runtime/operators/SystemOperator.java +++ b/src/main/java/org/perlonjava/runtime/operators/SystemOperator.java @@ -176,6 +176,7 @@ private static String encodeByteStringForShell(String command) { StringBuilder encoded = new StringBuilder(command.length()); boolean singleQuoted = false; boolean doubleQuoted = false; + boolean asciiShellLocale = !SystemUtils.osIsWindows() && usesAsciiShellLocale(); for (int i = 0; i < command.length(); i++) { char ch = command.charAt(i); if (ch == '\\' && !singleQuoted && i + 1 < command.length()) { @@ -199,7 +200,7 @@ private static String encodeByteStringForShell(String command) { encoded.append('0'); } encoded.append(octal); - } else if (ch >= 0x80 && ch <= 0xff && !SystemUtils.osIsWindows()) { + } else if (ch >= 0x80 && ch <= 0xff && asciiShellLocale) { encoded.append("$(printf '\\"); String octal = Integer.toOctalString(ch); for (int pad = octal.length(); pad < 3; pad++) { @@ -213,6 +214,17 @@ private static String encodeByteStringForShell(String command) { return encoded.toString(); } + private static boolean usesAsciiShellLocale() { + String locale = getPerlEnvValue("LC_ALL"); + if (locale == null || locale.isEmpty()) { + locale = getPerlEnvValue("LC_CTYPE"); + } + if (locale == null || locale.isEmpty()) { + locale = getPerlEnvValue("LANG"); + } + return "C".equals(locale) || "POSIX".equals(locale); + } + /** * Executes a system command and returns the exit status. * This implements Perl's system() function. From aba025fd2305eb265f86f9ade0767d5a4b8f58cf Mon Sep 17 00:00:00 2001 From: "Flavio S. Glock" Date: Sat, 3 Oct 2026 16:24:15 +0200 Subject: [PATCH 40/41] fix: preserve Windows child process behavior Retain the configured stack size when embedded runtimes relaunch PerlOnJava, return the group name from scalar getgrgid, and parse single-quoted Windows qx arguments without sending them through cmd.exe. Preserve byte-valued characters for direct Windows child launches. Generated with [Codex](https://openai.com/codex) Co-Authored-By: Codex <158243242+codex@users.noreply.github.com> --- .../org/perlonjava/runtime/ForkOpenState.java | 17 +++++++++++++++++ .../runtime/nativ/ExtendedNativeUtils.java | 11 +++++++++-- .../runtime/operators/SystemOperator.java | 19 +++++++++++++------ 3 files changed, 39 insertions(+), 8 deletions(-) diff --git a/src/main/java/org/perlonjava/runtime/ForkOpenState.java b/src/main/java/org/perlonjava/runtime/ForkOpenState.java index 4c50e99164..e9446993f8 100644 --- a/src/main/java/org/perlonjava/runtime/ForkOpenState.java +++ b/src/main/java/org/perlonjava/runtime/ForkOpenState.java @@ -128,6 +128,11 @@ static List currentJavaCommand(String command, String[] arguments) { ? "java.exe" : "java"; List invocation = new ArrayList<>(); invocation.add(new File(new File(System.getProperty("java.home"), "bin"), javaName).getPath()); + invocation.add("-Xss16m"); + String perlJvmOptions = perlEnvironmentValue("JPERL_OPTS"); + if (perlJvmOptions != null && !perlJvmOptions.isBlank()) { + invocation.addAll(Arrays.asList(perlJvmOptions.trim().split("\\s+"))); + } invocation.add("--enable-native-access=ALL-UNNAMED"); invocation.add("-cp"); invocation.add(embeddedRuntimeClasspath()); @@ -135,6 +140,18 @@ static List currentJavaCommand(String command, String[] arguments) { return invocation; } + private static String perlEnvironmentValue(String key) { + try { + RuntimeScalar value = GlobalVariable.getGlobalHash("main::ENV").get(key); + if (value != null && value.defined().getBoolean()) { + return value.toString(); + } + } catch (RuntimeException ignored) { + // Child launch may happen outside an active Perl runtime. + } + return System.getenv(key); + } + /** * Resolve the product classpath used when an embedded runtime launches a * child PerlOnJava CLI. The host classpath may belong to a Gradle worker diff --git a/src/main/java/org/perlonjava/runtime/nativ/ExtendedNativeUtils.java b/src/main/java/org/perlonjava/runtime/nativ/ExtendedNativeUtils.java index 5d679e854a..3ba8ef17b2 100644 --- a/src/main/java/org/perlonjava/runtime/nativ/ExtendedNativeUtils.java +++ b/src/main/java/org/perlonjava/runtime/nativ/ExtendedNativeUtils.java @@ -217,8 +217,15 @@ public static RuntimeList getgrgid(int ctx, RuntimeBase... args) { int gid = args[0].scalar().getInt(); if (IS_WINDOWS) { - int currentGid = getgid(ctx).getInt(); - if (gid == currentGid) return getgrnam(ctx, new RuntimeScalar("Users")); + int currentGid = getgid(SCALAR).getInt(); + if (gid == currentGid) { + RuntimeList record = getgrnam(RuntimeContextType.LIST, new RuntimeScalar("Users")); + if (ctx == SCALAR) { + return record.elements.isEmpty() + ? new RuntimeList() : record.elements.getFirst().getList(); + } + return record; + } return new RuntimeList(); } return groupResult(groupToArray(FFMPosix.get().getgrgid(gid)), ctx, 0); diff --git a/src/main/java/org/perlonjava/runtime/operators/SystemOperator.java b/src/main/java/org/perlonjava/runtime/operators/SystemOperator.java index e85dd528a9..929584e9b2 100644 --- a/src/main/java/org/perlonjava/runtime/operators/SystemOperator.java +++ b/src/main/java/org/perlonjava/runtime/operators/SystemOperator.java @@ -173,6 +173,13 @@ public static RuntimeBase systemCommand(RuntimeScalar command, int ctx) { * not replace them while encoding the shell command. */ private static String encodeByteStringForShell(String command) { + // Windows child processes receive argv through CreateProcess's UTF-16 + // command line. Keep byte-valued characters intact so the direct + // jperl launcher path can recover them; cmd.exe octal escapes are not + // interpreted like POSIX shell escapes. + if (SystemUtils.osIsWindows()) { + return command; + } StringBuilder encoded = new StringBuilder(command.length()); boolean singleQuoted = false; boolean doubleQuoted = false; @@ -442,17 +449,17 @@ private static List splitDirectCommandWords(String command) { static List splitWindowsDirectCommandWords(String command) { List words = new ArrayList<>(); StringBuilder word = new StringBuilder(); - boolean quoted = false; + char quote = 0; boolean started = false; for (int i = 0; i < command.length(); i++) { char ch = command.charAt(i); - if (ch == '"') { - quoted = !quoted; + if ((ch == '"' || ch == '\'') && (quote == 0 || quote == ch)) { + quote = quote == 0 ? ch : 0; started = true; continue; } - if (!quoted && Character.isWhitespace(ch)) { + if (quote == 0 && Character.isWhitespace(ch)) { if (started) { words.add(word.toString()); word.setLength(0); @@ -460,14 +467,14 @@ static List splitWindowsDirectCommandWords(String command) { } continue; } - if (!quoted && "*?[]{}()<>|&;`'$%".indexOf(ch) >= 0) { + if (quote == 0 && "*?[]{}()<>|&;`$%".indexOf(ch) >= 0) { return null; } word.append(ch); started = true; } - if (quoted) { + if (quote != 0) { return null; } if (started) { From b80480f74f66fcdf979e201f4b6fdb820a7c8d22 Mon Sep 17 00:00:00 2001 From: "Flavio S. Glock" Date: Sat, 3 Oct 2026 17:25:17 +0200 Subject: [PATCH 41/41] fix: preserve byte arguments through Windows shells Encode byte-valued characters in Windows shell commands as ASCII hex markers, then restore them before Perl argument parsing. Decode markers in both launcher and embedded-runtime child processes. Generated with [Codex](https://openai.com/codex) Co-Authored-By: Codex <158243242+codex@users.noreply.github.com> --- docs/about/changelog.md | 2 +- jperl.bat | 2 +- .../java/org/perlonjava/app/cli/Main.java | 31 +++++++++++++++++++ .../org/perlonjava/runtime/ForkOpenState.java | 7 +++-- .../runtime/operators/SystemOperator.java | 12 +++---- 5 files changed, 43 insertions(+), 11 deletions(-) diff --git a/docs/about/changelog.md b/docs/about/changelog.md index 6fb56cd20e..33e3227be2 100644 --- a/docs/about/changelog.md +++ b/docs/about/changelog.md @@ -47,7 +47,7 @@ priorities and future plans. - Restore `EAGAIN` after alarm interrupts `sleep`, even when a signal handler changes `$!`. - Preserve Unicode `-s` arguments when a core test launches a nested interpreter through the shell. - Preserve non-ASCII byte arguments in unquoted shell commands and nested - PerlOnJava launches under the C locale. + PerlOnJava launches under C locales and through Windows command shells. - Apply Unicode character classes to interpolated Unicode regex patterns. - Preserve combining-mark order in Unicode uppercase mappings and honor byte-string method names in `can`. - Reject scalar constants passed to hash-reference prototypes with the expected diagnostic. diff --git a/jperl.bat b/jperl.bat index aeed1e82e5..84a5718e7b 100755 --- a/jperl.bat +++ b/jperl.bat @@ -23,7 +23,7 @@ rem for native system calls (file operations, process management). rem Perl call frames currently use the Java stack. Keep enough stack for rem ecosystem recursion guards such as Catalyst's default 1000-call limit. rem A later -Xss value in JPERL_OPTS overrides this default. -set JVM_OPTS=-Xss16m --enable-native-access=ALL-UNNAMED +set JVM_OPTS=-Xss16m --enable-native-access=ALL-UNNAMED -Dperlonjava.rawargv.hex=true rem Note on JVM heap settings: do NOT set -XX:SoftMaxHeapSize below -Xmx. rem That combination triggers an aggressive G1 GC cadence that interacts diff --git a/src/main/java/org/perlonjava/app/cli/Main.java b/src/main/java/org/perlonjava/app/cli/Main.java index db731e07b4..23a2550056 100644 --- a/src/main/java/org/perlonjava/app/cli/Main.java +++ b/src/main/java/org/perlonjava/app/cli/Main.java @@ -22,6 +22,7 @@ public class Main { private static final String RAW_ARG_HEX_PREFIX = "__PERLONJAVA_RAWARG_HEX__"; + private static final String RAW_BYTE_HEX_PREFIX = "__PERLONJAVA_RAWBYTE_HEX__"; static { // Set default locale to US (uses dot as decimal separator) @@ -110,10 +111,40 @@ private static void restoreRawByteArguments(String[] args) { String encoded = args[i].substring(RAW_ARG_HEX_PREFIX.length()); byte[] bytes = java.util.HexFormat.of().parseHex(encoded); args[i] = new String(bytes, java.nio.charset.StandardCharsets.ISO_8859_1); + } else if (args[i].contains(RAW_BYTE_HEX_PREFIX)) { + args[i] = restoreEmbeddedRawBytes(args[i]); } } } + private static String restoreEmbeddedRawBytes(String argument) { + StringBuilder restored = new StringBuilder(argument.length()); + for (int index = 0; index < argument.length();) { + int marker = argument.indexOf(RAW_BYTE_HEX_PREFIX, index); + if (marker < 0) { + restored.append(argument, index, argument.length()); + break; + } + restored.append(argument, index, marker); + int hexStart = marker + RAW_BYTE_HEX_PREFIX.length(); + if (hexStart + 2 > argument.length()) { + restored.append(RAW_BYTE_HEX_PREFIX); + index = hexStart; + continue; + } + int high = Character.digit(argument.charAt(hexStart), 16); + int low = Character.digit(argument.charAt(hexStart + 1), 16); + if (high < 0 || low < 0) { + restored.append(RAW_BYTE_HEX_PREFIX); + index = hexStart; + continue; + } + restored.append((char) ((high << 4) | low)); + index = hexStart + 2; + } + return restored.toString(); + } + private static void installThreadExitDiagnostic(PerlRuntime runtime) { Thread hook = Thread.ofPlatform().name("perlonjava-thread-exit-diagnostic") .unstarted(() -> { diff --git a/src/main/java/org/perlonjava/runtime/ForkOpenState.java b/src/main/java/org/perlonjava/runtime/ForkOpenState.java index e9446993f8..28b76ea480 100644 --- a/src/main/java/org/perlonjava/runtime/ForkOpenState.java +++ b/src/main/java/org/perlonjava/runtime/ForkOpenState.java @@ -124,10 +124,13 @@ static List currentJavaCommand(String command, String[] arguments) { // Unit tests and other embedders run PerlOnJava inside their own JVM. // Reconstruct a CLI invocation from the active Perl program instead of // accidentally re-executing the host (for example, a Gradle worker). - String javaName = System.getProperty("os.name", "").toLowerCase().contains("win") - ? "java.exe" : "java"; + boolean windows = System.getProperty("os.name", "").toLowerCase().contains("win"); + String javaName = windows ? "java.exe" : "java"; List invocation = new ArrayList<>(); invocation.add(new File(new File(System.getProperty("java.home"), "bin"), javaName).getPath()); + if (windows) { + invocation.add("-Dperlonjava.rawargv.hex=true"); + } invocation.add("-Xss16m"); String perlJvmOptions = perlEnvironmentValue("JPERL_OPTS"); if (perlJvmOptions != null && !perlJvmOptions.isBlank()) { diff --git a/src/main/java/org/perlonjava/runtime/operators/SystemOperator.java b/src/main/java/org/perlonjava/runtime/operators/SystemOperator.java index 929584e9b2..104685ba30 100644 --- a/src/main/java/org/perlonjava/runtime/operators/SystemOperator.java +++ b/src/main/java/org/perlonjava/runtime/operators/SystemOperator.java @@ -173,16 +173,10 @@ public static RuntimeBase systemCommand(RuntimeScalar command, int ctx) { * not replace them while encoding the shell command. */ private static String encodeByteStringForShell(String command) { - // Windows child processes receive argv through CreateProcess's UTF-16 - // command line. Keep byte-valued characters intact so the direct - // jperl launcher path can recover them; cmd.exe octal escapes are not - // interpreted like POSIX shell escapes. - if (SystemUtils.osIsWindows()) { - return command; - } StringBuilder encoded = new StringBuilder(command.length()); boolean singleQuoted = false; boolean doubleQuoted = false; + boolean windows = SystemUtils.osIsWindows(); boolean asciiShellLocale = !SystemUtils.osIsWindows() && usesAsciiShellLocale(); for (int i = 0; i < command.length(); i++) { char ch = command.charAt(i); @@ -207,6 +201,10 @@ private static String encodeByteStringForShell(String command) { encoded.append('0'); } encoded.append(octal); + } else if (ch >= 0x80 && ch <= 0xff && windows) { + encoded.append("__PERLONJAVA_RAWBYTE_HEX__"); + encoded.append(Character.forDigit((ch >>> 4) & 0xf, 16)); + encoded.append(Character.forDigit(ch & 0xf, 16)); } else if (ch >= 0x80 && ch <= 0xff && asciiShellLocale) { encoded.append("$(printf '\\"); String octal = Integer.toOctalString(ch);