diff --git a/dev/tools/perl_test_runner.pl b/dev/tools/perl_test_runner.pl index 31f2ce7151..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; @@ -477,7 +483,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) @@ -538,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); @@ -597,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 @@ -607,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 @@ -654,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: $!"; } @@ -682,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 2c428ef196..33e3227be2 100644 --- a/docs/about/changelog.md +++ b/docs/about/changelog.md @@ -6,6 +6,55 @@ priorities and future plans. ## Work in progress +- 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. +- 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. +- 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. +- 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. +- 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 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. +- Warn about anonymous subroutines in void context and undef dynamic code references in place. +- 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 and nested + 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. +- 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. + - Prevent stale CPAN archive-name entries and namespace-resolution errors from being recorded as compatibility regressions. 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/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 13a00953e7..23a2550056 100644 --- a/src/main/java/org/perlonjava/app/cli/Main.java +++ b/src/main/java/org/perlonjava/app/cli/Main.java @@ -21,6 +21,9 @@ */ 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) Locale.setDefault(Locale.US); @@ -91,6 +94,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 +102,49 @@ 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); + } 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/backend/bytecode/BytecodeCompiler.java b/src/main/java/org/perlonjava/backend/bytecode/BytecodeCompiler.java index 263a75ff71..b7fbf972a5 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") @@ -3906,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); @@ -4325,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. @@ -6322,7 +6337,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); @@ -9093,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(); @@ -9181,6 +9201,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/BytecodeInterpreter.java b/src/main/java/org/perlonjava/backend/bytecode/BytecodeInterpreter.java index ba6608881a..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); } } @@ -2614,6 +2616,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..dda0b14d61 100644 --- a/src/main/java/org/perlonjava/backend/bytecode/CompileAssignment.java +++ b/src/main/java/org/perlonjava/backend/bytecode/CompileAssignment.java @@ -2,6 +2,8 @@ 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; import org.perlonjava.runtime.runtimetypes.NameNormalizer; @@ -2180,6 +2182,31 @@ && 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 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); + } + 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 @@ -3051,11 +3078,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 +3101,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 +3122,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/CompileOperator.java b/src/main/java/org/perlonjava/backend/bytecode/CompileOperator.java index 6c4ae3487c..e9fd392a06 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(); @@ -1515,7 +1519,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); @@ -1674,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/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/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/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/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/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/backend/jvm/EmitVariable.java b/src/main/java/org/perlonjava/backend/jvm/EmitVariable.java index ac87d34f0f..143167a816 100644 --- a/src/main/java/org/perlonjava/backend/jvm/EmitVariable.java +++ b/src/main/java/org/perlonjava/backend/jvm/EmitVariable.java @@ -7,6 +7,8 @@ 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; import org.perlonjava.runtime.perlmodule.Strict; @@ -882,6 +884,33 @@ 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()) { + // `() = 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)); + 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 @@ -1310,7 +1339,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(); @@ -2822,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/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/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/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/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/OperatorParser.java b/src/main/java/org/perlonjava/frontend/parser/OperatorParser.java index 4c18cea3ea..02c9158fed 100644 --- a/src/main/java/org/perlonjava/frontend/parser/OperatorParser.java +++ b/src/main/java/org/perlonjava/frontend/parser/OperatorParser.java @@ -1458,9 +1458,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()) { @@ -1482,7 +1494,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/ParseInfix.java b/src/main/java/org/perlonjava/frontend/parser/ParseInfix.java index f4903f3a70..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 @@ -639,6 +640,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 +816,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/main/java/org/perlonjava/frontend/parser/ParsePrimary.java b/src/main/java/org/perlonjava/frontend/parser/ParsePrimary.java index fd65e2368d..76794713a3 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: @@ -761,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 { @@ -802,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/frontend/parser/PrototypeArgs.java b/src/main/java/org/perlonjava/frontend/parser/PrototypeArgs.java index a7f86e8c29..f5f792b4df 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); @@ -1431,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/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/frontend/parser/StatementResolver.java b/src/main/java/org/perlonjava/frontend/parser/StatementResolver.java index 2c36efc73c..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 @@ -1447,8 +1469,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 +1479,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/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/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/ForkOpenState.java b/src/main/java/org/perlonjava/runtime/ForkOpenState.java index 4c50e99164..28b76ea480 100644 --- a/src/main/java/org/perlonjava/runtime/ForkOpenState.java +++ b/src/main/java/org/perlonjava/runtime/ForkOpenState.java @@ -124,10 +124,18 @@ 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()) { + invocation.addAll(Arrays.asList(perlJvmOptions.trim().split("\\s+"))); + } invocation.add("--enable-native-access=ALL-UNNAMED"); invocation.add("-cp"); invocation.add(embeddedRuntimeClasspath()); @@ -135,6 +143,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/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/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/nativ/ExtendedNativeUtils.java b/src/main/java/org/perlonjava/runtime/nativ/ExtendedNativeUtils.java index 9815b79d57..3ba8ef17b2 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,55 @@ 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(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); + } - 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 +266,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 +286,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 +304,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/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/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/operators/IOOperator.java b/src/main/java/org/perlonjava/runtime/operators/IOOperator.java index 0682203f2f..180e76bca5 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(); @@ -597,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"); } @@ -698,7 +721,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 +1170,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 +1195,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; @@ -2859,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); @@ -2877,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/operators/Operator.java b/src/main/java/org/perlonjava/runtime/operators/Operator.java index 9044bfd1a9..1ef07b184f 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); }; @@ -865,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); } @@ -906,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/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/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/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/operators/SystemOperator.java b/src/main/java/org/perlonjava/runtime/operators/SystemOperator.java index de2f97a06c..104685ba30 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; @@ -166,22 +167,51 @@ 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 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()); + 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); - 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++) { 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); + for (int pad = octal.length(); pad < 3; pad++) { + encoded.append('0'); + } + encoded.append(octal).append("')"); } else { encoded.append(ch); } @@ -189,6 +219,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. @@ -204,7 +245,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; @@ -402,17 +447,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); @@ -420,14 +465,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) { @@ -854,14 +899,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; @@ -955,8 +997,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 @@ -1010,8 +1055,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; @@ -1113,6 +1161,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/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 f261d437fd..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; @@ -82,11 +83,35 @@ 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. + 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/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/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/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/main/java/org/perlonjava/runtime/regex/RuntimeRegex.java b/src/main/java/org/perlonjava/runtime/regex/RuntimeRegex.java index fdecb6d34d..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); @@ -3772,6 +3773,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/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/main/java/org/perlonjava/runtime/runtimetypes/ExecutionRuntimeState.java b/src/main/java/org/perlonjava/runtime/runtimetypes/ExecutionRuntimeState.java index a50f984eee..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; @@ -55,7 +56,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<>(); @@ -72,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<>(); @@ -83,8 +85,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/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/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/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/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/main/java/org/perlonjava/runtime/runtimetypes/RuntimeCode.java b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeCode.java index 7892aba3b1..9133b59a48 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"); } @@ -818,9 +846,51 @@ 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; } + /** 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(); + 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; + } + } + 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 @@ -1423,6 +1493,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) { @@ -1754,6 +1843,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). @@ -1835,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}). @@ -2103,6 +2196,9 @@ public void unbindActiveLexical(String variableName, RuntimeBase cell) { return; } } + if (runtime.executionState().topLevelLexicals.get(variableName) == cell) { + runtime.executionState().topLevelLexicals.remove(variableName); + } } /** @@ -2503,8 +2599,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(); @@ -2846,7 +2941,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) { @@ -3013,10 +3108,12 @@ 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) { + code.codeReferenceUndefined = codeFrom.codeReferenceUndefined; code.prototype = codeFrom.prototype; code.attributes = codeFrom.attributes; code.methodHandle = codeFrom.methodHandle; @@ -3061,6 +3158,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; @@ -3092,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; @@ -3449,11 +3548,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; @@ -4031,11 +4127,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; @@ -4131,10 +4224,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); } @@ -5474,7 +5565,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; } } @@ -5877,6 +5971,13 @@ private static String callerSubNameForCode(RuntimeCode code) { } return null; } + if (code.hadStashRef && code.explicitlyMaterializedGlob && !code.explicitlyRenamed + && GlobalVariable.findGlobalCodeRefName(code) == null) { + // 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("::")) { return code.subName; } @@ -5887,6 +5988,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.explicitlyMaterializedGlob && !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 @@ -6272,10 +6392,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 +6663,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 +7459,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 +7811,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 +8283,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 +8313,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 +8477,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 +8638,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); @@ -8770,6 +8932,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/main/java/org/perlonjava/runtime/runtimetypes/RuntimeFormat.java b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeFormat.java index 87d628cc18..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,16 +637,47 @@ 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) { - if (!(value instanceof String name) || isPackageVariable(name)) continue; + 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); 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; + } WarnDie.warn(new RuntimeScalar("Variable \"" + name + "\" is not available at format " + formatName + "\n"), new RuntimeScalar("")); @@ -642,12 +685,23 @@ 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) { + // activeLexicals contains only the format's declaring CV, + // so this is the current invocation's lexical pad. lexicalVariables.put(name, active); - } else if (!(argLine.getAnnotation("unavailableLexicalVariableNames") instanceof List unavailable - && unavailable.contains(name)) - && !isPackageVariable(name) + } 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/main/java/org/perlonjava/runtime/runtimetypes/RuntimeGlob.java b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeGlob.java index 7f97e689f5..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); @@ -977,6 +980,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/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/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/main/java/org/perlonjava/runtime/runtimetypes/RuntimeIO.java b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeIO.java index 5877ace4ab..60163ffef3 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(); @@ -307,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/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/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/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/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/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/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/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'); 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 ｍａｉｎ; +my @c; +sub ｆｏｏ { @c = caller(0) } +{ + no strict 'refs'; + no warnings 'utf8'; + () = *{"ｆｏｏ"}; +} +my $fooref = delete $ｍａｉｎ::{ｆｏｏ}; +$fooref->(); +::is($c[3], "ｍａｉｎ::__ANON__", 'deleted named CV is reported as anonymous'); 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/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"); 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(); 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/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'); 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'); 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'); 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'); 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/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'); +} 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(); 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/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/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'); 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'); 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'); 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/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(); 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'); + } +} 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'); 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: $!"; 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..91a4191b45 --- /dev/null +++ b/src/test/resources/unit/posix_group_lookup.t @@ -0,0 +1,52 @@ +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'; +} + +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(); 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'); 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(); 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; 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'); 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/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'); 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'); +} 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'); 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/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/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'); 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'); 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/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'); 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(); 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/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'; 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'); 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(); 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(); 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;