diff --git a/docs/about/changelog.md b/docs/about/changelog.md index 237e687098..2930d4511a 100644 --- a/docs/about/changelog.md +++ b/docs/about/changelog.md @@ -19,6 +19,21 @@ priorities and future plans. - Complete `tr///` compatibility for extended Unicode and surrogate scalars, identity lvalues, and `chop`/`chomp` diagnostics on both execution backends. +- Reject Unicode named sequences in transliteration operands and preserve the + Perl foreach-entry diagnostic for shadowing `goto` labels inside `eval`. + +- Avoid materializing a key list when bytecode evaluates `keys %hash` in scalar + context, restoring empty-hash performance for repeated hash-count queries. + +- Reset embedded-script readline state between top-level programs and include + the nested-class fixture required by the standalone unit-test corpus. + +- Preserve literal exclamation marks in multiline `-e` arguments when Windows + dispatches a child `jperl` process without invoking its batch launcher. + +- Improve Perl-compatible compiler diagnostics for unterminated quoted strings + and here-document delimiters. + - Restore `local` compatibility for tied hash and array elements, sparse arrays, magic stashes, implicit `$_` foreach aliases (including early return), and localized regex captures on both execution backends. @@ -34,6 +49,36 @@ priorities and future plans. - Keep debugger EOF from terminating embedded Gradle test workers on Windows. + +- Restore source-scoped eval diagnostic numbering; reject Unicode punctuation + in lexical declarations; diagnose invalid `delete` and `exists` targets; and + report clean control-flow errors from `defer` and `finally` blocks. Require + block arguments for feature-gated `all` and `any` keywords, with + Perl-compatible syntax diagnostics, and diagnose invalid indirect arguments + to `return` without rejecting valid return statement modifiers. Reject + reference-valued `bless` class names, including values from tied scalars. + Diagnose `when` and `default` used outside a `given` topicalizer. + Reject assignments to unknown `%SIG` hooks and diagnose defined assignments + to the removed `${^ENCODING}` special variable. + Reject assignments of Perl class objects to typeglobs. + Diagnose aggregate operands to numeric and string bitwise assignments. + Diagnose aggregate lvalues passed to `substr` and `vec`. + Report Perl-compatible hash, private-hash, and typeglob diagnostics for + invalid `push`, `pop`, `shift`, and `unshift` operands, including every + direct invalid operation in a compilation. + Report undefined hash-reference diagnostics when aggregate values are used + as hash references. + Preserve mismatched array and hash literal delimiters in syntax-error + context, matching Perl's diagnostics. + Report evaluated missing labels for the legacy `CORE::dump` operator. + Report Perl-compatible undefined subroutine-reference errors for ordinary + and tied scalar codereferences. + Reject attempts to reopen active filehandles as directory handles (and vice + versa), with Perl-compatible lexical and Unicode handle diagnostics. + Report Perl-compatible UTF-8-layer errors from `sysread` and `syswrite`. + Reject non-reference and wrong-reference-type values in declared-reference + `foreach` iterators with Perl-compatible diagnostics. + - Avoid transient helper allocation while counting ordinary Perl UTF strings. - Reuse static literal regular-expression match wrappers per runtime and call @@ -96,7 +141,8 @@ priorities and future plans. closure capture, and experimental `@_` warnings. - Preserve state-variable initialization across `goto` loops after nested - closure compilation. + closure compilation and parenthesized logical defaults on both execution + backends. - Preserve async Future ownership across interpreter suspension and resume. diff --git a/src/main/java/org/perlonjava/app/scriptengine/PerlLanguageProvider.java b/src/main/java/org/perlonjava/app/scriptengine/PerlLanguageProvider.java index 2343f07181..4eaec562c9 100644 --- a/src/main/java/org/perlonjava/app/scriptengine/PerlLanguageProvider.java +++ b/src/main/java/org/perlonjava/app/scriptengine/PerlLanguageProvider.java @@ -116,6 +116,7 @@ public static void resetAll() { // engine resets run multiple top-level programs in one JVM, so give // the next program a fresh wrapper around the process standard input. RuntimeIO.setStdin(new RuntimeIO(new StandardIO(System.in))); + RuntimeIO.resetLastReadlineHandle(); DataSection.reset(); } } @@ -653,12 +654,10 @@ private static RuntimeList executeCodeImpl(RuntimeCode runtimeCode, Node ast, Em // internal control-flow marker. result = RuntimeCode.resolveTailCalls(result, executionContext); - // A labelled goto that reaches the outermost execution boundary - // has no remaining lexical scope in which it can be resolved. - // Do not silently return its marker as the program result: Perl - // reports the missing label at this point. - if (isMainProgram && result instanceof RuntimeControlFlowList flow - && flow.getControlFlowType() == ControlFlowType.GOTO) { + // A non-local control marker that reaches the outermost execution + // boundary has no remaining lexical scope in which it can be + // resolved. Do not silently return it as the program result. + if (isMainProgram && result instanceof RuntimeControlFlowList flow) { throw new PerlCompilerException(flow.marker.buildErrorMessage()); } diff --git a/src/main/java/org/perlonjava/backend/bytecode/BytecodeCompiler.java b/src/main/java/org/perlonjava/backend/bytecode/BytecodeCompiler.java index f75d71fb7c..d1510a7698 100644 --- a/src/main/java/org/perlonjava/backend/bytecode/BytecodeCompiler.java +++ b/src/main/java/org/perlonjava/backend/bytecode/BytecodeCompiler.java @@ -100,6 +100,30 @@ private static void collectConstructEntryLabels(Node node, Set out, bool } } + /** Record labels in given blocks; entering one skips topicalizer setup. */ + private static void collectGivenLabels(Node node, Set out, boolean insideGiven) { + if (node == null) return; + if (node instanceof LabelNode labelNode) { + if (insideGiven) out.add(labelNode.label); + return; + } + if (node instanceof BlockNode block) { + boolean nestedGiven = insideGiven || block.getBooleanAnnotation("givenBlock"); + if (nestedGiven) out.addAll(block.labels); + for (Node child : block.elements) collectGivenLabels(child, out, nestedGiven); + return; + } + if (node instanceof IfNode conditional) { + collectGivenLabels(conditional.condition, out, insideGiven); + collectGivenLabels(conditional.thenBranch, out, insideGiven); + collectGivenLabels(conditional.elseBranch, out, insideGiven); + return; + } + if (node instanceof OperatorNode operator) { + collectGivenLabels(operator.operand, out, insideGiven); + } + } + private static void markGotosInLoopConditions(Node node) { if (node == null) return; if (node instanceof For3Node loop) { @@ -177,6 +201,8 @@ private void registerGotoLoopRanges(int bodyStartPc, int bodyEndPc) { final Map gotoLabelPcs = new HashMap<>(); final Set gotoLabelsInsideLoop = new HashSet<>(); final Set gotoLabelsInsideConstruct = new HashSet<>(); + final Set gotoLabelsInsideGiven = new HashSet<>(); + private int givenBlockDepth; final Map gotoLabelLoopRanges = new HashMap<>(); final Map gotoLabelPackages = new HashMap<>(); static final class GotoLabelTarget { @@ -206,7 +232,21 @@ static final class GotoLabelTarget { private void pushGotoLabelScope(BlockNode block) { Map scope = new LinkedHashMap<>(); - for (String name : block.labels) scope.put(name, new GotoLabelTarget(name, -1, false, false, block)); + // Reuse the predeclared targets, rather than inventing a second target + // for the same source label. Static goto resolution must first choose + // the nearest lexical block; a global source-position heuristic sends + // a goto back into an inner loop when labels share a name. + for (Map.Entry> entry : gotoLabelTargetsByName.entrySet()) { + for (GotoLabelTarget target : entry.getValue()) { + if (target.owner == block) { + scope.putIfAbsent(entry.getKey(), target); + break; + } + } + } + for (String name : block.labels) { + scope.putIfAbsent(name, new GotoLabelTarget(name, -1, false, false, block)); + } gotoLabelScopes.push(scope); gotoLabelBlockScopes.push(block); } @@ -214,6 +254,7 @@ private void pushGotoLabelScope(BlockNode block) { private void popGotoLabelScope() { gotoLabelScopes.pop(); gotoLabelBlockScopes.pop(); } boolean isInsideGotoLabelBlock(BlockNode block) { return block != null && gotoLabelBlockScopes.contains(block); } + boolean isInsideGivenBlock() { return givenBlockDepth > 0; } GotoLabelTarget resolveStaticGotoTarget(String name) { for (Map scope : gotoLabelScopes) { @@ -224,7 +265,19 @@ GotoLabelTarget resolveStaticGotoTarget(String name) { } GotoLabelTarget resolveStaticGotoTarget(String name, int sourceTokenIndex) { + GotoLabelTarget scoped = resolveStaticGotoTarget(name); List candidates = gotoLabelTargetsByName.get(name); + // eval BLOCK shares its caller's control-flow frame. If the eval + // contains a foreach-body label with this name, that shadowing label + // is the destination even when a later outer label is numerically + // closer in the source. Choosing the latter used to bypass the + // foreach-entry guard and jump to the outer label instead. + if (evalBlockDepth > 0 && candidates != null) { + for (GotoLabelTarget candidate : candidates) { + if (candidate.loopBody) return candidate; + } + } + if (scoped != null) return scoped; if (candidates == null || candidates.isEmpty()) return resolveStaticGotoTarget(name); GotoLabelTarget result = null; long bestDistance = Long.MAX_VALUE; @@ -257,6 +310,19 @@ private void predeclareGotoLabels(Node node, boolean expressionContext, boolean boolean constructEntry = expressionContext && !block.getBooleanAnnotation("fieldInitializer"); Map local = new HashMap<>(); + // StatementParser keeps labels that prefix a statement in the + // owning block's label table. They have no LabelNode child, but + // must still be visible to a forward goto outside that block. + // In particular, this lets the existing foreach-entry guard + // report the Perl diagnostic instead of falling through to + // "Can't find label". + for (String name : block.labels) { + GotoLabelTarget created = new GotoLabelTarget(name, block.getIndex(), + constructEntry, insideLoopBody, block); + local.put(name, created); + gotoLabelTargetsByName.computeIfAbsent(name, + ignoredName -> new ArrayList<>()).add(created); + } for (Node child : block.elements) { if (!(child instanceof LabelNode label)) continue; GotoLabelTarget target = local.computeIfAbsent(label.label, ignored -> { @@ -431,6 +497,8 @@ private void emitNormalLoopResult() { private int maxRegisterEverUsed = 2; // Track highest register ever allocated // True when this compiler was constructed for eval STRING (has parentRegistry) private boolean isEvalString; + boolean isSubroutineBody; + boolean isSmartmatchPredicate; // Runtime regex interpolation can synthesize executable source through // overload, so the containing CV must expose all of its live lexical cells. private boolean tracksRuntimeRegexLexicals; @@ -1134,11 +1202,20 @@ void throwCompilerException(String message) { */ void checkNotInDeferBlock(int tokenIndex, String operator) { if (isInDeferBlock) { - throwCompilerException("Can't \"" + operator + "\" out of a \"defer\" block", tokenIndex); + throwCleanCompilerException("Can't \"" + operator + "\" out of a \"defer\" block", tokenIndex); } if (finallyBlockDepth > 0) { - throwCompilerException("Can't \"" + operator + "\" out of a \"finally\" block", tokenIndex); + throwCleanCompilerException("Can't \"" + operator + "\" out of a \"finally\" block", tokenIndex); + } + } + + void throwCleanCompilerException(String message, int tokenIndex) { + if (errorUtil != null && tokenIndex >= 0) { + var location = errorUtil.getSourceLocationAccurate(tokenIndex); + throw new PerlCompilerException(message + " at " + location.fileName() + + " line " + location.lineNumber() + ".\n"); } + throw new PerlCompilerException(message); } /** @@ -1193,6 +1270,7 @@ public InterpretedCode compile(Node node, EmitterContext ctx) { collectLoopBodyLabels(node, gotoLabelsInsideLoop, false); collectConstructEntryLabels(node, gotoLabelsInsideConstruct, false); + collectGivenLabels(node, gotoLabelsInsideGiven, false); predeclareGotoLabels(node, false, false); markGotosInLoopConditions(node); @@ -1350,6 +1428,9 @@ public InterpretedCode compile(Node node, EmitterContext ctx) { if (!this.gotoLabelsInsideConstruct.isEmpty()) { code.gotoLabelsInsideConstruct = new HashSet<>(this.gotoLabelsInsideConstruct); } + if (!this.gotoLabelsInsideGiven.isEmpty()) { + code.gotoLabelsInsideGiven = new HashSet<>(this.gotoLabelsInsideGiven); + } if (!this.gotoLabelLoopRanges.isEmpty()) { code.gotoLabelLoopRanges = new HashMap<>(this.gotoLabelLoopRanges); } @@ -1604,6 +1685,7 @@ public void visit(BlockNode node) { } pushGotoLabelScope(node); + if (node.getBooleanAnnotation("givenBlock")) givenBlockDepth++; enterScope(); int regexSaveReg = -1; @@ -1854,6 +1936,7 @@ public void visit(BlockNode node) { emitRefreshVisibleOurVariables(); } + if (node.getBooleanAnnotation("givenBlock")) givenBlockDepth--; popGotoLabelScope(); // Set lastResultReg to the outer register (or -1 if VOID context) lastResultReg = outerResultReg; @@ -2923,6 +3006,19 @@ private int compileLhsForCompoundAssignment(BinaryOperatorNode node) { int targetReg; Node left = scalarizeSingleElementSliceLvalue(node.left); + // Match the JVM backend: a parenthesized single-target state + // declaration is a scalar lvalue for logical assignment, not a list + // target. Keeping the ListNode would assign to a temporary list and + // leave the state scalar undef on every call. + if (left instanceof OperatorNode declaration + && "state".equals(declaration.operator) + && declaration.operand instanceof ListNode list + && list.elements.size() == 1 + && list.elements.getFirst() instanceof OperatorNode target + && "$@%".contains(target.operator)) { + left = new OperatorNode("state", target, declaration.tokenIndex); + } + if (left instanceof ListNode listNode && listNode.elements.size() == 1) { compileNode(listNode.elements.get(0), -1, RuntimeContextType.LVALUE); return lastResultReg; @@ -2959,7 +3055,7 @@ private int compileLhsForCompoundAssignment(BinaryOperatorNode node) { } } else { // Other operator (not simple variable) - compile as lvalue expression - compileNode(node.left, -1, RuntimeContextType.LVALUE); + compileNode(left, -1, RuntimeContextType.LVALUE); targetReg = lastResultReg; } } else { @@ -3428,7 +3524,7 @@ void compileVariableDeclaration(OperatorNode node, String op) { if (beginId != null) { // BEGIN-captured variable: use RETRIEVE_BEGIN_* (destructive removal from global storage) int persistId = beginId; - int reg = allocateRegister(); + int reg = op.equals("state") ? allocateStateVariableRegister() : allocateRegister(); int nameIdx = addToStringPool(varName); switch (sigil) { @@ -3482,7 +3578,7 @@ void compileVariableDeclaration(OperatorNode node, String op) { // State variable without initializer: use STATE_INIT_* (non-destructive) // This preserves the variable across subroutine calls int persistId = sigilOp.id; - int reg = allocateRegister(); + int reg = allocateStateVariableRegister(); int nameIdx = addToStringPool(varName); // Allocate a register for the undef/empty initial value @@ -3859,7 +3955,7 @@ void compileVariableDeclaration(OperatorNode node, String op) { Integer beginId2 = RuntimeCode.evalBeginIds().get(sigilOp); if (beginId2 != null || op.equals("state")) { int persistId = beginId2 != null ? beginId2 : sigilOp.id; - int reg = allocateRegister(); + int reg = op.equals("state") ? allocateStateVariableRegister() : allocateRegister(); int nameIdx = addToStringPool(varName); switch (sigil) { @@ -5349,6 +5445,19 @@ void compileVariableReference(OperatorNode node, String op) { // Check strict refs at compile time — mirrors JVM path in EmitVariable.java compileNode(block, -1, RuntimeContextType.SCALAR); int blockResultReg = lastResultReg; + // A block may return a typeglob assignment such as + // `${*name = \$value}`. Block-scope register recycling can + // immediately reuse a temporary which is also the scalar-slot + // referent. Materialize the result as a scalar first, just as + // assigning that glob result to a lexical does, before the + // dereference reads its slot. + int stableBlockResultReg = allocateRegister(); + emit(Opcodes.LOAD_UNDEF); + emitReg(stableBlockResultReg); + emit(Opcodes.SET_SCALAR); + emitReg(stableBlockResultReg); + emitReg(blockResultReg); + blockResultReg = stableBlockResultReg; int rd = allocateOutputRegister(); if (isStrictRefsEnabled()) { // strict refs: scalarDeref() — throws for non-refs @@ -5682,10 +5791,18 @@ void compileVariableReference(OperatorNode node, String op) { int rd = allocateOutputRegister(); int nameIdx = addToStringPool(subName); int cacheIdx = addToConstantPool(new RuntimeScalar()); + Object classMethod = node.getAnnotation("directClassMethod"); + int classNameIdx = classMethod instanceof String className + ? addToStringPool(className) : -1; + Object precedingLabel = node.getAnnotation("precedingLabel"); + int labelIdx = precedingLabel instanceof String label + ? addToStringPool(label) : -1; emit(Opcodes.DIRECT_NAMED_CODE_CALL); emitReg(rd); emit(nameIdx); emit(cacheIdx); + emit(classNameIdx); + emit(labelIdx); lastResultReg = rd; return; } @@ -5790,7 +5907,18 @@ void compileVariableReference(OperatorNode node, String op) { ? RuntimeContextType.SCALAR : RuntimeContextType.LIST; int valueReg; - if (node.operand instanceof StringNode stringNode && !stringNode.isVString) { + if (node.operand instanceof IdentifierNode identifierNode) { + // A bare identifier under refgen is a bareword literal: + // \_ means a reference to the scalar string "_", not a + // reference to @_ merely because the caller frame owns + // that implicitly named array. Generic IdentifierNode + // compilation searches sigil-prefixed pad entries, which + // is correct for variable syntax but not refgen barewords. + valueReg = allocateRegister(); + emit(Opcodes.LOAD_STRING); + emitReg(valueReg); + emit(addToStringPool(identifierNode.name)); + } else if (node.operand instanceof StringNode stringNode && !stringNode.isVString) { boolean byteString = !stringNode.forceUnicodeString && (stringNode.forceByteString || isAsciiOnly(stringNode.value)); if (!stringNode.forceUnicodeString && !byteString @@ -5919,6 +6047,17 @@ int allocateRegister() { return reg; } + /** + * Allocate storage for a state lexical without reusing a temporary from + * an earlier statement. A goto may skip the declaration and a later redo + * can then read that lexical before its declaration executes; it must see + * an uninitialized state cell, never a stale condition temporary. + */ + int allocateStateVariableRegister() { + nextRegister = Math.max(nextRegister, maxRegisterEverUsed + 1); + return allocateRegister(); + } + /** * Allocate a unique callsite ID for /o modifier support. * Each callsite with /o gets a unique ID so the pattern is compiled only once per callsite. @@ -6469,6 +6608,8 @@ private void visitNamedSubroutine(SubroutineNode node) { // The parentRegistry constructor sets isEvalString=true (for eval STRING closures), // but named subs are NOT eval strings - clear the flag. subCompiler.isEvalString = false; + subCompiler.isSubroutineBody = true; + subCompiler.isSmartmatchPredicate = node.getBooleanAnnotation("smartmatchPredicate"); subCompiler.symbolTable.setCurrentPackage(getCurrentPackage(), symbolTable.currentPackageIsClass()); @@ -6487,6 +6628,12 @@ private void visitNamedSubroutine(SubroutineNode node) { subCode.futureAsyncAwaitSub = node.getBooleanAnnotation("futureAsyncAwaitSub"); subCode.futureAsyncAwaitFutureClass = (String) node.getAnnotation("futureAsyncAwaitFutureClass"); + subCode.generatedClassConstructor = node.getBooleanAnnotation("generatedClassConstructor") + || (node.block instanceof AbstractNode blockNode + && blockNode.getBooleanAnnotation("generatedClassConstructor")); + subCode.classAdjustBlock = node.getBooleanAnnotation("classAdjustBlock") + || (node.block instanceof AbstractNode blockNode + && blockNode.getBooleanAnnotation("classAdjustBlock")); copySignatureMetadata(subCode, node.block); attachDeparseSourceSpan(subCode, node); @@ -6588,6 +6735,8 @@ private void visitAnonymousSubroutine(SubroutineNode node) { // The parentRegistry constructor sets isEvalString=true (for eval STRING closures), // but anonymous subs are NOT eval strings - clear the flag. subCompiler.isEvalString = false; + subCompiler.isSubroutineBody = true; + subCompiler.isSmartmatchPredicate = node.getBooleanAnnotation("smartmatchPredicate"); subCompiler.symbolTable.setCurrentPackage(getCurrentPackage(), symbolTable.currentPackageIsClass()); @@ -7010,6 +7159,23 @@ public void visit(For1Node node) { && sigilOp.operand instanceof IdentifierNode) { referenceAliasedVariable = sigilOp; } + if (referenceAliasedVariable == null && node.variable instanceof OperatorNode referenceOp + && referenceOp.operator.equals("\\") + && referenceOp.operand instanceof OperatorNode declaration + && (declaration.operator.equals("my") || declaration.operator.equals("our") + || declaration.operator.equals("state")) + && declaration.operand instanceof OperatorNode sigilOp + && (sigilOp.operator.equals("$") || sigilOp.operator.equals("@") || sigilOp.operator.equals("%")) + && sigilOp.operand instanceof IdentifierNode) { + referenceAliasedVariable = sigilOp; + } + if (referenceAliasedVariable == null && node.variable instanceof OperatorNode declaration + && declaration.operator.equals("my") + && declaration.getBooleanAnnotation("isDeclaredReference") + && declaration.operand instanceof OperatorNode sigilOp + && (sigilOp.operator.equals("$") || sigilOp.operator.equals("@") || sigilOp.operator.equals("%"))) { + referenceAliasedVariable = sigilOp; + } if (globalLoopVarName == null && node.variable instanceof OperatorNode declaration && declaration.operator.equals("my") && declaration.operand instanceof ListNode variables) { @@ -7282,15 +7448,15 @@ public void visit(For1Node node) { emitReg(referenceReg); emitReg(iterReg); if (referenceAliasedVariable.operator.equals("$")) { - emitWithToken(Opcodes.DEREF_SCALAR_STRICT, node.getIndex()); + emitWithToken(Opcodes.FOREACH_DEREF_SCALAR, referenceAliasedVariable.getIndex()); emitReg(varReg); emitReg(referenceReg); } else if (referenceAliasedVariable.operator.equals("@")) { - emitWithToken(Opcodes.DEREF_ARRAY, node.getIndex()); + emitWithToken(Opcodes.FOREACH_DEREF_ARRAY, referenceAliasedVariable.getIndex()); emitReg(varReg); emitReg(referenceReg); } else { - emitWithToken(Opcodes.DEREF_HASH, node.getIndex()); + emitWithToken(Opcodes.FOREACH_DEREF_HASH, referenceAliasedVariable.getIndex()); emitReg(varReg); emitReg(referenceReg); } @@ -8070,8 +8236,13 @@ public void visit(DeferNode node) { @Override public void visit(LabelNode node) { int pc = bytecode.size(); - GotoLabelTarget target = gotoLabelTargetsByToken.get(node.getIndex()); - if (target == null) target = resolveStaticGotoTarget(node.label); + // The active lexical scope may contain a target created after a + // folding pass cloned this block. Bind that scope's target here so + // its pending static gotos receive this PC; otherwise their initial + // zero placeholder jumps to the program start. Prefer the scope over + // the prepass's token table, whose owner can be the pre-fold clone. + GotoLabelTarget target = resolveStaticGotoTarget(node.label); + if (target == null) target = gotoLabelTargetsByToken.get(node.getIndex()); if (target == null) { target = new GotoLabelTarget(node.label, node.getIndex(), false, false, null); } @@ -8440,6 +8611,12 @@ void handleLoopControlOperator(OperatorNode node, String op) { } if (targetLoop == null) { + // A normal subroutine cannot direct loop control at its caller. + // Eval STRING intentionally carries a marker to its lexical + // caller, where the surrounding loop is resolved. + if (isSmartmatchPredicate) { + throwCleanCompilerException("Can't \"" + op + "\" outside a loop block", node.getIndex()); + } // No matching loop found - non-local control flow // Emit CREATE_LAST/NEXT/REDO + RETURN to propagate via RuntimeControlFlowList short createOp = op.equals("last") ? Opcodes.CREATE_LAST diff --git a/src/main/java/org/perlonjava/backend/bytecode/BytecodeInterpreter.java b/src/main/java/org/perlonjava/backend/bytecode/BytecodeInterpreter.java index 76eaa1f8b8..4c1c541da5 100644 --- a/src/main/java/org/perlonjava/backend/bytecode/BytecodeInterpreter.java +++ b/src/main/java/org/perlonjava/backend/bytecode/BytecodeInterpreter.java @@ -31,10 +31,21 @@ public class BytecodeInterpreter { /** A loop-entry restriction belongs to the resolved destination, not to * every unrelated label with the same spelling elsewhere in the frame. */ - private static boolean jumpsIntoUnenteredLoopBody(InterpretedCode code, String label, int targetPc) { + private static boolean jumpsIntoUnenteredLoopBody(InterpretedCode code, String label, int targetPc, + int sourcePc) { if (code.gotoLabelLoopRanges == null) return false; int[] range = code.gotoLabelLoopRanges.get(label); - return range != null && targetPc >= range[0] && targetPc < range[1]; + // A computed goto may target a label in the current foreach body. Its + // iterator and control-block state are already active in that case; + // only an entry from outside the range is forbidden. + return range != null && targetPc >= range[0] && targetPc < range[1] + && (sourcePc < range[0] || sourcePc >= range[1]); + } + + private static void rejectGotoIntoGiven(InterpretedCode code, String label) { + if (code.gotoLabelsInsideGiven != null && code.gotoLabelsInsideGiven.contains(label)) { + throw new PerlCompilerException("Can't \"goto\" into a \"given\" block"); + } } private static void enterGotoLabelPackage(InterpretedCode code, int targetPc) { @@ -733,9 +744,14 @@ private static RuntimeList execute(SuspendedInterpreterFrame frame) { // Bare `goto` without label - runtime error like Perl 5 throw new PerlCompilerException("goto must have label"); } + rejectGotoIntoGiven(code, labelName); if (code.gotoLabelPcs != null) { Integer targetPc = code.gotoLabelPcs.get(labelName); if (targetPc != null) { + if (jumpsIntoUnenteredLoopBody(code, labelName, targetPc, pc)) { + throw new PerlCompilerException( + "Can't \"goto\" into the middle of a foreach loop"); + } if (code.gotoLabelsInsideConstruct != null && code.gotoLabelsInsideConstruct.contains(labelName)) { throw new PerlCompilerException( @@ -746,6 +762,15 @@ private static RuntimeList execute(SuspendedInterpreterFrame frame) { break; } } + // Parser-attached statement labels can be classified as + // loop-body labels before they acquire an executable PC. + // Preserve the foreach-entry diagnostic when no target PC + // is available to establish that this jump is already inside. + if (code.gotoLabelsInsideLoop != null + && code.gotoLabelsInsideLoop.contains(labelName)) { + throw new PerlCompilerException( + "Can't \"goto\" into the middle of a foreach loop"); + } if (code.isSortComparator) { throw new PerlCompilerException( "Can't \"goto\" out of a pseudo block at " @@ -965,14 +990,24 @@ private static RuntimeList execute(SuspendedInterpreterFrame frame) { case Opcodes.APPLY_LEXICAL_ALIAS -> { int reg = bytecode[pc++]; int nameIdx = bytecode[pc++]; + String variableName = code.stringPool[nameIdx]; registers[reg] = code.resolveLexicalAlias( - code.stringPool[nameIdx], registers[reg]); + variableName, registers[reg]); + if (registers[reg] instanceof RuntimeScalar scalar + && variableName.startsWith("$")) { + scalar.setLexicalDisplayName(variableName); + } } case Opcodes.BIND_ACTIVE_LEXICAL -> { int reg = bytecode[pc++]; int nameIdx = bytecode[pc++]; - code.bindActiveLexical(code.stringPool[nameIdx], registers[reg]); + String variableName = code.stringPool[nameIdx]; + code.bindActiveLexical(variableName, registers[reg]); + if (registers[reg] instanceof RuntimeScalar scalar + && variableName.startsWith("$")) { + scalar.setLexicalDisplayName(variableName); + } } // ================================================================= @@ -1437,7 +1472,7 @@ private static RuntimeList execute(SuspendedInterpreterFrame frame) { // TYPE AND REFERENCE OPERATORS (opcodes 102-105) - Delegated // ================================================================= - case Opcodes.DEFINED, Opcodes.DEFINED_CODE, Opcodes.DEFINED_CODE_DYNAMIC, Opcodes.DEFINED_GLOB, Opcodes.REF, Opcodes.BLESS, Opcodes.ISA, Opcodes.SMARTMATCH, Opcodes.PROTOTYPE, + case Opcodes.DEFINED, Opcodes.DEFINED_CODE, Opcodes.DEFINED_CODE_DYNAMIC, Opcodes.DEFINED_GLOB, Opcodes.REF, Opcodes.BLESS, Opcodes.BLESS_CLASS_INSTANCE, Opcodes.ISA, Opcodes.SMARTMATCH, Opcodes.PROTOTYPE, Opcodes.QUOTE_REGEX, Opcodes.QUOTE_REGEX_O -> { pc = executeTypeOps(opcode, bytecode, pc, registers, code); } @@ -1734,6 +1769,10 @@ private static RuntimeList execute(SuspendedInterpreterFrame frame) { pc = InlineOpcodeHandler.executeHashKeys(bytecode, pc, registers); } + case Opcodes.HASH_KEYS_SCALAR -> { + pc = InlineOpcodeHandler.executeHashKeysScalar(bytecode, pc, registers); + } + case Opcodes.HASH_VALUES -> { pc = InlineOpcodeHandler.executeHashValues(bytecode, pc, registers); } @@ -1875,10 +1914,11 @@ private static RuntimeList execute(SuspendedInterpreterFrame frame) { // This applies equally to a marker from eval STRING and one // from eval BLOCK (the latter has no evalScope tag). if (jumpsIntoUnenteredLoopBody(code, - flow.getControlFlowLabel(), targetPc)) { + flow.getControlFlowLabel(), targetPc, pc)) { throw new PerlCompilerException( "Can't \"goto\" into the middle of a foreach loop"); } + rejectGotoIntoGiven(code, flow.getControlFlowLabel()); if (code.gotoLabelsInsideConstruct != null && code.gotoLabelsInsideConstruct.contains(flow.getControlFlowLabel())) { throw new PerlCompilerException( @@ -2036,10 +2076,11 @@ private static RuntimeList execute(SuspendedInterpreterFrame frame) { // See the equivalent marker handoff above: eval BLOCK markers // carry no evalScope, but cannot safely enter a loop either. if (jumpsIntoUnenteredLoopBody(code, - flow.getControlFlowLabel(), targetPc)) { + flow.getControlFlowLabel(), targetPc, pc)) { throw new PerlCompilerException( "Can't \"goto\" into the middle of a foreach loop"); } + rejectGotoIntoGiven(code, flow.getControlFlowLabel()); if (code.gotoLabelsInsideConstruct != null && code.gotoLabelsInsideConstruct.contains(flow.getControlFlowLabel())) { throw new PerlCompilerException( @@ -2787,7 +2828,8 @@ private static RuntimeList execute(SuspendedInterpreterFrame frame) { case Opcodes.RETRIEVE_BEGIN_SCALAR, Opcodes.RETRIEVE_BEGIN_ARRAY, Opcodes.RETRIEVE_BEGIN_HASH, Opcodes.LOCAL_SCALAR, Opcodes.LOCAL_ARRAY, Opcodes.LOCAL_HASH, Opcodes.STATE_INIT_SCALAR, Opcodes.STATE_INIT_ARRAY, - Opcodes.STATE_INIT_HASH -> { + Opcodes.STATE_INIT_HASH, Opcodes.STATE_RETRIEVE_SCALAR, + Opcodes.STATE_IS_INITIALIZED, Opcodes.STATE_MARK_INITIALIZED -> { pc = executeScopeOps(opcode, bytecode, pc, registers, code); } @@ -2830,7 +2872,9 @@ private static RuntimeList execute(SuspendedInterpreterFrame frame) { Opcodes.ALARM_OP, Opcodes.DEREF_GLOB, Opcodes.DEREF_GLOB_NONSTRICT, Opcodes.LOAD_GLOB_DYNAMIC, Opcodes.DEREF_SCALAR_STRICT, Opcodes.DEREF_SCALAR_NONSTRICT, Opcodes.CODE_DEREF_NONSTRICT, - Opcodes.NAMED_CODE_REFERENCE, Opcodes.DIRECT_NAMED_CODE_CALL -> { + Opcodes.NAMED_CODE_REFERENCE, Opcodes.DIRECT_NAMED_CODE_CALL, + Opcodes.FOREACH_DEREF_SCALAR, Opcodes.FOREACH_DEREF_ARRAY, + Opcodes.FOREACH_DEREF_HASH -> { int resultReg = opcode == Opcodes.EVAL_STRING ? bytecode[pc] : -1; pc = executeSpecialIO(opcode, bytecode, pc, registers, code); if (opcode == Opcodes.EVAL_STRING @@ -2840,10 +2884,11 @@ private static RuntimeList execute(SuspendedInterpreterFrame frame) { Integer targetPc = code.gotoLabelPcs.get(flow.getControlFlowLabel()); if (targetPc != null) { if (jumpsIntoUnenteredLoopBody(code, - flow.getControlFlowLabel(), targetPc)) { + flow.getControlFlowLabel(), targetPc, pc)) { throw new PerlCompilerException( "Can't \"goto\" into the middle of a foreach loop"); } + rejectGotoIntoGiven(code, flow.getControlFlowLabel()); if (code.gotoLabelsInsideConstruct != null && code.gotoLabelsInsideConstruct.contains(flow.getControlFlowLabel())) { throw new PerlCompilerException( @@ -3886,6 +3931,15 @@ private static int executeTypeOps(int opcode, int[] bytecode, int pc, registers[rd] = ReferenceOperators.bless(ref, pkg); return pc; } + case Opcodes.BLESS_CLASS_INSTANCE -> { + int rd = bytecode[pc++]; + int refReg = bytecode[pc++]; + int pkgReg = bytecode[pc++]; + RuntimeScalar ref = registers[refReg].scalar(); + RuntimeScalar pkg = registers[pkgReg].scalar(); + registers[rd] = ReferenceOperators.blessClassInstance(ref, pkg); + return pc; + } case Opcodes.ISA -> { int rd = bytecode[pc++]; int objReg = bytecode[pc++]; @@ -4150,6 +4204,32 @@ private static int executeScopeOps(int opcode, int[] bytecode, int pc, } return pc; } + case Opcodes.STATE_RETRIEVE_SCALAR -> { + int rd = bytecode[pc++]; + int nameIdx = bytecode[pc++]; + int persistId = bytecode[pc++]; + String varName = code.stringPool[nameIdx]; + RuntimeScalar codeRef = code.__SUB__ != null ? code.__SUB__ : new RuntimeScalar(); + registers[rd] = StateVariable.retrieveStateScalar(codeRef, varName, persistId); + return pc; + } + case Opcodes.STATE_IS_INITIALIZED -> { + int rd = bytecode[pc++]; + int nameIdx = bytecode[pc++]; + int persistId = bytecode[pc++]; + String varName = code.stringPool[nameIdx]; + RuntimeScalar codeRef = code.__SUB__ != null ? code.__SUB__ : new RuntimeScalar(); + registers[rd] = StateVariable.isInitializedStateVariable(codeRef, varName, persistId); + return pc; + } + case Opcodes.STATE_MARK_INITIALIZED -> { + int nameIdx = bytecode[pc++]; + int persistId = bytecode[pc++]; + String varName = code.stringPool[nameIdx]; + RuntimeScalar codeRef = code.__SUB__ != null ? code.__SUB__ : new RuntimeScalar(); + StateVariable.markInitializedStateVariable(codeRef, varName, persistId); + return pc; + } default -> throw new RuntimeException("Unknown scope opcode: " + opcode); } } @@ -4381,6 +4461,15 @@ private static int executeSpecialIO(int opcode, int[] bytecode, int pc, case Opcodes.REJECT_LOCALIZE_REFERENCE -> { return SlowOpcodeHandler.executeRejectLocalizeReference(bytecode, pc, registers); } + case Opcodes.FOREACH_DEREF_SCALAR -> { + return SlowOpcodeHandler.executeForeachDerefScalar(bytecode, pc, registers); + } + case Opcodes.FOREACH_DEREF_ARRAY -> { + return SlowOpcodeHandler.executeForeachDerefArray(bytecode, pc, registers); + } + case Opcodes.FOREACH_DEREF_HASH -> { + return SlowOpcodeHandler.executeForeachDerefHash(bytecode, pc, registers); + } case Opcodes.DEREF_SCALAR_NONSTRICT -> { return SlowOpcodeHandler.executeDerefScalarNonStrict(bytecode, pc, registers, code); } diff --git a/src/main/java/org/perlonjava/backend/bytecode/CompileAssignment.java b/src/main/java/org/perlonjava/backend/bytecode/CompileAssignment.java index e9a2cb3a5d..d2b81b0d9e 100644 --- a/src/main/java/org/perlonjava/backend/bytecode/CompileAssignment.java +++ b/src/main/java/org/perlonjava/backend/bytecode/CompileAssignment.java @@ -794,7 +794,9 @@ public static void compileAssignmentOperator(BytecodeCompiler bytecodeCompiler, if (beginIdObj != null) { int beginId = beginIdObj; int nameIdx = bytecodeCompiler.addToStringPool(varName); - int reg = bytecodeCompiler.allocateRegister(); + int reg = leftOp.operator.equals("state") + ? bytecodeCompiler.allocateStateVariableRegister() + : bytecodeCompiler.allocateRegister(); bytecodeCompiler.emitWithToken(Opcodes.RETRIEVE_BEGIN_SCALAR, node.getIndex()); bytecodeCompiler.emitReg(reg); @@ -822,24 +824,39 @@ public static void compileAssignmentOperator(BytecodeCompiler bytecodeCompiler, } if (leftOp.operator.equals("state")) { - // State variable without BEGIN id: use conditional initialization - // STATE_INIT_SCALAR handles both retrieval (non-destructive) and - // conditional first-time initialization + // State initialization is lazy: Perl does not evaluate the + // RHS after the first successful initialization. Retrieve and + // test the persistent cell before compiling that RHS so a + // `redo` after a skipped declaration cannot repeat its side + // effects. int persistId = sigilOp.id; int nameIdx = bytecodeCompiler.addToStringPool(varName); - int reg = bytecodeCompiler.allocateRegister(); + int reg = bytecodeCompiler.allocateStateVariableRegister(); + int initializedReg = bytecodeCompiler.allocateRegister(); + + bytecodeCompiler.emitWithToken(Opcodes.STATE_RETRIEVE_SCALAR, node.getIndex()); + bytecodeCompiler.emitReg(reg); + bytecodeCompiler.emit(nameIdx); + bytecodeCompiler.emit(persistId); + bytecodeCompiler.emit(Opcodes.STATE_IS_INITIALIZED); + bytecodeCompiler.emitReg(initializedReg); + bytecodeCompiler.emit(nameIdx); + bytecodeCompiler.emit(persistId); + + bytecodeCompiler.emit(bytecodeCompiler.gotoIfTrueOpcode()); + bytecodeCompiler.emitReg(initializedReg); + int initializedJump = bytecodeCompiler.bytecode.size(); + bytecodeCompiler.emitInt(0); - // Compile RHS (value to conditionally assign) bytecodeCompiler.compileNode(node.right, -1, rhsContext); int valueReg = bytecodeCompiler.lastResultReg; - - // STATE_INIT_SCALAR: retrieves persistent variable and - // only assigns if not yet initialized - bytecodeCompiler.emitWithToken(Opcodes.STATE_INIT_SCALAR, node.getIndex()); + bytecodeCompiler.emit(Opcodes.SET_SCALAR); bytecodeCompiler.emitReg(reg); bytecodeCompiler.emitReg(valueReg); + bytecodeCompiler.emit(Opcodes.STATE_MARK_INITIALIZED); bytecodeCompiler.emit(nameIdx); bytecodeCompiler.emit(persistId); + bytecodeCompiler.patchIntOffset(initializedJump, bytecodeCompiler.bytecode.size()); bytecodeCompiler.emitActiveLexicalBinding(reg, varName); bytecodeCompiler.registerVariable(varName, reg); diff --git a/src/main/java/org/perlonjava/backend/bytecode/CompileBinaryOperator.java b/src/main/java/org/perlonjava/backend/bytecode/CompileBinaryOperator.java index 2202e4bd2e..740fa860c7 100644 --- a/src/main/java/org/perlonjava/backend/bytecode/CompileBinaryOperator.java +++ b/src/main/java/org/perlonjava/backend/bytecode/CompileBinaryOperator.java @@ -294,6 +294,9 @@ else if (node.right instanceof BinaryOperatorNode rightCall) { } methodName = lexicalPackage + "::" + methodName; } + if (node.getBooleanAnnotation("indirectBlockMethod")) { + methodName = RuntimeCode.indirectBlockMethodName(methodName); + } methodNode = new StringNode(methodName, methodNode.getIndex()); } @@ -489,6 +492,16 @@ else if (node.right instanceof BinaryOperatorNode rightCall) { } if (node.operator.equals("(") || node.operator.equals("()")) { + // The parser records a bare statement label on this call node. The + // direct-call opcode is emitted from its nested '&' node, so pass the + // diagnostic-only hint down before compiling that operand. + Object precedingLabel = node.getAnnotation("precedingLabel"); + if (precedingLabel instanceof String label + && node.left instanceof OperatorNode operatorNode + && operatorNode.operator.equals("&") + && operatorNode.getBooleanAnnotation("directNamedCall")) { + operatorNode.setAnnotation("precedingLabel", label); + } bytecodeCompiler.compileNode(node.left, -1, RuntimeContextType.SCALAR); int rs1 = bytecodeCompiler.lastResultReg; @@ -776,7 +789,7 @@ else if (node.right instanceof BinaryOperatorNode rightCall) { ? RuntimeContextType.LIST : RuntimeContextType.SCALAR; // Preserve the actual scalar slot: bless may publish metadata through // a threads::shared scalar and must not operate on a temporary copy. - case "bless" -> isDirectScalarLvalue(node.left) + case "bless", "blessClassInstance" -> isDirectScalarLvalue(node.left) ? RuntimeContextType.LVALUE : RuntimeContextType.SCALAR; default -> RuntimeContextType.SCALAR; }; @@ -808,6 +821,9 @@ else if (node.right instanceof BinaryOperatorNode rightCall) { rightCtx = RuntimeContextType.OBJECT; } Node rightNode = node.right; + if (node.operator.equals("~~") && rightNode instanceof SubroutineNode subroutine) { + subroutine.setAnnotation("smartmatchPredicate", true); + } if (node.operator.equals("isa") && rightNode instanceof IdentifierNode identifier) { // The RHS package name of the feature 'isa' operator is a // class-name bareword even under strict subs. Match the JVM diff --git a/src/main/java/org/perlonjava/backend/bytecode/CompileBinaryOperatorHelper.java b/src/main/java/org/perlonjava/backend/bytecode/CompileBinaryOperatorHelper.java index ab27709c0f..5a5e632c4f 100644 --- a/src/main/java/org/perlonjava/backend/bytecode/CompileBinaryOperatorHelper.java +++ b/src/main/java/org/perlonjava/backend/bytecode/CompileBinaryOperatorHelper.java @@ -25,11 +25,13 @@ public static int compileBinaryOperatorSwitch(BytecodeCompiler bytecodeCompiler, } public static int compileBinaryOperatorSwitch(BytecodeCompiler bytecodeCompiler, BinaryOperatorNode node, int rs1, int rs2, int tokenIndex) { - return compileBinaryOperatorSwitch(bytecodeCompiler, node.operator, rs1, rs2, tokenIndex, false, integerOverride(node)); + return compileBinaryOperatorSwitch(bytecodeCompiler, node.operator, rs1, rs2, tokenIndex, false, + integerOverride(node), node.operator.equals("blessClassInstance")); } public static int compileBinaryOperatorSwitch(BytecodeCompiler bytecodeCompiler, BinaryOperatorNode node, int rs1, int rs2, int tokenIndex, boolean shareCallerArgs) { - return compileBinaryOperatorSwitch(bytecodeCompiler, node.operator, rs1, rs2, tokenIndex, shareCallerArgs, integerOverride(node)); + return compileBinaryOperatorSwitch(bytecodeCompiler, node.operator, rs1, rs2, tokenIndex, shareCallerArgs, + integerOverride(node), node.operator.equals("blessClassInstance")); } private static Boolean integerOverride(BinaryOperatorNode node) { @@ -42,6 +44,11 @@ private static boolean isIntegerEnabled(BytecodeCompiler bytecodeCompiler, Boole } private static int compileBinaryOperatorSwitch(BytecodeCompiler bytecodeCompiler, String operator, int rs1, int rs2, int tokenIndex, boolean shareCallerArgs, Boolean useIntegerOverride) { + return compileBinaryOperatorSwitch(bytecodeCompiler, operator, rs1, rs2, tokenIndex, shareCallerArgs, + useIntegerOverride, false); + } + + private static int compileBinaryOperatorSwitch(BytecodeCompiler bytecodeCompiler, String operator, int rs1, int rs2, int tokenIndex, boolean shareCallerArgs, Boolean useIntegerOverride, boolean classConstructionBless) { // Allocate result register int rd = bytecodeCompiler.allocateOutputRegister(); @@ -121,11 +128,11 @@ private static int compileBinaryOperatorSwitch(BytecodeCompiler bytecodeCompiler bytecodeCompiler.emitReg(rs1); bytecodeCompiler.emitReg(rs2); } - case "bless" -> { + case "bless", "blessClassInstance" -> { // bless $ref, "Package" or bless $ref (defaults to current package) // rs1 = reference to bless // rs2 = package name (or undef for current package) - bytecodeCompiler.emit(Opcodes.BLESS); + bytecodeCompiler.emit(classConstructionBless ? Opcodes.BLESS_CLASS_INSTANCE : Opcodes.BLESS); bytecodeCompiler.emitReg(rd); bytecodeCompiler.emitReg(rs1); bytecodeCompiler.emitReg(rs2); diff --git a/src/main/java/org/perlonjava/backend/bytecode/CompileExistsDelete.java b/src/main/java/org/perlonjava/backend/bytecode/CompileExistsDelete.java index 75df2c753a..81fda13c72 100644 --- a/src/main/java/org/perlonjava/backend/bytecode/CompileExistsDelete.java +++ b/src/main/java/org/perlonjava/backend/bytecode/CompileExistsDelete.java @@ -9,12 +9,22 @@ public class CompileExistsDelete { + // Perl permits a leading unary plus to disambiguate a dereference target + // passed to exists/delete. It does not turn the element access into a + // value expression for these operators. + private static Node unwrapUnaryPlus(Node arg) { + if (arg instanceof OperatorNode operator && operator.operator.equals("+")) { + return operator.operand; + } + return arg; + } + public static void visitExists(BytecodeCompiler bc, OperatorNode node) { if (node.operand == null || !(node.operand instanceof ListNode list) || list.elements.isEmpty()) { bc.throwCompilerException("exists requires an argument"); return; } - Node arg = list.elements.get(0); + Node arg = unwrapUnaryPlus(list.elements.get(0)); if (arg instanceof BinaryOperatorNode binOp) { switch (binOp.operator) { case "{" -> visitExistsHash(bc, node, binOp); @@ -98,7 +108,7 @@ public static void visitDelete(BytecodeCompiler bc, OperatorNode node) { bc.throwCompilerException("delete requires an argument"); return; } - Node arg = list.elements.get(0); + Node arg = unwrapUnaryPlus(list.elements.get(0)); if (arg instanceof BinaryOperatorNode binOp) { switch (binOp.operator) { case "{" -> visitDeleteHash(bc, node, binOp); diff --git a/src/main/java/org/perlonjava/backend/bytecode/CompileOperator.java b/src/main/java/org/perlonjava/backend/bytecode/CompileOperator.java index 11f6c6c378..828b603d36 100644 --- a/src/main/java/org/perlonjava/backend/bytecode/CompileOperator.java +++ b/src/main/java/org/perlonjava/backend/bytecode/CompileOperator.java @@ -1302,9 +1302,15 @@ public static void visitOperator(BytecodeCompiler bytecodeCompiler, OperatorNode expansions); } } catch (PerlCompilerException exception) { - throw PerlCompilerException.withSourceLocation( - node.tokenIndex, exception.getMessage(), - bytecodeCompiler.errorUtil); + // Let the runtime regex compiler render a U+ overflow + // at evaluation time. The bytecode compiler's source + // map predates #line remapping inside eval strings. + if (!StringParser.shouldDeferRegexDiagnostic( + exception.getMessage())) { + throw PerlCompilerException.withSourceLocation( + node.tokenIndex, exception.getMessage(), + bytecodeCompiler.errorUtil); + } } } boolean needsCallsiteCache = false; @@ -1757,13 +1763,20 @@ private static void visitKeys(BytecodeCompiler bc, OperatorNode node) { bc.compileNode(node.operand, -1, RuntimeContextType.LIST); int hashReg = bc.lastResultReg; int rd = bc.allocateOutputRegister(); + if (bc.currentCallContext == RuntimeContextType.SCALAR) { + // A scalar keys result is the hash count. Calling the context-aware + // runtime path avoids materializing (and then counting) a key list, + // which is especially important for repeatedly queried empty hashes. + bc.emit(Opcodes.HASH_KEYS_SCALAR); bc.emitReg(rd); bc.emitReg(hashReg); + bc.lastResultReg = rd; + return; + } bc.emit(Opcodes.HASH_KEYS); bc.emitReg(rd); bc.emitReg(hashReg); // keys is not itself an assignable aggregate. In the lvalue contexts // reached by `keys %h .= ...` and `substr keys %h, ...`, Perl uses its // scalar count result rather than passing the key RuntimeArray through // to the assignment operator. - if (bc.currentCallContext == RuntimeContextType.SCALAR - || bc.currentCallContext == RuntimeContextType.LVALUE) { + if (bc.currentCallContext == RuntimeContextType.LVALUE) { int scalarReg = bc.allocateRegister(); bc.emit(Opcodes.ARRAY_SIZE); bc.emitReg(scalarReg); bc.emitReg(rd); if (bc.currentCallContext == RuntimeContextType.LVALUE) { @@ -2146,6 +2159,15 @@ private static void visitGoto(BytecodeCompiler bc, OperatorNode node) { labelStr = "\u0000invalid-goto-into-foreach:" + labelStr; staticTarget = null; } + if (staticTarget != null && staticTarget.owner != null + && staticTarget.owner.getBooleanAnnotation("givenBlock") + && !node.getBooleanAnnotation("insideGivenBlock")) { + // A raw PC jump into `given` skips its topicalizer and control + // block setup. Static gotos normally bypass GOTO_DYNAMIC, so + // reject this at the resolved target just as the dynamic path + // does at runtime. + bc.throwCompilerException("Can't \"goto\" into a \"given\" block", node.getIndex()); + } if (staticTarget != null) { // Static gotos bind to the nearest containing block, never to the // final entry of the name-only dynamic map. @@ -2160,6 +2182,9 @@ private static void visitGoto(BytecodeCompiler bc, OperatorNode node) { bc.lastResultReg = -1; return; } + if (bc.isSmartmatchPredicate) { + bc.throwCleanCompilerException("Can't find label " + labelStr, node.getIndex()); + } // Always use the resolver instead of emitting a raw PC jump. A PC is // only valid after all enclosing construct prologues have run; raw // jumps previously let an eval enter a foreach body with a temporary diff --git a/src/main/java/org/perlonjava/backend/bytecode/Disassemble.java b/src/main/java/org/perlonjava/backend/bytecode/Disassemble.java index 8d794b9c89..0df73100be 100644 --- a/src/main/java/org/perlonjava/backend/bytecode/Disassemble.java +++ b/src/main/java/org/perlonjava/backend/bytecode/Disassemble.java @@ -1173,6 +1173,12 @@ public static String disassemble(InterpretedCode interpretedCode) { int hashKeysReg = interpretedCode.bytecode[pc++]; sb.append("HASH_KEYS r").append(rd).append(" = keys(r").append(hashKeysReg).append(")\n"); break; + case Opcodes.HASH_KEYS_SCALAR: + rd = interpretedCode.bytecode[pc++]; + int hashKeysScalarReg = interpretedCode.bytecode[pc++]; + sb.append("HASH_KEYS_SCALAR r").append(rd).append(" = scalar keys(r") + .append(hashKeysScalarReg).append(")\n"); + break; case Opcodes.HASH_VALUES: rd = interpretedCode.bytecode[pc++]; int hashValuesReg = interpretedCode.bytecode[pc++]; @@ -1414,6 +1420,13 @@ public static String disassemble(InterpretedCode interpretedCode) { sb.append("BLESS r").append(rd).append(" = bless(r").append(refReg) .append(", r").append(packageReg).append(")\n"); break; + case Opcodes.BLESS_CLASS_INSTANCE: + rd = interpretedCode.bytecode[pc++]; + int classRefReg = interpretedCode.bytecode[pc++]; + int classPackageReg = interpretedCode.bytecode[pc++]; + sb.append("BLESS_CLASS_INSTANCE r").append(rd).append(" = bless(r").append(classRefReg) + .append(", r").append(classPackageReg).append(")\n"); + break; case Opcodes.ISA: rd = interpretedCode.bytecode[pc++]; int objReg = interpretedCode.bytecode[pc++]; @@ -1992,9 +2005,18 @@ public static String disassemble(InterpretedCode interpretedCode) { int directCallRd = interpretedCode.bytecode[pc++]; int directCallNameIdx = interpretedCode.bytecode[pc++]; int directCallCacheIdx = interpretedCode.bytecode[pc++]; + int directCallClassNameIdx = interpretedCode.bytecode[pc++]; + int directCallLabelIdx = interpretedCode.bytecode[pc++]; sb.append("DIRECT_NAMED_CODE_CALL r").append(directCallRd) .append(" = &").append(interpretedCode.stringPool[directCallNameIdx]) - .append(" cache=").append(directCallCacheIdx).append("\n"); + .append(" cache=").append(directCallCacheIdx); + if (directCallClassNameIdx >= 0) { + sb.append(" class=").append(interpretedCode.stringPool[directCallClassNameIdx]); + } + if (directCallLabelIdx >= 0) { + sb.append(" label=").append(interpretedCode.stringPool[directCallLabelIdx]); + } + sb.append("\n"); break; case Opcodes.PUSH_LABELED_BLOCK: { int labelIdx = interpretedCode.bytecode[pc++]; @@ -2884,6 +2906,31 @@ public static String disassemble(InterpretedCode interpretedCode) { .append(", name=").append(stName).append(", persist=").append(stPersist).append("\n"); break; } + case Opcodes.STATE_RETRIEVE_SCALAR: { + int stateRd = interpretedCode.bytecode[pc++]; + int stateName = interpretedCode.bytecode[pc++]; + int statePersist = interpretedCode.bytecode[pc++]; + sb.append("STATE_RETRIEVE_SCALAR r").append(stateRd) + .append(", name=").append(stateName) + .append(", persist=").append(statePersist).append("\n"); + break; + } + case Opcodes.STATE_IS_INITIALIZED: { + int stateRd = interpretedCode.bytecode[pc++]; + int stateName = interpretedCode.bytecode[pc++]; + int statePersist = interpretedCode.bytecode[pc++]; + sb.append("STATE_IS_INITIALIZED r").append(stateRd) + .append(", name=").append(stateName) + .append(", persist=").append(statePersist).append("\n"); + break; + } + case Opcodes.STATE_MARK_INITIALIZED: { + int stateName = interpretedCode.bytecode[pc++]; + int statePersist = interpretedCode.bytecode[pc++]; + sb.append("STATE_MARK_INITIALIZED name=").append(stateName) + .append(", persist=").append(statePersist).append("\n"); + break; + } case Opcodes.SMARTMATCH: { int smRd = interpretedCode.bytecode[pc++]; int smRs1 = 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 77acaaf0a8..fec2ab44eb 100644 --- a/src/main/java/org/perlonjava/backend/bytecode/EvalStringHandler.java +++ b/src/main/java/org/perlonjava/backend/bytecode/EvalStringHandler.java @@ -339,7 +339,7 @@ private static RuntimeList evalStringList(String perlCode, // Generate a unique eval filename so ByteCodeSourceMapper entries from // different evals don't collide (each eval's token indices start from 0, // so sharing a single filename would mix package-at-location data). - String evalFileName = RuntimeCode.getNextEvalFilename(); + String evalFileName = RuntimeCode.getNextEvalFilename(sourceName); CompilerOptions opts = new CompilerOptions(); opts.fileName = evalFileName; @@ -589,8 +589,7 @@ private static RuntimeList evalStringList(String perlCode, // Step 4.5: Store source lines in debugger symbol table if $^P flags are set int debugFlags = GlobalVariable.getGlobalVariable(GlobalContext.encodeSpecialVar("P")).getInt(); if (debugFlags != 0) { - String evalFilename = RuntimeCode.getNextEvalFilename(); - RuntimeCode.storeSourceLines(perlCode, evalFilename, ast, tokens); + RuntimeCode.storeSourceLines(perlCode, evalFileName, ast, tokens); } // Step 5: Attach captured variables to eval'd code @@ -747,7 +746,7 @@ public static RuntimeScalar evalString(String perlCode, List tokens = lexer.tokenize(); // Generate a unique eval filename (see comment in evalStringList above) - String evalFileName = RuntimeCode.getNextEvalFilename(); + String evalFileName = RuntimeCode.getNextEvalFilename(sourceName); CompilerOptions opts = new CompilerOptions(); opts.fileName = evalFileName; @@ -800,8 +799,7 @@ public static RuntimeScalar evalString(String perlCode, // Store source lines in debugger symbol table if $^P flags are set int debugFlags = GlobalVariable.getGlobalVariable(GlobalContext.encodeSpecialVar("P")).getInt(); if (debugFlags != 0) { - String evalFilename = RuntimeCode.getNextEvalFilename(); - RuntimeCode.storeSourceLines(perlCode, evalFilename, ast, tokens); + RuntimeCode.storeSourceLines(perlCode, evalFileName, ast, tokens); } // Attach captured variables diff --git a/src/main/java/org/perlonjava/backend/bytecode/InlineOpcodeHandler.java b/src/main/java/org/perlonjava/backend/bytecode/InlineOpcodeHandler.java index 0095bf0b2f..a7ad211a15 100644 --- a/src/main/java/org/perlonjava/backend/bytecode/InlineOpcodeHandler.java +++ b/src/main/java/org/perlonjava/backend/bytecode/InlineOpcodeHandler.java @@ -876,6 +876,17 @@ public static int executeHashKeys(int[] bytecode, int pc, RuntimeBase[] register return pc; } + /** + * Get the scalar-context count for {@code keys %hash} without first + * materializing a key list. Format: HASH_KEYS_SCALAR rd hashReg. + */ + public static int executeHashKeysScalar(int[] bytecode, int pc, RuntimeBase[] registers) { + int rd = bytecode[pc++]; + int hashReg = bytecode[pc++]; + registers[rd] = registers[hashReg].keys(RuntimeContextType.SCALAR); + return pc; + } + /** Preallocate hash buckets. Format: HASH_PREALLOCATE hashReg capacityReg. */ public static int executeHashPreallocate(int[] bytecode, int pc, RuntimeBase[] registers) { int hashReg = bytecode[pc++]; diff --git a/src/main/java/org/perlonjava/backend/bytecode/InterpretedCode.java b/src/main/java/org/perlonjava/backend/bytecode/InterpretedCode.java index 88f9affff2..cd57a8fcb5 100644 --- a/src/main/java/org/perlonjava/backend/bytecode/InterpretedCode.java +++ b/src/main/java/org/perlonjava/backend/bytecode/InterpretedCode.java @@ -57,6 +57,8 @@ public class InterpretedCode extends RuntimeCode implements PerlSubroutine { // Labels inside expression-level `do { ... }` blocks. Entering one with // goto skips the enclosing operator's setup and is forbidden by Perl. public Set gotoLabelsInsideConstruct; + /** Labels inside a given block, which goto may not enter. */ + public Set gotoLabelsInsideGiven; public Map gotoLabelLoopRanges; // Runtime package in effect at each goto-label PC. A goto can skip a // preceding `package` statement but must still resume in that package. @@ -419,6 +421,8 @@ public RuntimeList apply(RuntimeArray args, int callContext) { // retaining async initial-result wrapping from master. RuntimeList result = BytecodeInterpreter.execute( this, args, effectiveContext, this.subName); + result = RuntimeCode.handleEscapingLoopControl( + result, generatedClassConstructor, classAdjustBlock); if (isSortComparator && result instanceof RuntimeControlFlowList flow) { throw new PerlCompilerException("Can't \"goto\" out of a pseudo block at " + flow.marker.fileName + " line " + flow.marker.lineNumber + ".\n"); @@ -612,6 +616,7 @@ public InterpretedCode withCapturedVars(RuntimeBase[] capturedVars) { copy.gotoLabelPcs = this.gotoLabelPcs; copy.gotoLabelsInsideLoop = this.gotoLabelsInsideLoop; copy.gotoLabelsInsideConstruct = this.gotoLabelsInsideConstruct; + copy.gotoLabelsInsideGiven = this.gotoLabelsInsideGiven; copy.gotoLabelLoopRanges = this.gotoLabelLoopRanges; copy.gotoLabelPackages = this.gotoLabelPackages; copy.usesLocalization = this.usesLocalization; diff --git a/src/main/java/org/perlonjava/backend/bytecode/Opcodes.java b/src/main/java/org/perlonjava/backend/bytecode/Opcodes.java index 1dd406f499..36723b3288 100644 --- a/src/main/java/org/perlonjava/backend/bytecode/Opcodes.java +++ b/src/main/java/org/perlonjava/backend/bytecode/Opcodes.java @@ -2077,6 +2077,15 @@ public class Opcodes { */ public static final short STATE_INIT_HASH = 399; + /** Retrieve a persistent state scalar without initializing it. Format: rd name_idx persist_id. */ + public static final short STATE_RETRIEVE_SCALAR = 572; + + /** Read a persistent state scalar's initialization flag. Format: rd name_idx persist_id. */ + public static final short STATE_IS_INITIALIZED = 573; + + /** Mark a persistent state scalar initialized. Format: name_idx persist_id. */ + public static final short STATE_MARK_INITIALIZED = 574; + // Smartmatch operator (~~) // Format: SMARTMATCH rd rs1 rs2 // Effect: rd = CompareOperators.smartmatch(rs1, rs2) @@ -2569,8 +2578,18 @@ public class Opcodes { /** Array element fetch that preserves tied-array lvalue semantics for local(). */ public static final short ARRAY_GET_FOR_LOCAL = 562; + /** Declared-reference foreach scalar dereference without autovivification. */ + public static final short FOREACH_DEREF_SCALAR = 566; + /** Declared-reference foreach array dereference without autovivification. */ + public static final short FOREACH_DEREF_ARRAY = 569; + /** Declared-reference foreach hash dereference without autovivification. */ + public static final short FOREACH_DEREF_HASH = 568; + + /** Synthetic class constructor blessing. Format: BLESS_CLASS_INSTANCE rd refReg packageReg. */ + public static final short BLESS_CLASS_INSTANCE = 570; + /** Record a readline handle's source spelling for $. diagnostics. Format: nameStringIdx. */ - public static final short SET_LAST_READLINE_HANDLE_NAME = 566; + public static final short SET_LAST_READLINE_HANDLE_NAME = 571; /** * Resolve a statically named CODE reference at runtime. This preserves the @@ -2595,7 +2614,7 @@ public class Opcodes { */ public static final short UNDEFINE_SCALAR_LVALUE = 534; - /** Resolve a direct named call with a call-site CV cache. Format: rd nameStringIdx cacheConstIdx. */ + /** Resolve a direct named call with a call-site CV cache. Format: rd nameStringIdx cacheConstIdx classNameStringIdx (-1 if ordinary sub) labelStringIdx (-1 if absent). */ public static final short DIRECT_NAMED_CODE_CALL = 535; /** Register a format declaration and lexical cells. Format: constantIdx captureCount (nameIdx reg)*. */ @@ -2635,6 +2654,9 @@ public class Opcodes { /** Return the mutable {@code $#array} cell. Format: ARRAY_LAST_INDEX_LVALUE rd arrayReg. */ public static final short ARRAY_LAST_INDEX_LVALUE = 518; + /** Scalar-context {@code keys}: rd = scalar keys(hashReg). Format: rd hashReg. */ + public static final short HASH_KEYS_SCALAR = 575; + private Opcodes() { } // Utility class - no instantiation } diff --git a/src/main/java/org/perlonjava/backend/bytecode/SlowOpcodeHandler.java b/src/main/java/org/perlonjava/backend/bytecode/SlowOpcodeHandler.java index 7513b71ce4..8d1631e50f 100644 --- a/src/main/java/org/perlonjava/backend/bytecode/SlowOpcodeHandler.java +++ b/src/main/java/org/perlonjava/backend/bytecode/SlowOpcodeHandler.java @@ -509,6 +509,27 @@ public static int executeRejectLocalizeReference( return pc; } + public static int executeForeachDerefScalar(int[] bytecode, int pc, RuntimeBase[] registers) { + int rd = bytecode[pc++]; + int rs = bytecode[pc++]; + registers[rd] = registers[rs].scalar().foreachScalarReference(); + return pc; + } + + public static int executeForeachDerefArray(int[] bytecode, int pc, RuntimeBase[] registers) { + int rd = bytecode[pc++]; + int rs = bytecode[pc++]; + registers[rd] = registers[rs].scalar().foreachArrayReference(); + return pc; + } + + public static int executeForeachDerefHash(int[] bytecode, int pc, RuntimeBase[] registers) { + int rd = bytecode[pc++]; + int rs = bytecode[pc++]; + registers[rd] = registers[rs].scalar().foreachHashReference(); + return pc; + } + /** * DEREF_SCALAR_NONSTRICT: rd = rs.scalarDerefNonStrict(pkg) * Format: DEREF_SCALAR_NONSTRICT rd rs pkgIdx @@ -1535,9 +1556,25 @@ public static int executeDirectNamedCodeCall(int[] bytecode, int pc, int rd = bytecode[pc++]; int nameIdx = bytecode[pc++]; int cacheIdx = bytecode[pc++]; + int classNameIdx = bytecode[pc++]; + int labelIdx = bytecode[pc++]; RuntimeScalar cached = (RuntimeScalar) code.constants[cacheIdx]; - registers[rd] = GlobalVariable.getGlobalCodeRefForDirectCall( - code.stringPool[nameIdx], cached); + String name = code.stringPool[nameIdx]; + RuntimeScalar codeRef = GlobalVariable.getGlobalCodeRefForDirectCall(name, cached); + // The normal RuntimeCode.apply path owns ordinary direct-call errors. + // Preflight only labelled statements, where the diagnostic needs the + // parser-provided "close to label" hint. A goto &name also reuses this + // lookup opcode while constructing its tail-call marker, and must defer + // its undefined-target diagnostic to that marker's resolver. + if (labelIdx >= 0) { + RuntimeCode.throwIfDirectCallUndefined(codeRef, name, code.stringPool[labelIdx]); + } + if (classNameIdx >= 0 && codeRef.value instanceof RuntimeCode runtimeCode) { + runtimeCode.isClassMethod = true; + runtimeCode.declaringClass = code.stringPool[classNameIdx]; + runtimeCode.referenceOriginFqn = name; + } + registers[rd] = codeRef; return pc; } diff --git a/src/main/java/org/perlonjava/backend/jvm/Dereference.java b/src/main/java/org/perlonjava/backend/jvm/Dereference.java index 42fd69046a..9857143753 100644 --- a/src/main/java/org/perlonjava/backend/jvm/Dereference.java +++ b/src/main/java/org/perlonjava/backend/jvm/Dereference.java @@ -10,6 +10,7 @@ import org.perlonjava.runtime.perlmodule.Strict; import org.perlonjava.runtime.runtimetypes.PerlCompilerException; import org.perlonjava.runtime.runtimetypes.RuntimeContextType; +import org.perlonjava.runtime.runtimetypes.RuntimeCode; import static org.perlonjava.backend.jvm.EmitSubroutine.handleSelfCallOperator; import static org.perlonjava.runtime.perlmodule.Strict.HINT_STRICT_REFS; @@ -923,6 +924,9 @@ static void handleArrowOperator(EmitterVisitor emitterVisitor, BinaryOperatorNod } methodName = lexicalPackage + "::" + methodName; } + if (node.getBooleanAnnotation("indirectBlockMethod")) { + methodName = RuntimeCode.indirectBlockMethodName(methodName); + } method = new StringNode(methodName, method.getIndex()); } diff --git a/src/main/java/org/perlonjava/backend/jvm/EmitBinaryOperator.java b/src/main/java/org/perlonjava/backend/jvm/EmitBinaryOperator.java index 39b0e42eba..a4d40f58c6 100644 --- a/src/main/java/org/perlonjava/backend/jvm/EmitBinaryOperator.java +++ b/src/main/java/org/perlonjava/backend/jvm/EmitBinaryOperator.java @@ -11,6 +11,7 @@ import org.perlonjava.frontend.astnode.NumberNode; import org.perlonjava.frontend.astnode.OperatorNode; import org.perlonjava.frontend.astnode.StringNode; +import org.perlonjava.frontend.astnode.SubroutineNode; import org.perlonjava.runtime.operators.OperatorHandler; import org.perlonjava.runtime.perlmodule.Strict; import org.perlonjava.runtime.runtimetypes.RuntimeContextType; @@ -79,6 +80,9 @@ && switch (node.operator) { } var right = node.right; + if (node.operator.equals("~~") && right instanceof SubroutineNode subroutine) { + subroutine.setAnnotation("smartmatchPredicate", true); + } // Special case for `isa` - left side can be bareword if (node.operator.equals("isa") && right instanceof IdentifierNode identifierNode) { diff --git a/src/main/java/org/perlonjava/backend/jvm/EmitBinaryOperatorNode.java b/src/main/java/org/perlonjava/backend/jvm/EmitBinaryOperatorNode.java index b4d5b3dba3..bb88046727 100644 --- a/src/main/java/org/perlonjava/backend/jvm/EmitBinaryOperatorNode.java +++ b/src/main/java/org/perlonjava/backend/jvm/EmitBinaryOperatorNode.java @@ -89,7 +89,7 @@ public static void emitBinaryOperatorNode(EmitterVisitor emitterVisitor, BinaryO // Binary operators case "%", "&", "&.", "binary&", "*", "**", "+", "-", "/", "<<", "<=>", ">>", "^", "^.", "binary^", "|", "|.", "binary|", - "bless", "cmp", "isa", "~~" -> { + "bless", "blessClassInstance", "cmp", "isa", "~~" -> { // Check if uninitialized warnings are enabled at compile time // Use warn variant for zero-overhead when warnings disabled boolean warnUninit = emitterVisitor.ctx.symbolTable.isWarningCategoryEnabled("uninitialized"); diff --git a/src/main/java/org/perlonjava/backend/jvm/EmitBlock.java b/src/main/java/org/perlonjava/backend/jvm/EmitBlock.java index fab823bce8..b38b6379a5 100644 --- a/src/main/java/org/perlonjava/backend/jvm/EmitBlock.java +++ b/src/main/java/org/perlonjava/backend/jvm/EmitBlock.java @@ -16,6 +16,7 @@ import java.util.ArrayList; import java.util.LinkedHashSet; import java.util.List; +import java.util.Map; import java.util.Set; public class EmitBlock { @@ -30,6 +31,15 @@ private static void collectStateDeclSigilNodes(Node node, Set out) out.add(sigilNode); } } + if ("state".equals(op.operator) && op.operand instanceof ListNode listNode) { + for (Node element : listNode.elements) { + if (element instanceof OperatorNode sigilNode + && sigilNode.operand instanceof IdentifierNode + && "$@%".contains(sigilNode.operator)) { + out.add(sigilNode); + } + } + } collectStateDeclSigilNodes(op.operand, out); return; } @@ -98,30 +108,80 @@ private static void collectStatementLabelNamesRecursive(Node node, List * Record labels that are only reachable after a loop has initialized its * iterator and control state. An eval may not jump into such a body. */ - private static void collectLoopBodyLabels(Node node, Set out, boolean insideLoop) { + private static void collectLoopBodyLabels(Node node, Set out, + Map tokenIndices, boolean insideLoop) { if (node == null) return; if (node instanceof LabelNode labelNode) { - if (insideLoop) out.add(labelNode.label); + if (insideLoop) { + out.add(labelNode.label); + tokenIndices.putIfAbsent(labelNode.label, labelNode.getIndex()); + } return; } if (node instanceof For1Node for1) { - collectLoopBodyLabels(for1.body, out, true); - collectLoopBodyLabels(for1.continueBlock, out, true); + collectLoopBodyLabels(for1.body, out, tokenIndices, true); + collectLoopBodyLabels(for1.continueBlock, out, tokenIndices, true); return; } if (node instanceof For3Node for3) { - collectLoopBodyLabels(for3.body, out, true); - collectLoopBodyLabels(for3.continueBlock, out, true); + collectLoopBodyLabels(for3.body, out, tokenIndices, true); + collectLoopBodyLabels(for3.continueBlock, out, tokenIndices, true); return; } if (node instanceof BlockNode block) { - for (Node child : block.elements) collectLoopBodyLabels(child, out, insideLoop); + if (insideLoop) { + for (String label : block.labels) { + out.add(label); + tokenIndices.putIfAbsent(label, block.getIndex()); + } + } + for (Node child : block.elements) collectLoopBodyLabels(child, out, tokenIndices, insideLoop); + return; + } + if (node instanceof SubroutineNode subroutine) { + // An eval BLOCK is emitted as a separate JVM method but remains + // within the enclosing Perl lexical control-flow scope. Carry + // protected foreach destinations into that method so a goto is + // rejected there instead of propagating by name to a later outer + // label. Ordinary subroutines remain control-flow boundaries. + if (subroutine.useTryCatch) { + collectLoopBodyLabels(subroutine.block, out, tokenIndices, insideLoop); + } return; } if (node instanceof IfNode ifNode) { - collectLoopBodyLabels(ifNode.thenBranch, out, insideLoop); - collectLoopBodyLabels(ifNode.elseBranch, out, insideLoop); + collectLoopBodyLabels(ifNode.thenBranch, out, tokenIndices, insideLoop); + collectLoopBodyLabels(ifNode.elseBranch, out, tokenIndices, insideLoop); + return; + } + // Parser-generated wrappers such as `local $_` around foreach must + // not hide a label that is structurally in the loop body. Do not + // descend into SubroutineNode: ordinary subroutines are lexical + // control-flow boundaries and compile independently. + if (node instanceof OperatorNode operator) { + collectLoopBodyLabels(operator.operand, out, tokenIndices, insideLoop); + return; + } + if (node instanceof ListNode list) { + for (Node child : list.elements) collectLoopBodyLabels(child, out, tokenIndices, insideLoop); + return; } + if (node instanceof BinaryOperatorNode binary) { + collectLoopBodyLabels(binary.left, out, tokenIndices, insideLoop); + collectLoopBodyLabels(binary.right, out, tokenIndices, insideLoop); + return; + } + if (node instanceof TernaryOperatorNode ternary) { + collectLoopBodyLabels(ternary.condition, out, tokenIndices, insideLoop); + collectLoopBodyLabels(ternary.trueExpr, out, tokenIndices, insideLoop); + collectLoopBodyLabels(ternary.falseExpr, out, tokenIndices, insideLoop); + } + } + + /** Collect protected foreach destinations for a separately compiled eval block. */ + static void collectEvalLoopBodyLabels(Node block, JavaClassInfo javaClassInfo) { + collectLoopBodyLabels(block, javaClassInfo.gotoLabelsInsideLoop, + javaClassInfo.gotoLoopLabelTokenIndices, false); } /** @@ -133,6 +193,32 @@ private static void collectConstructEntryLabels(Node node, Set out, bool collectConstructEntryLabels(node, out, expressionContext, false); } + private static void collectGivenLabels(Node node, Set out, + Map tokenIndices, boolean insideGiven) { + if (node == null) return; + if (node instanceof LabelNode labelNode) { + if (insideGiven) { + out.add(labelNode.label); + tokenIndices.putIfAbsent(labelNode.label, labelNode.getIndex()); + } + return; + } + if (node instanceof BlockNode block) { + boolean nestedGiven = insideGiven || block.getBooleanAnnotation("givenBlock"); + if (nestedGiven) { + out.addAll(block.labels); + for (String label : block.labels) tokenIndices.putIfAbsent(label, block.getIndex()); + } + for (Node child : block.elements) collectGivenLabels(child, out, tokenIndices, nestedGiven); + return; + } + if (node instanceof IfNode conditional) { + collectGivenLabels(conditional.condition, out, tokenIndices, insideGiven); + collectGivenLabels(conditional.thenBranch, out, tokenIndices, insideGiven); + collectGivenLabels(conditional.elseBranch, out, tokenIndices, insideGiven); + } + } + private static void collectConstructEntryLabels( Node node, Set out, boolean expressionContext, boolean fieldInitializer) { if (node == null) return; @@ -144,6 +230,10 @@ private static void collectConstructEntryLabels( for (Node child : block.elements) collectConstructEntryLabels(child, out, expressionContext, fieldInitializer); return; } + if (node instanceof SubroutineNode subroutine) { + collectConstructEntryLabels(subroutine.block, out, true, fieldInitializer); + return; + } if (node instanceof OperatorNode op) { collectConstructEntryLabels(op.operand, out, true, fieldInitializer); return; @@ -170,6 +260,45 @@ private static void collectConstructEntryLabels( } } + /** Labels in binary/list operands use Perl's more specific diagnostic. */ + private static void collectBinaryOrListExpressionLabels(Node node, Set out) { + collectBinaryOrListExpressionLabels(node, out, false, false); + } + + private static void collectBinaryOrListExpressionLabels(Node node, Set out, + boolean expressionOperand, boolean fieldInitializer) { + if (node == null) return; + if (node instanceof AbstractNode abstractNode) { + fieldInitializer |= abstractNode.getBooleanAnnotation("fieldInitializer"); + } + if (node instanceof BlockNode block) { + if (expressionOperand && !fieldInitializer) out.addAll(block.labels); + for (Node child : block.elements) { + collectBinaryOrListExpressionLabels(child, out, false, fieldInitializer); + } + return; + } + if (node instanceof SubroutineNode subroutine) { + collectBinaryOrListExpressionLabels(subroutine.block, out, expressionOperand, fieldInitializer); + return; + } + if (node instanceof BinaryOperatorNode binary) { + collectBinaryOrListExpressionLabels(binary.left, out, true, fieldInitializer); + collectBinaryOrListExpressionLabels(binary.right, out, true, fieldInitializer); + return; + } + if (node instanceof ListNode list) { + for (Node child : list.elements) { + collectBinaryOrListExpressionLabels(child, out, true, fieldInitializer); + } + return; + } + if (node instanceof OperatorNode operator + && (operator.operator.equals("map") || operator.operator.equals("grep"))) { + collectBinaryOrListExpressionLabels(operator.operand, out, true, fieldInitializer); + } + } + static void collectIfChainLabels(IfNode ifNode, List out) { collectStatementLabelNamesRecursive(ifNode.thenBranch, out); if (ifNode.elseBranch instanceof IfNode elseIf) { @@ -198,8 +327,13 @@ static int pushNewGotoLabels(JavaClassInfo javaClassInfo, List labelName */ public static void emitBlock(EmitterVisitor emitterVisitor, BlockNode node) { MethodVisitor mv = emitterVisitor.ctx.mv; - collectLoopBodyLabels(node, emitterVisitor.ctx.javaClassInfo.gotoLabelsInsideLoop, false); + collectLoopBodyLabels(node, emitterVisitor.ctx.javaClassInfo.gotoLabelsInsideLoop, + emitterVisitor.ctx.javaClassInfo.gotoLoopLabelTokenIndices, false); collectConstructEntryLabels(node, emitterVisitor.ctx.javaClassInfo.gotoLabelsInsideConstruct, false); + collectBinaryOrListExpressionLabels(node, + emitterVisitor.ctx.javaClassInfo.gotoLabelsInsideBinaryOrListExpression); + collectGivenLabels(node, emitterVisitor.ctx.javaClassInfo.gotoLabelsInsideGiven, + emitterVisitor.ctx.javaClassInfo.gotoGivenLabelTokenIndices, false); // Try to refactor large blocks using the helper class if (LargeBlockRefactorer.processBlock(emitterVisitor, node)) { diff --git a/src/main/java/org/perlonjava/backend/jvm/EmitControlFlow.java b/src/main/java/org/perlonjava/backend/jvm/EmitControlFlow.java index f8f967dc6a..b53ddf456d 100644 --- a/src/main/java/org/perlonjava/backend/jvm/EmitControlFlow.java +++ b/src/main/java/org/perlonjava/backend/jvm/EmitControlFlow.java @@ -121,16 +121,12 @@ static void handleNextOperator(EmitterVisitor emitterVisitor, OperatorNode node) // Check if we're inside a defer block - control flow out of defer is prohibited if (ctx.javaClassInfo.isInDeferBlock) { - throw new PerlCompilerException(node.tokenIndex, - "Can't \"" + operator + "\" out of a \"defer\" block", - ctx.errorUtil); + throwControlFlowBlockError(ctx, node, operator, "defer"); } // Check if we're inside a finally block - control flow out of finally is prohibited if (ctx.javaClassInfo.finallyBlockDepth > 0) { - throw new PerlCompilerException(node.tokenIndex, - "Can't \"" + operator + "\" out of a \"finally\" block", - ctx.errorUtil); + throwControlFlowBlockError(ctx, node, operator, "finally"); } // Initialize label string for labeled loops @@ -176,6 +172,14 @@ static void handleNextOperator(EmitterVisitor emitterVisitor, OperatorNode node) } if (loopLabels == null) { + // A CV is a control-flow boundary: last/next/redo in an ordinary + // sub cannot target its caller's loop. Eval blocks are the one + // exception, because their markers are caught by the enclosing + // eval machinery and may target its lexical caller. + if (ctx.javaClassInfo.isSmartmatchPredicate) { + throw PerlCompilerException.withSourceLocation(node.tokenIndex, + "Can't \"" + operator + "\" outside a loop block", ctx.errorUtil); + } // Non-local control flow: return tagged RuntimeControlFlowList if (CompilerOptions.DEBUG_ENABLED) ctx.logDebug("visit(next): Non-local control flow for " + operator + " " + labelStr); @@ -305,16 +309,12 @@ static void handleReturnOperator(EmitterVisitor emitterVisitor, OperatorNode nod // Check if we're inside a defer block - return out of defer is prohibited if (ctx.javaClassInfo.isInDeferBlock) { - throw new PerlCompilerException(node.tokenIndex, - "Can't \"return\" out of a \"defer\" block", - ctx.errorUtil); + throwControlFlowBlockError(ctx, node, "return", "defer"); } // Check if we're inside a finally block - return out of finally is prohibited if (ctx.javaClassInfo.finallyBlockDepth > 0) { - throw new PerlCompilerException(node.tokenIndex, - "Can't \"return\" out of a \"finally\" block", - ctx.errorUtil); + throwControlFlowBlockError(ctx, node, "return", "finally"); } if (CompilerOptions.DEBUG_ENABLED) ctx.logDebug("visit(return) in context " + emitterVisitor.ctx.contextType); @@ -668,16 +668,12 @@ static void handleGotoLabel(EmitterVisitor emitterVisitor, OperatorNode node) { // Check if we're inside a defer block - goto out of defer is prohibited if (ctx.javaClassInfo.isInDeferBlock) { - throw new PerlCompilerException(node.tokenIndex, - "Can't \"goto\" out of a \"defer\" block", - ctx.errorUtil); + throwControlFlowBlockError(ctx, node, "goto", "defer"); } // Check if we're inside a finally block - goto out of finally is prohibited if (ctx.javaClassInfo.finallyBlockDepth > 0) { - throw new PerlCompilerException(node.tokenIndex, - "Can't \"goto\" out of a \"finally\" block", - ctx.errorUtil); + throwControlFlowBlockError(ctx, node, "goto", "finally"); } // Parse the goto argument @@ -781,14 +777,33 @@ static void handleGotoLabel(EmitterVisitor emitterVisitor, OperatorNode node) { "Dynamic goto EXPR requires interpreter fallback", ctx.errorUtil); } - if (ctx.javaClassInfo.gotoLabelsInsideConstruct.contains(labelName)) { - String fileName = ctx.compilerOptions.fileName != null - ? ctx.compilerOptions.fileName : "(eval)"; - int lineNumber = ctx.errorUtil != null ? ctx.errorUtil.getLineNumber(node.tokenIndex) : 0; + boolean gotoIntoGiven = ctx.javaClassInfo.gotoLabelsInsideGiven.contains(labelName) + && !node.getBooleanAnnotation("insideGivenBlock"); + boolean gotoIntoBinaryOrListExpression = ctx.javaClassInfo + .gotoLabelsInsideBinaryOrListExpression.contains(labelName); + if (gotoIntoGiven || gotoIntoBinaryOrListExpression + || ctx.javaClassInfo.gotoLabelsInsideConstruct.contains(labelName)) { + if (gotoIntoGiven) { + // Perl reports the destination label's location. Raise at + // compile time so an eval preserves that source location, + // rather than a synthetic instruction in the enclosing file. + Integer targetToken = ctx.javaClassInfo.gotoGivenLabelTokenIndices.get(labelName); + throw PerlCompilerException.withSourceLocation( + targetToken != null ? targetToken : node.tokenIndex, + "Can't \"goto\" into a \"given\" block", ctx.errorUtil); + } + String errorMessage = gotoIntoBinaryOrListExpression + ? "Can't \"goto\" into a binary or list expression" + : "Use of \"goto\" to jump into a construct is no longer permitted"; + var location = ctx.errorUtil != null + ? ctx.errorUtil.getSourceLocationAccurate(node.tokenIndex) : null; + String fileName = location != null ? location.fileName() + : (ctx.compilerOptions.fileName != null ? ctx.compilerOptions.fileName : "(eval)"); + int lineNumber = location != null ? location.lineNumber() : 0; ctx.mv.visitTypeInsn(Opcodes.NEW, "org/perlonjava/runtime/runtimetypes/RuntimeScalar"); ctx.mv.visitInsn(Opcodes.DUP); - ctx.mv.visitLdcInsn("Use of \"goto\" to jump into a construct is no longer permitted"); + ctx.mv.visitLdcInsn(errorMessage); ctx.mv.visitMethodInsn(Opcodes.INVOKESPECIAL, "org/perlonjava/runtime/runtimetypes/RuntimeScalar", "", "(Ljava/lang/String;)V", false); @@ -815,14 +830,22 @@ static void handleGotoLabel(EmitterVisitor emitterVisitor, OperatorNode node) { // For static label, check if it's local GotoLabels targetLabel = ctx.javaClassInfo.findGotoLabelsByName(labelName); if (targetLabel == null) { - if (ctx.javaClassInfo.isInEvalBlock - && ctx.javaClassInfo.gotoLabelsInsideLoop.contains(labelName)) { - // This is a run-time eval failure, not a source parse error: - // emit die so the surrounding eval catches it and sets $@. - String fileName = ctx.compilerOptions.fileName != null - ? ctx.compilerOptions.fileName : "(eval)"; - int lineNumber = ctx.errorUtil != null - ? ctx.errorUtil.getLineNumber(node.tokenIndex) : 0; + if (ctx.javaClassInfo.isSmartmatchPredicate) { + throw PerlCompilerException.withSourceLocation(node.tokenIndex, + "Can't find label " + labelName, ctx.errorUtil); + } + if (ctx.javaClassInfo.gotoLabelsInsideLoop.contains(labelName)) { + // A label in a foreach body is not a valid destination from + // outside that body: its iterator/control-block setup has not + // run. This applies equally to source-level and eval gotos. + // Emit die so an enclosing eval can still catch it and set $@. + Integer destinationToken = ctx.javaClassInfo.gotoLoopLabelTokenIndices.get(labelName); + int locationToken = destinationToken != null ? destinationToken : node.tokenIndex; + var location = ctx.errorUtil != null + ? ctx.errorUtil.getSourceLocationAccurate(locationToken) : null; + String fileName = location != null ? location.fileName() + : (ctx.compilerOptions.fileName != null ? ctx.compilerOptions.fileName : "(eval)"); + int lineNumber = location != null ? location.lineNumber() : 0; ctx.mv.visitTypeInsn(Opcodes.NEW, "org/perlonjava/runtime/runtimetypes/RuntimeScalar"); ctx.mv.visitInsn(Opcodes.DUP); @@ -881,4 +904,12 @@ static void handleGotoLabel(EmitterVisitor emitterVisitor, OperatorNode node) { // Emit the goto instruction ctx.mv.visitJumpInsn(Opcodes.GOTO, targetLabel.gotoLabel); } + + private static void throwControlFlowBlockError(EmitterContext ctx, OperatorNode node, + String operator, String blockType) { + var location = ctx.errorUtil.getSourceLocationAccurate(node.tokenIndex); + throw new PerlCompilerException("Can't \"" + operator + "\" out of a \"" + + blockType + "\" block at " + location.fileName() + " line " + + location.lineNumber() + ".\n"); + } } diff --git a/src/main/java/org/perlonjava/backend/jvm/EmitForeach.java b/src/main/java/org/perlonjava/backend/jvm/EmitForeach.java index f29a0f56c2..2f463c93bd 100644 --- a/src/main/java/org/perlonjava/backend/jvm/EmitForeach.java +++ b/src/main/java/org/perlonjava/backend/jvm/EmitForeach.java @@ -178,6 +178,17 @@ public static void emitFor1(EmitterVisitor emitterVisitor, For1Node node) { // Use the variable node without the declaration for codegen, but do not mutate the AST. variableNode = opNode.operand; + // `foreach my \$x (...)` is represented as a declared-reference + // annotation on the declaration, rather than as a literal leading + // backslash node. Preserve that distinction for the iteration + // lowering: declared references must validate and bind each input + // reference, not receive ordinary foreach assignment. + if (opNode.getBooleanAnnotation("isDeclaredReference") + && variableNode instanceof OperatorNode declaredReferenceTarget) { + variableNode = new OperatorNode("\\", declaredReferenceTarget, + declaredReferenceTarget.tokenIndex); + } + if (opNode.operator.equals("my") && variableNode instanceof OperatorNode declVar && declVar.operator.equals("$") && declVar.operand instanceof IdentifierNode declId) { String varName = declVar.operator + declId.name; @@ -245,6 +256,17 @@ public static void emitFor1(EmitterVisitor emitterVisitor, For1Node node) { isReferenceAliasing = true; actualVariable = opNode.operand; // Get the actual variable ($x, @x, %x) + // `for \my $x (...)` retains the declaration beneath the + // reference operator. Lower it to its sigil target just like + // `for \$x (...)`, so the reference validator is selected for + // every list element (including sparse-array undef slots). + if (actualVariable instanceof OperatorNode declaration + && (declaration.operator.equals("my") || declaration.operator.equals("our") + || declaration.operator.equals("state")) + && declaration.operand instanceof OperatorNode sigil) { + actualVariable = sigil; + } + // Allocate a temporary variable to save the current value savedValueIndex = emitterVisitor.ctx.symbolTable.allocateLocalVariable(); @@ -551,24 +573,28 @@ public static void emitFor1(EmitterVisitor emitterVisitor, For1Node node) { // Reference-alias loop variables bind to the referenced cell, not // to the RuntimeScalar that holds the reference. if (isReferenceAliasing && actualVariable instanceof OperatorNode innerOp) { + // The validation below is emitted directly rather than through + // a child node visitor. Give it the iterator variable's COP + // so runtime errors retain the iterator's #line location. + ByteCodeSourceMapper.setDebugInfoLineNumber(emitterVisitor.ctx, innerOp.getIndex()); if (innerOp.operator.equals("$")) { mv.visitMethodInsn(Opcodes.INVOKEVIRTUAL, "org/perlonjava/runtime/runtimetypes/RuntimeScalar", - "scalarDeref", + "foreachScalarReference", "()Lorg/perlonjava/runtime/runtimetypes/RuntimeScalar;", false); } else if (innerOp.operator.equals("@")) { // Array: dereference scalar to get RuntimeArray mv.visitMethodInsn(Opcodes.INVOKEVIRTUAL, "org/perlonjava/runtime/runtimetypes/RuntimeScalar", - "arrayDeref", + "foreachArrayReference", "()Lorg/perlonjava/runtime/runtimetypes/RuntimeArray;", false); } else if (innerOp.operator.equals("%")) { // Hash: dereference scalar to get RuntimeHash mv.visitMethodInsn(Opcodes.INVOKEVIRTUAL, "org/perlonjava/runtime/runtimetypes/RuntimeScalar", - "hashDeref", + "foreachHashReference", "()Lorg/perlonjava/runtime/runtimetypes/RuntimeHash;", false); } diff --git a/src/main/java/org/perlonjava/backend/jvm/EmitLogicalOperator.java b/src/main/java/org/perlonjava/backend/jvm/EmitLogicalOperator.java index 758d1f946c..ada6ce5cef 100644 --- a/src/main/java/org/perlonjava/backend/jvm/EmitLogicalOperator.java +++ b/src/main/java/org/perlonjava/backend/jvm/EmitLogicalOperator.java @@ -164,6 +164,19 @@ static void emitLogicalAssign(EmitterVisitor emitterVisitor, BinaryOperatorNode } private static Node scalarizeSingleElementSliceLvalue(Node left) { + // `state ($value) //= ...` has a declaration ListNode around a single + // scalar target. Logical assignment is scalar here, just as it is for + // `state $value //= ...`; retaining the list makes the assignment write + // to a temporary RuntimeList instead of the persistent scalar. + if (left instanceof OperatorNode declaration + && "state".equals(declaration.operator) + && declaration.operand instanceof ListNode list + && list.elements.size() == 1 + && list.elements.getFirst() instanceof OperatorNode target + && "$@%".contains(target.operator)) { + return new OperatorNode("state", target, declaration.tokenIndex); + } + // Parentheses are represented as a one-element ListNode in some nested // expression shapes. Perl still treats ($scalar) as the scalar lvalue; // emitting the list node directly leaves a RuntimeList on the stack and diff --git a/src/main/java/org/perlonjava/backend/jvm/EmitOperatorLocal.java b/src/main/java/org/perlonjava/backend/jvm/EmitOperatorLocal.java index b65cf31871..e549219dcd 100644 --- a/src/main/java/org/perlonjava/backend/jvm/EmitOperatorLocal.java +++ b/src/main/java/org/perlonjava/backend/jvm/EmitOperatorLocal.java @@ -6,6 +6,7 @@ import org.perlonjava.frontend.analysis.LValueVisitor; import org.perlonjava.frontend.astnode.*; import org.perlonjava.runtime.runtimetypes.NameNormalizer; +import org.perlonjava.runtime.runtimetypes.PerlCompilerException; import org.perlonjava.runtime.runtimetypes.RuntimeContextType; public class EmitOperatorLocal { @@ -32,6 +33,39 @@ static void handleLocal(EmitterVisitor emitterVisitor, OperatorNode node) { return; } + Node localOperand = node.operand; + if (localOperand instanceof OperatorNode sigilNode + && (sigilNode.operator.equals("@") || sigilNode.operator.equals("%"))) { + Node dereferenceOperand = sigilNode.operand; + if (dereferenceOperand instanceof BlockNode block && block.elements.size() == 1) { + dereferenceOperand = block.elements.getFirst(); + } + if (dereferenceOperand instanceof OperatorNode dereference + && dereference.operator.equals("\\")) { + // This error is runtime-visible: `eval { local %{$ref} }` + // must catch it rather than abort compilation of the outer + // program. Match the interpreter's REJECT_LOCALIZE_REFERENCE + // opcode by evaluating the reference and rejecting it here. + var location = emitterVisitor.ctx.errorUtil + .getSourceLocationAccurate(node.tokenIndex); + mv.visitLdcInsn("Can't localize through a reference at " + + location.fileName() + " line " + location.lineNumber() + ".\n"); + mv.visitMethodInsn(Opcodes.INVOKESTATIC, + "org/perlonjava/runtime/runtimetypes/RuntimeScalar", + "rejectLocalizeThroughReference", + "(Ljava/lang/String;)V", + false); + // The helper always throws, but retain a formal scalar result + // on the unreachable normal-flow path for ASM frame merging. + mv.visitFieldInsn(Opcodes.GETSTATIC, + "org/perlonjava/runtime/runtimetypes/RuntimeScalarCache", + "scalarUndef", + "Lorg/perlonjava/runtime/runtimetypes/RuntimeScalar;"); + EmitOperator.handleVoidContext(emitterVisitor); + return; + } + } + if (node.operand instanceof OperatorNode opNode && opNode.operator.equals("$")) { // Check if the variable is global or 'our' variable if (opNode.operand instanceof IdentifierNode idNode) { diff --git a/src/main/java/org/perlonjava/backend/jvm/EmitSubroutine.java b/src/main/java/org/perlonjava/backend/jvm/EmitSubroutine.java index 1e23f54d51..8756446778 100644 --- a/src/main/java/org/perlonjava/backend/jvm/EmitSubroutine.java +++ b/src/main/java/org/perlonjava/backend/jvm/EmitSubroutine.java @@ -244,6 +244,8 @@ && isDirectLeafIntegerAddition(node.block, directLeafCaptures, // Create the new method context JavaClassInfo newJavaClassInfo = new JavaClassInfo(); + newJavaClassInfo.isSubroutineBody = !node.useTryCatch; + newJavaClassInfo.isSmartmatchPredicate = node.getBooleanAnnotation("smartmatchPredicate"); // Eval blocks are compiled as separate methods, but a goto inside one // still observes labels structurally contained by the enclosing method. // Carry the loop-body set so it can reject an illegal entry before the @@ -251,6 +253,13 @@ && isDirectLeafIntegerAddition(node.block, directLeafCaptures, if (ctx.javaClassInfo != null) { newJavaClassInfo.gotoLabelsInsideLoop.addAll(ctx.javaClassInfo.gotoLabelsInsideLoop); } + if (node.useTryCatch) { + // The eval body is compiled into a fresh method before its own + // visitor has emitted control flow. Establish its protected + // foreach destinations now, rather than relying on labels from + // the parent method's later traversal. + EmitBlock.collectEvalLoopBodyLabels(node.block, newJavaClassInfo); + } // Check if this subroutine is a defer block - control flow restrictions apply Boolean isDeferBlock = (Boolean) node.getAnnotation("isDeferBlock"); @@ -452,6 +461,24 @@ && isDirectLeafIntegerAddition(node.block, directLeafCaptures, "(Lorg/perlonjava/runtime/runtimetypes/RuntimeScalar;)Lorg/perlonjava/runtime/runtimetypes/RuntimeScalar;", false); } + if (node.getBooleanAnnotation("generatedClassConstructor") + || (node.block instanceof AbstractNode blockNode + && blockNode.getBooleanAnnotation("generatedClassConstructor"))) { + mv.visitMethodInsn(Opcodes.INVOKESTATIC, + "org/perlonjava/runtime/runtimetypes/RuntimeCode", + "markGeneratedClassConstructor", + "(Lorg/perlonjava/runtime/runtimetypes/RuntimeScalar;)Lorg/perlonjava/runtime/runtimetypes/RuntimeScalar;", + false); + } + if (node.getBooleanAnnotation("classAdjustBlock") + || (node.block instanceof AbstractNode blockNode + && blockNode.getBooleanAnnotation("classAdjustBlock"))) { + mv.visitMethodInsn(Opcodes.INVOKESTATIC, + "org/perlonjava/runtime/runtimetypes/RuntimeCode", + "markClassAdjustBlock", + "(Lorg/perlonjava/runtime/runtimetypes/RuntimeScalar;)Lorg/perlonjava/runtime/runtimetypes/RuntimeScalar;", + false); + } if (node.getAnnotation("lexicalSubDisplayName") instanceof String lexicalName) { mv.visitLdcInsn(lexicalName); mv.visitMethodInsn(Opcodes.INVOKESTATIC, @@ -1147,11 +1174,17 @@ static void handleApplyOperator(EmitterVisitor emitterVisitor, BinaryOperatorNod mv.visitVarInsn(Opcodes.ALOAD, codeRefSlot); mv.visitVarInsn(Opcodes.ALOAD, nameSlot); + Object precedingLabel = node.getAnnotation("precedingLabel"); + if (precedingLabel instanceof String label) { + mv.visitLdcInsn(label); + } else { + mv.visitInsn(Opcodes.ACONST_NULL); + } mv.visitMethodInsn( Opcodes.INVOKESTATIC, "org/perlonjava/runtime/runtimetypes/RuntimeCode", "throwIfDirectCallUndefined", - "(Lorg/perlonjava/runtime/runtimetypes/RuntimeScalar;Ljava/lang/String;)V", + "(Lorg/perlonjava/runtime/runtimetypes/RuntimeScalar;Ljava/lang/String;Ljava/lang/String;)V", false); // Set debug line number to the call site. Perl reports the enclosing @@ -1179,11 +1212,23 @@ static void handleApplyOperator(EmitterVisitor emitterVisitor, BinaryOperatorNod mv.visitVarInsn(Opcodes.ALOAD, nameSlot); mv.visitVarInsn(Opcodes.ALOAD, argsArraySlot); emitterVisitor.pushCallContext(); // Push call context to stack + String callerPackage = emitterVisitor.ctx.symbolTable.getCurrentPackage(); + String callerFile = emitterVisitor.ctx.compilerOptions.fileName; + int callerLine = 0; + if (emitterVisitor.ctx.errorUtil != null && callSiteIndex > 0) { + var callerLocation = emitterVisitor.ctx.errorUtil + .getSourceLocationAccurate(callSiteIndex); + callerFile = callerLocation.fileName(); + callerLine = callerLocation.lineNumber(); + } + mv.visitLdcInsn(callerPackage == null ? "main" : callerPackage); + mv.visitLdcInsn(callerFile == null ? "-e" : callerFile); + mv.visitLdcInsn(callerLine); mv.visitMethodInsn( Opcodes.INVOKESTATIC, "org/perlonjava/runtime/runtimetypes/RuntimeCode", - "apply", - "(Lorg/perlonjava/runtime/runtimetypes/RuntimeScalar;Ljava/lang/String;[Lorg/perlonjava/runtime/runtimetypes/RuntimeBase;I)Lorg/perlonjava/runtime/runtimetypes/RuntimeList;", + "applyAtLocation", + "(Lorg/perlonjava/runtime/runtimetypes/RuntimeScalar;Ljava/lang/String;[Lorg/perlonjava/runtime/runtimetypes/RuntimeBase;ILjava/lang/String;Ljava/lang/String;I)Lorg/perlonjava/runtime/runtimetypes/RuntimeList;", false); // Generate an .apply() call if (pooledArgsArray) { diff --git a/src/main/java/org/perlonjava/backend/jvm/EmitVariable.java b/src/main/java/org/perlonjava/backend/jvm/EmitVariable.java index e34b0469e1..c7e509e447 100644 --- a/src/main/java/org/perlonjava/backend/jvm/EmitVariable.java +++ b/src/main/java/org/perlonjava/backend/jvm/EmitVariable.java @@ -281,7 +281,7 @@ private static void fetchGlobalVariable(EmitterContext ctx, boolean createIfNotE } // Variable not found and not allowed under strict - throw new PerlCompilerException( + throw PerlCompilerException.withSourceLocation( tokenIndex, "Global symbol \"" + sigil + varName @@ -1752,6 +1752,14 @@ static void handleMyOperator(EmitterVisitor emitterVisitor, OperatorNode node) { // Create and fetch a global variable fetchGlobalVariable(emitterVisitor.ctx, true, sigil, name, node.getIndex()); } + if (sigil.equals("$") && !operator.equals("our")) { + ctx.mv.visitLdcInsn(var); + ctx.mv.visitMethodInsn(Opcodes.INVOKEVIRTUAL, + "org/perlonjava/runtime/runtimetypes/RuntimeScalar", + "setLexicalDisplayName", + "(Ljava/lang/String;)Lorg/perlonjava/runtime/runtimetypes/RuntimeScalar;", + false); + } // Store the variable in a JVM local variable emitterVisitor.ctx.mv.visitVarInsn(Opcodes.ASTORE, varIndex); diff --git a/src/main/java/org/perlonjava/backend/jvm/EmitterMethodCreator.java b/src/main/java/org/perlonjava/backend/jvm/EmitterMethodCreator.java index 9759e9ac99..4c8d80a6cc 100644 --- a/src/main/java/org/perlonjava/backend/jvm/EmitterMethodCreator.java +++ b/src/main/java/org/perlonjava/backend/jvm/EmitterMethodCreator.java @@ -811,6 +811,23 @@ private static byte[] getBytecodeInternal(EmitterContext ctx, Node ast, boolean mv.visitJumpInsn(Opcodes.IFEQ, normalReturn); // Not marked, return normally // Marked with non-TAILCALL marker (LAST/NEXT/REDO/GOTO/RETURN) + // A compiled named/anonymous sub bypasses RuntimeCode.apply() + // when the emitter can invoke its PerlSubroutine directly, so + // enforce the escaping-loop-control boundary here as well. + // Eval blocks intentionally defer this to their caller. + if (!useTryCatch) { + mv.visitVarInsn(Opcodes.ALOAD, returnListSlot); + mv.visitInsn(Boolean.TRUE.equals(ast.getAnnotation("generatedClassConstructor")) + ? Opcodes.ICONST_1 : Opcodes.ICONST_0); + mv.visitInsn(Boolean.TRUE.equals(ast.getAnnotation("classAdjustBlock")) + ? Opcodes.ICONST_1 : Opcodes.ICONST_0); + mv.visitMethodInsn(Opcodes.INVOKESTATIC, + "org/perlonjava/runtime/runtimetypes/RuntimeCode", + "handleEscapingLoopControl", + "(Lorg/perlonjava/runtime/runtimetypes/RuntimeList;ZZ)Lorg/perlonjava/runtime/runtimetypes/RuntimeList;", + false); + mv.visitVarInsn(Opcodes.ASTORE, returnListSlot); + } if (useTryCatch) { // For eval BLOCK: RETURN markers should propagate (not error), // because 'return' inside map/grep inside eval should exit the enclosing sub. diff --git a/src/main/java/org/perlonjava/backend/jvm/JavaClassInfo.java b/src/main/java/org/perlonjava/backend/jvm/JavaClassInfo.java index bcb8925f7f..9c04fc347e 100644 --- a/src/main/java/org/perlonjava/backend/jvm/JavaClassInfo.java +++ b/src/main/java/org/perlonjava/backend/jvm/JavaClassInfo.java @@ -92,6 +92,10 @@ public class JavaClassInfo { * goto &sub from eval blocks is prohibited ("Can't goto subroutine from an eval-block"). */ public boolean isInEvalBlock; + /** True while emitting a normal subroutine body, rather than an eval block. */ + public boolean isSubroutineBody; + /** A smartmatch RHS predicate CV cannot target a caller's loop or label. */ + public boolean isSmartmatchPredicate; /** * Flag indicating if this method is compiled for an eval string (eval 'string'). @@ -167,8 +171,16 @@ public boolean isCapturedVariableIndex(int index) { public Deque gotoLabelStack; /** Labels structurally located in a loop body, which eval may not enter. */ public Set gotoLabelsInsideLoop; + /** Source token of a loop-body label, used for Perl's destination diagnostic. */ + public Map gotoLoopLabelTokenIndices; /** Labels in expression-level do blocks, which goto may not enter. */ public Set gotoLabelsInsideConstruct; + /** Labels in binary or list expression operands, with Perl's specific diagnostic. */ + public Set gotoLabelsInsideBinaryOrListExpression; + /** Labels inside given blocks, which goto may not enter. */ + public Set gotoLabelsInsideGiven; + /** Source token of a label inside a given block, used for Perl's destination diagnostic. */ + public Map gotoGivenLabelTokenIndices; /** * Map of loop state signature to block-level dispatcher label. * Allows multiple call sites with the same visible loops to share one dispatcher. @@ -194,7 +206,11 @@ public JavaClassInfo() { this.loopLabelStack = new ArrayDeque<>(); this.gotoLabelStack = new ArrayDeque<>(); this.gotoLabelsInsideLoop = new HashSet<>(); + this.gotoLoopLabelTokenIndices = new HashMap<>(); this.gotoLabelsInsideConstruct = new HashSet<>(); + this.gotoLabelsInsideBinaryOrListExpression = new HashSet<>(); + this.gotoLabelsInsideGiven = new HashSet<>(); + this.gotoGivenLabelTokenIndices = new HashMap<>(); this.blockDispatcherLabels = new HashMap<>(); this.spillSlots = new int[0]; this.spillTop = 0; diff --git a/src/main/java/org/perlonjava/frontend/lexer/Lexer.java b/src/main/java/org/perlonjava/frontend/lexer/Lexer.java index ad41565160..fce7897e8e 100644 --- a/src/main/java/org/perlonjava/frontend/lexer/Lexer.java +++ b/src/main/java/org/perlonjava/frontend/lexer/Lexer.java @@ -69,7 +69,23 @@ public Lexer(String input) { } private static boolean isPerlIdentifierStart(int codePoint) { - return codePoint == '_' || UCharacter.hasBinaryProperty(codePoint, UProperty.XID_START); + return codePoint == '_' || UCharacter.hasBinaryProperty(codePoint, UProperty.XID_START) + || isNewerPerlXidStart(codePoint); + } + + // Perl's bundled Unicode table is newer than the ICU table used here. Keep + // this intentionally narrow: Character.isUnicodeIdentifierStart also + // admits compatibility characters Perl rejects as XIDS. + private static boolean isNewerPerlXidStart(int cp) { + return cp == 0x088F || cp == 0x0C5C || cp == 0x0CDC || cp == 0x1885 || cp == 0x1886 + || cp == 0x2118 || cp == 0x212E || cp == 0x3007 || cp == 0x3038 || cp == 0x3039 || cp == 0x303A + || cp == 0xA7CE || cp == 0xA7CF || cp == 0xA7D2 || cp == 0xA7D4 || cp == 0xA7F1 + || (cp >= 0x16EE && cp <= 0x16F0) + || (cp >= 0x2160 && cp <= 0x217F) + || (cp >= 0x2180 && cp <= 0x2182) + || (cp >= 0x2185 && cp <= 0x2188) + || (cp >= 0x3021 && cp <= 0x3029) + || (cp >= 0xA6E6 && cp <= 0xA6EF); } private static boolean isPerlIdentifierPart(int codePoint) { diff --git a/src/main/java/org/perlonjava/frontend/parser/ClassTransformer.java b/src/main/java/org/perlonjava/frontend/parser/ClassTransformer.java index 507a8c8183..d6b8ed0974 100644 --- a/src/main/java/org/perlonjava/frontend/parser/ClassTransformer.java +++ b/src/main/java/org/perlonjava/frontend/parser/ClassTransformer.java @@ -2,6 +2,7 @@ import org.perlonjava.frontend.astnode.*; import org.perlonjava.runtime.runtimetypes.GlobalVariable; +import org.perlonjava.runtime.runtimetypes.PerlCompilerException; import org.perlonjava.runtime.runtimetypes.RuntimeCode; import org.perlonjava.runtime.runtimetypes.RuntimeScalar; import org.perlonjava.runtime.runtimetypes.RuntimeScalarType; @@ -132,8 +133,14 @@ public static BlockNode transformClassBlock(BlockNode block, String className, P Node isaAssignment = generateIsaAssignment(className, parentClass); block.elements.add(isaAssignment); } + // Perl classes expose @ISA for introspection but do not permit it + // to be altered after the declaration (including classes without + // a :isa attribute). + block.elements.add(generateReadonlyIsa(className)); } + validateParameterNames(fields, className, parser); + // Transform user-defined methods but DEFER their registration // They'll be registered AFTER scope exit in StatementParser // Unlike generated methods, they DON'T use filtering (can capture class-level lexicals) @@ -162,12 +169,22 @@ public static BlockNode transformClassBlock(BlockNode block, String className, P List deferredAccessors = new ArrayList<>(); for (OperatorNode field : fields) { if (field.getAnnotation("attr:reader") != null) { + String readerName = (String) field.getAnnotation("attr:reader"); + validateGeneratedMethodName(parser, field, + readerName == null || readerName.isEmpty() + ? defaultAccessorName((String) field.getAnnotation("name")) : readerName); SubroutineNode reader = generateReaderMethod(field, className); block.elements.add(reader); deferredAccessors.add(reader); } if (field.getAnnotation("attr:writer") != null) { + if (!"$".equals(field.getAnnotation("sigil"))) { + throw PerlCompilerException.withSourceLocation(field.getIndex(), + "Cannot apply a :writer attribute to a non-scalar field", + parser.ctx.errorUtil); + } + validateGeneratedMethodName(parser, field, (String) field.getAnnotation("attr:writer")); SubroutineNode writer = generateWriterMethod(field); block.elements.add(writer); deferredAccessors.add(writer); @@ -201,6 +218,52 @@ public static BlockNode transformClassBlock(BlockNode block, String className, P return block; } + private static void validateGeneratedMethodName(Parser parser, OperatorNode field, String name) { + if (name == null || name.isEmpty()) { + return; + } + if (!isValidMethodIdentifier(name)) { + throw PerlCompilerException.withSourceLocation(field.getIndex(), + "\"" + name + "\" is not a valid name for a generated method", + parser.ctx.errorUtil); + } + } + + private static void validateParameterNames(List fields, String className, Parser parser) { + java.util.Set names = FieldRegistry.getParameterNamesInHierarchy(className); + for (OperatorNode field : fields) { + String parameter = (String) field.getAnnotation("attr:param"); + if (parameter == null) { + continue; + } + if (parameter.isEmpty()) { + parameter = (String) field.getAnnotation("name"); + } + if (!names.add(parameter)) { + throw PerlCompilerException.withSourceLocation(field.getIndex(), + "Cannot assign :param(" + parameter + ") to field " + + field.getAnnotation("sigil") + field.getAnnotation("name") + + " because that name is already in use", parser.ctx.errorUtil); + } + FieldRegistry.registerParameterName(className, parameter); + } + } + + private static boolean isValidMethodIdentifier(String name) { + if (name.isEmpty() + || (name.codePointAt(0) != '_' && !Character.isUnicodeIdentifierStart(name.codePointAt(0)))) { + return false; + } + for (int offset = Character.charCount(name.codePointAt(0)); offset < name.length();) { + int codePoint = name.codePointAt(offset); + if (codePoint != '_' && !Character.isUnicodeIdentifierPart(codePoint)) { + return false; + } + offset += Character.charCount(codePoint); + } + return true; + } + /** * Generate a constructor (new) method from field declarations. *

@@ -231,6 +294,7 @@ static void transformUnitClassMethod(SubroutineNode method) { private static SubroutineNode generateConstructor(List fields, String className, List adjustNodes) { List bodyElements = new ArrayList<>(); BlockNode body = new BlockNode(bodyElements, 0); + body.setAnnotation("generatedClassConstructor", Boolean.TRUE); // MINIMAL CONSTRUCTOR - Start with just bless {} and return // We'll add statements back one by one to identify the bytecode issue @@ -254,6 +318,27 @@ private static SubroutineNode generateConstructor(List fields, Str new OperatorNode("@", new IdentifierNode("_", 0), 0), 0); body.elements.add(argsAssign); + // Required :param fields must be present in the argument hash. An + // explicitly supplied undef is valid, so defined-or is not suitable: + // only the hash entry's existence determines whether it is missing. + for (OperatorNode field : fields) { + if (!isRequiredParameterField(field)) { + continue; + } + String paramName = parameterName(field); + + OperatorNode argsVar = new OperatorNode("$", new IdentifierNode("args", 0), 0); + HashLiteralNode parameterKey = new HashLiteralNode(List.of(new StringNode(paramName, 0)), 0); + BinaryOperatorNode parameterAccess = new BinaryOperatorNode("{", argsVar, parameterKey, 0); + OperatorNode exists = new OperatorNode("exists", new ListNode(List.of(parameterAccess), 0), 0); + OperatorNode missing = new OperatorNode("!", exists, 0); + String message = "Required parameter '" + paramName + "' is missing for \"" + + className + "\" constructor"; + OperatorNode die = new OperatorNode("die", new ListNode(List.of(new StringNode(message, 0)), 0), 0); + body.elements.add(new IfNode("if", missing, + new BlockNode(new ArrayList<>(List.of(die)), 0), null, 0)); + } + // Step 3: Create $self - either by calling SUPER::new or blessing empty hash ListNode mySelfDecl = new ListNode(0); OperatorNode mySelf = new OperatorNode("my", @@ -288,7 +373,10 @@ private static SubroutineNode generateConstructor(List fields, Str ListNode emptyList = new ListNode(0); HashLiteralNode emptyHash = new HashLiteralNode(emptyList.elements, 0); OperatorNode classVar = new OperatorNode("$", new IdentifierNode("class", 0), 0); - selfValue = new BinaryOperatorNode("bless", emptyHash, classVar, 0); + // Use a distinct internal operator rather than an annotation: generated + // subroutines are cloned before JVM emission and node annotations do not + // survive that route. + selfValue = new BinaryOperatorNode("blessClassInstance", emptyHash, classVar, 0); } // my $self = ; @@ -304,13 +392,6 @@ private static SubroutineNode generateConstructor(List fields, Str } } - // Step 3.5: TODO - Parameter validation temporarily disabled - // The parameter validation implementation is hitting operator implementation issues - // (delete and if operators not fully implemented for our use case) - // We'll revisit this with a simpler approach later - - // For now, leaving parameter validation disabled to continue progress on other tests - // Step 4: Run ADJUST blocks after field initialization // ADJUST blocks are anonymous subs that need to be called with $self // They run in the order they appear in the class @@ -403,10 +484,26 @@ private static SubroutineNode generateConstructor(List fields, Str false, // isAnonymous 0 // tokenIndex ); + constructor.setAnnotation("generatedClassConstructor", Boolean.TRUE); return constructor; } + private static boolean isRequiredParameterField(OperatorNode field) { + return field.getAnnotation("attr:param") != null + && !field.getBooleanAnnotation("hasDefault"); + } + + /** Return the external constructor parameter name for a :param field. */ + private static String parameterName(OperatorNode field) { + String explicitName = (String) field.getAnnotation("attr:param"); + if (explicitName != null && !explicitName.isEmpty()) { + return explicitName; + } + String fieldName = (String) field.getAnnotation("name"); + return fieldName.startsWith("_") ? fieldName.substring(1) : fieldName; + } + /** * Generate field initialization code for the constructor. */ @@ -415,8 +512,8 @@ private static Node generateFieldInitialization(OperatorNode field) { String name = (String) field.getAnnotation("name"); String paramName = (String) field.getAnnotation("attr:param"); boolean hasParam = paramName != null; - if (paramName == null || paramName.isEmpty()) { - paramName = name; + if (hasParam) { + paramName = parameterName(field); } boolean hasDefault = field.getBooleanAnnotation("hasDefault"); String defaultOperator = (String) field.getAnnotation("defaultOperator"); // =, //=, or ||= @@ -459,6 +556,7 @@ private static Node generateFieldInitialization(OperatorNode field) { BinaryOperatorNode selfField = new BinaryOperatorNode("->", selfVar, hashSubscript, 0); Node value; + Node parameterAccess = null; if (hasParam) { // $args{paramname} // default_or_undef // Use correct structure: %args becomes $args in hash access @@ -467,6 +565,7 @@ private static Node generateFieldInitialization(OperatorNode field) { argKeyList.add(new StringNode(paramName, 0)); HashLiteralNode argHashSubscript = new HashLiteralNode(argKeyList, 0); BinaryOperatorNode argsAccess = new BinaryOperatorNode("{", argsVar, argHashSubscript, 0); + parameterAccess = argsAccess; if (hasDefault) { // Handle different default operators: @@ -474,11 +573,19 @@ private static Node generateFieldInitialization(OperatorNode field) { // //= means use default only if param is undefined // ||= means use default only if param is false/empty if ("=".equals(defaultOperator)) { - // Standard default - use // operator (defined-or) + // `=` defaults a missing parameter, but preserves an + // explicitly supplied undef. Defined-or cannot make that + // distinction, so test existence of the named hash entry. + OperatorNode exists = new OperatorNode("exists", + new ListNode(List.of(argsAccess), 0), 0); + value = new TernaryOperatorNode("?", exists, argsAccess, defaultValue, 0); + } else if ("//=".equals(defaultOperator)) { + // The parameter hash entry may be an undef proxy. Resolve + // its definedness before assigning it to the object field. value = new BinaryOperatorNode("//", argsAccess, defaultValue, 0); + } else if ("||=".equals(defaultOperator)) { + value = new BinaryOperatorNode("||", argsAccess, defaultValue, 0); } else { - // For //= and ||=, the value itself acts as the default - // We'll handle this differently below value = argsAccess; } } else if ("@".equals(sigil)) { @@ -511,9 +618,22 @@ private static Node generateFieldInitialization(OperatorNode field) { } // Handle different assignment operators for field initialization - if (hasDefault && "//=".equals(defaultOperator)) { - // For //= operator: $self->{field} //= default - // This assigns the default only if the field is undefined + if (hasParam && hasDefault && "||=".equals(defaultOperator)) { + // Preserve ||= as an lvalue operation. Its argument may be a + // hash-entry proxy whose truth value must be resolved after it is + // installed in the object field. + List statements = new ArrayList<>(); + BinaryOperatorNode parameterAssignment = new BinaryOperatorNode("=", selfField, parameterAccess, 0); + parameterAssignment.setAnnotation("fieldInitializer", true); + statements.add(parameterAssignment); + BinaryOperatorNode initialization = new BinaryOperatorNode("||=", selfField, defaultValue, 0); + initialization.setAnnotation("fieldInitializer", true); + statements.add(initialization); + BlockNode initializationBlock = new BlockNode(statements, 0); + initializationBlock.setAnnotation("fieldInitializer", true); + return initializationBlock; + } else if (hasDefault && "//=".equals(defaultOperator) && !hasParam) { + // For non-parameter fields: $self->{field} //= default BinaryOperatorNode initialization = new BinaryOperatorNode("//=", selfField, defaultValue, 0); initialization.setAnnotation("fieldInitializer", true); return initialization; @@ -587,10 +707,13 @@ private static SubroutineNode generateReaderMethod(OperatorNode field, String cl * This modifies the method in place. */ private static void transformMethod(SubroutineNode method, List fields) { - if (method.getBooleanAnnotation("methodSelfInjected")) { + if (method.block == null || !(method.block instanceof BlockNode methodBody)) { return; } - if (method.block == null || !(method.block instanceof BlockNode methodBody)) { + + methodBody.setAnnotation("isClassMethod", true); + + if (method.getBooleanAnnotation("methodSelfInjected")) { return; } @@ -720,6 +843,19 @@ private static Node generateIsaAssignment(String className, String parentClass) return new BinaryOperatorNode("=", isaArray, parentListNode, 0); } + /** Seal a class's inheritance list after its generated {@code :isa} assignment. */ + private static Node generateReadonlyIsa(String className) { + OperatorNode isaArray = new OperatorNode("@", + new IdentifierNode(className + "::ISA", 0), 0); + OperatorNode isaReference = new OperatorNode("\\", isaArray, 0); + ListNode args = new ListNode(0); + args.elements.add(isaReference); + args.elements.add(new NumberNode("1", 0)); + OperatorNode call = new OperatorNode("&", + new IdentifierNode("Internals::SvREADONLY", 0), 0); + return new BinaryOperatorNode("(", call, args, 0); + } + /** * Helper method to extract field name from a field OperatorNode. */ diff --git a/src/main/java/org/perlonjava/frontend/parser/ConstantOverloadParser.java b/src/main/java/org/perlonjava/frontend/parser/ConstantOverloadParser.java index b2ce6d665d..5906c9717a 100644 --- a/src/main/java/org/perlonjava/frontend/parser/ConstantOverloadParser.java +++ b/src/main/java/org/perlonjava/frontend/parser/ConstantOverloadParser.java @@ -12,6 +12,7 @@ import org.perlonjava.runtime.runtimetypes.RuntimeHash; import org.perlonjava.runtime.runtimetypes.RuntimeScalar; import org.perlonjava.runtime.runtimetypes.RuntimeScalarType; +import org.perlonjava.runtime.runtimetypes.PerlParserException; import java.nio.charset.StandardCharsets; import java.util.concurrent.atomic.AtomicInteger; @@ -32,8 +33,8 @@ private ConstantOverloadParser() { * can change package variables that the handler consults, whereas Perl * constant overloading observes their compile-time values.

*/ - static Node wrapRegexSegment(StringNode cooked, String raw, int tokenIndex, - boolean utf8Source) { + static Node wrapRegexSegment(Parser parser, StringNode cooked, String raw, int tokenIndex, + String literalKind, boolean utf8Source) { RuntimeScalar handler = findHandler("qr"); if (handler == null) { return cooked; @@ -46,6 +47,8 @@ static Node wrapRegexSegment(StringNode cooked, String raw, int tokenIndex, RuntimeArray args = new RuntimeArray(); args.elements.add(materializeRawSource(raw, utf8Source)); args.elements.add(materializeCooked(cooked, utf8Source)); + // The qr callback contract always receives qq; literalKind is + // only for Perl's later diagnostic wording (m'...' reports q). args.elements.add(new RuntimeScalar("qq")); result = RuntimeCode.apply(handler, args, RuntimeContextType.SCALAR).scalar(); } finally { @@ -54,6 +57,12 @@ static Node wrapRegexSegment(StringNode cooked, String raw, int tokenIndex, } } + if (result.type == RuntimeScalarType.UNDEF) { + var location = parser.ctx.errorUtil.getSourceLocationAccurate(tokenIndex); + throw new PerlParserException("Constant(" + literalKind + "): Call to &{$^H{qr}} did not return a defined value at " + + location.fileName() + " line " + location.lineNumber() + ", within pattern"); + } + int id = HANDLER_COUNTER.incrementAndGet(); String varName = "overload::__poj_regex_const_value_" + id; GlobalVariable.getGlobalVariable(varName).set(result); diff --git a/src/main/java/org/perlonjava/frontend/parser/CoreOperatorResolver.java b/src/main/java/org/perlonjava/frontend/parser/CoreOperatorResolver.java index 4b0452277c..a10ce9950c 100644 --- a/src/main/java/org/perlonjava/frontend/parser/CoreOperatorResolver.java +++ b/src/main/java/org/perlonjava/frontend/parser/CoreOperatorResolver.java @@ -7,6 +7,8 @@ import org.perlonjava.frontend.lexer.LexerTokenType; import org.perlonjava.runtime.runtimetypes.GlobalVariable; import org.perlonjava.runtime.runtimetypes.PerlJavaUnimplementedException; +import org.perlonjava.runtime.runtimetypes.PerlCompilerException; +import org.perlonjava.runtime.runtimetypes.PerlParserException; import org.perlonjava.runtime.runtimetypes.RuntimeCode; import org.perlonjava.runtime.runtimetypes.RuntimeScalar; import org.perlonjava.runtime.runtimetypes.RuntimeScalarType; @@ -83,9 +85,11 @@ yield new StringNode(parser.ctx.errorUtil } case "__CLASS__" -> { handleEmptyParentheses(parser); - // Return the compile-time package name - // TODO: Implement proper runtime class detection that works with field defaults - // and ADJUST blocks without causing symbol table errors + if (!parser.isInMethod && !parser.isInFieldInitializer) { + throw PerlCompilerException.withSourceLocation(sourceIndex, + "Cannot use __CLASS__ outside of a method or field initializer expression", + parser.ctx.errorUtil); + } yield new StringNode(parser.ctx.symbolTable.getCurrentPackage(), parser.tokenIndex); } case "__SUB__", "time", "times", "wait", "wantarray" -> { @@ -105,7 +109,7 @@ yield new StringNode(parser.ctx.errorUtil case "bless" -> OperatorParser.parseBless(parser, currentIndex); case "split" -> OperatorParser.parseSplit(parser, token, currentIndex); case "push", "unshift", "join", "sprintf" -> - OperatorParser.parseJoin(parser, token, operatorName, currentIndex); + OperatorParser.parseJoin(parser, token, operatorName, currentIndex, sourceIndex); case "sort" -> ParseMapGrepSort.parseSort(parser, token); case "map", "grep", "all", "any" -> ParseMapGrepSort.parseMapGrep(parser, token); case "pack" -> OperatorParser.parsePack(parser, token, currentIndex); @@ -120,7 +124,8 @@ yield new StringNode(parser.ctx.errorUtil case "delete", "exists" -> OperatorParser.parseDelete(parser, token, currentIndex); case "defined" -> OperatorParser.parseDefined(parser, token, currentIndex); case "scalar", "values", "keys", "each" -> OperatorParser.parseKeys(parser, token, currentIndex); - case "our", "state", "my" -> OperatorParser.parseVariableDeclaration(parser, token.text, currentIndex); + case "our", "state", "my" -> + OperatorParser.parseVariableDeclaration(parser, token.text, currentIndex, sourceIndex); case "local" -> OperatorParser.parseLocal(parser, token, currentIndex); case "last", "next", "redo" -> OperatorParser.parseLast(parser, token, currentIndex); case "goto" -> OperatorParser.parseGoto(parser, currentIndex); @@ -132,10 +137,25 @@ yield new StringNode(parser.ctx.errorUtil case "method" -> parseAnonymousMethodExpression(parser, startIndex); case "q", "qq", "qx", "qw", "qr", "tr", "y", "s", "m" -> OperatorParser.parseSpecialQuoted(parser, token, startIndex); - // CORE::dump is an obsolete process/core-dump primitive. Parse it - // as a harmless false value so legacy modules can compile guarded - // diagnostics without terminating the JVM. - case "dump" -> new NumberNode("0", parser.tokenIndex); + // Perl's dump LABEL first resolves LABEL as a runtime value. The + // JVM cannot safely dump its own process, but it must preserve the + // observable failure for an unresolved computed label. + case "dump" -> { + if (!coreQualified) { + var location = parser.ctx.errorUtil.getSourceLocationAccurate(sourceIndex); + throw new PerlParserException("dump() must be written as CORE::dump() as of Perl 5.30 at " + + location.fileName() + " line " + location.lineNumber() + ".\n"); + } + ListNode labels = ListParser.parseZeroOrMoreList(parser, 0, + false, true, false, false); + Node label = labels.elements.isEmpty() + ? new StringNode("", currentIndex) + : labels.elements.getFirst(); + ListNode message = new ListNode(currentIndex); + message.elements.add(new BinaryOperatorNode(".", + new StringNode("Can't find label ", currentIndex), label, currentIndex)); + yield OperatorParser.dieWarnNode(parser, "die", message, currentIndex); + } case "dbmclose", "dbmopen" -> throw new PerlJavaUnimplementedException(parser.tokenIndex, "Not implemented: operator: " + token.text, parser.ctx.errorUtil); case "format" -> diff --git a/src/main/java/org/perlonjava/frontend/parser/FieldParser.java b/src/main/java/org/perlonjava/frontend/parser/FieldParser.java index 04f12bc3b5..a0384579ca 100644 --- a/src/main/java/org/perlonjava/frontend/parser/FieldParser.java +++ b/src/main/java/org/perlonjava/frontend/parser/FieldParser.java @@ -82,6 +82,12 @@ public static Node parseFieldDeclaration(Parser parser) { "Expected field name after sigil", parser.ctx.errorUtil); } String fieldName = token.text; + if ("$_".equals(sigil + fieldName)) { + var location = parser.ctx.errorUtil.getSourceLocationAccurate(index); + throw new PerlCompilerException("Can't use global $_ in \"field\" at " + + location.fileName() + " line " + location.lineNumber() + + ", near \"field $_\"\n"); + } TokenUtils.consume(parser); // Create a placeholder node with field information as annotations @@ -130,14 +136,16 @@ public static Node parseFieldDeclaration(Parser parser) { // earlier fields (for example `field $two = $one + 1`) become // accesses through $self rather than package globals. int initializerScope = parser.ctx.symbolTable.enterScope(); - parser.ctx.symbolTable.addVariable("$self", "my", null); boolean wasInMethod = parser.isInMethod; + boolean wasInFieldInitializer = parser.isInFieldInitializer; parser.isInMethod = true; + parser.isInFieldInitializer = true; Node defaultValue; try { defaultValue = parser.parseExpression(parser.getPrecedence(",")); } finally { parser.isInMethod = wasInMethod; + parser.isInFieldInitializer = wasInFieldInitializer; parser.ctx.symbolTable.exitScope(initializerScope); } if (defaultValue instanceof AbstractNode) { diff --git a/src/main/java/org/perlonjava/frontend/parser/FieldRegistry.java b/src/main/java/org/perlonjava/frontend/parser/FieldRegistry.java index 8e9eecc1f8..3c7ed7a0db 100644 --- a/src/main/java/org/perlonjava/frontend/parser/FieldRegistry.java +++ b/src/main/java/org/perlonjava/frontend/parser/FieldRegistry.java @@ -22,6 +22,10 @@ private static Map classParents() { return PerlRuntime.current().globalState().classParents(); } + private static Map> classParameters() { + return PerlRuntime.current().globalState().classParameters(); + } + /** * Register a field declaration in a class */ @@ -51,6 +55,21 @@ public static String getParentClass(String className) { return classParents().get(className); } + public static Set getParameterNamesInHierarchy(String className) { + Set names = new HashSet<>(); + Set visited = new HashSet<>(); + String current = className; + while (current != null && visited.add(current)) { + names.addAll(classParameters().getOrDefault(current, Set.of())); + current = classParents().get(current); + } + return names; + } + + public static void registerParameterName(String className, String parameterName) { + classParameters().computeIfAbsent(className, ignored -> new HashSet<>()).add(parameterName); + } + /** * Check if a field exists in the class hierarchy * This works if parent classes were parsed before child classes @@ -60,6 +79,24 @@ public static boolean hasFieldInHierarchy(String className, String fieldName) { return hasFieldInHierarchyHelper(className, fieldName, visited); } + /** + * Returns whether {@code candidateAncestor} is {@code className} or one + * of its declared class parents. Field names alone are insufficient for + * access control: a nested class can see its enclosing parser scope, but + * must not inherit that enclosing class's fields. + */ + public static boolean isClassOrAncestor(String className, String candidateAncestor) { + Set visited = new HashSet<>(); + String current = className; + while (current != null && visited.add(current)) { + if (current.equals(candidateAncestor)) { + return true; + } + current = classParents().get(current); + } + return false; + } + private static boolean hasFieldInHierarchyHelper(String className, String fieldName, Set visited) { if (className == null || visited.contains(className)) { return false; // Avoid infinite loops @@ -87,5 +124,6 @@ private static boolean hasFieldInHierarchyHelper(String className, String fieldN public static void clear() { classParents().clear(); classFields().clear(); + classParameters().clear(); } } diff --git a/src/main/java/org/perlonjava/frontend/parser/FormatParser.java b/src/main/java/org/perlonjava/frontend/parser/FormatParser.java index 17a41bc4ec..5698631855 100644 --- a/src/main/java/org/perlonjava/frontend/parser/FormatParser.java +++ b/src/main/java/org/perlonjava/frontend/parser/FormatParser.java @@ -139,6 +139,18 @@ private static List parseFormatTemplateContentImmediate(Parser parse break; } + // A malformed format argument beginning with '=' leaves the + // following POD terminator in the tokenizer's impossible + // state. Perl reports that token rather than continuing to + // EOF and calling the format unterminated. + if (line.trim().equals("=cut") && !templateLines.isEmpty() + && templateLines.getLast().content.trim().startsWith("=") + && !templateLines.getLast().content.trim().equals("=cut")) { + var location = parser.ctx.errorUtil.getSourceLocationAccurate(lineIndex); + throw new PerlCompilerException("syntax error at " + location.fileName() + + " line " + location.lineNumber() + ", next token ???\n"); + } + // Parse the line and add to template FormatLine formatLine = parseFormatLine(parser, line, lineIndex); setSourceLocation(parser, formatLine, lineIndex); @@ -172,6 +184,14 @@ private static List parseFormatTemplateContentImmediate(Parser parse } if (!foundTerminator) { + if (!templateLines.isEmpty() + && templateLines.getFirst().content.trim().startsWith("@") + && templateLines.getLast().content.trim().startsWith("for(")) { + var location = parser.ctx.errorUtil.getSourceLocationAccurate(parser.tokenIndex); + throw new PerlCompilerException("syntax error at " + location.fileName() + + " line " + location.lineNumber() + ", \nExecution of " + + location.fileName() + " aborted due to compilation errors.\n"); + } throw new PerlCompilerException(parser.tokenIndex, "Format not terminated", parser.ctx.errorUtil); } @@ -297,6 +317,12 @@ public static void parseFormatTemplateContent(Parser parser) { * @return FormatLine representing the parsed line */ private static FormatLine parseFormatLine(Parser parser, String line, int tokenIndex) { + if (line.trim().equals(".//")) { + var location = parser.ctx.errorUtil.getSourceLocationAccurate(tokenIndex); + throw new PerlCompilerException("syntax error at " + location.fileName() + + " line " + location.lineNumber() + ", near \".\"\n"); + } + // Comment lines start with # if (line.trim().startsWith("#")) { String comment = line.trim().substring(1).trim(); diff --git a/src/main/java/org/perlonjava/frontend/parser/IdentifierParser.java b/src/main/java/org/perlonjava/frontend/parser/IdentifierParser.java index feaadef658..f6712600d7 100644 --- a/src/main/java/org/perlonjava/frontend/parser/IdentifierParser.java +++ b/src/main/java/org/perlonjava/frontend/parser/IdentifierParser.java @@ -19,6 +19,23 @@ * from a list of tokens, excluding the sigil (e.g., $, @, %). */ public class IdentifierParser { + private static boolean isPerlIdentifierStart(int codePoint) { + return codePoint == '_' || UCharacter.hasBinaryProperty(codePoint, UProperty.XID_START) + || isNewerPerlXidStart(codePoint); + } + + private static boolean isNewerPerlXidStart(int cp) { + return cp == 0x088F || cp == 0x0C5C || cp == 0x0CDC || cp == 0x1885 || cp == 0x1886 + || cp == 0x2118 || cp == 0x212E || cp == 0x3007 || cp == 0x3038 || cp == 0x3039 || cp == 0x303A + || cp == 0xA7CE || cp == 0xA7CF || cp == 0xA7D2 || cp == 0xA7D4 || cp == 0xA7F1 + || (cp >= 0x16EE && cp <= 0x16F0) + || (cp >= 0x2160 && cp <= 0x217F) + || (cp >= 0x2180 && cp <= 0x2182) + || (cp >= 0x2185 && cp <= 0x2188) + || (cp >= 0x3021 && cp <= 0x3029) + || (cp >= 0xA6E6 && cp <= 0xA6EF); + } + private static boolean isIdentifierTooLong(StringBuilder variableName, boolean isTypeglob) { // perl5_t/t/comp/parser.t builds boundary cases using UTF-8 byte length. @@ -321,7 +338,7 @@ public static String parseComplexIdentifierInner(Parser parser, boolean insideBr Long.compareUnsigned(cpL, 0x10FFFFL) > 0 || (cpL >= 0xD800L && cpL <= 0xDFFFL); int cp = (int) cpL; boolean valid = - !invalidPlane && (cp == '_' || UCharacter.hasBinaryProperty(cp, UProperty.XID_START)); + !invalidPlane && isPerlIdentifierStart(cp); // Under 'no utf8', Perl allows many non-ASCII bytes as length-1 variables. // Only enforce XID_START there for multi-character identifiers. @@ -393,7 +410,7 @@ public static String parseComplexIdentifierInner(Parser parser, boolean insideBr Long.compareUnsigned(cpL, 0x10FFFFL) > 0 || (cpL >= 0xD800L && cpL <= 0xDFFFL); int cp = (int) cpL; boolean valid = - !invalidPlane && (cp == '_' || UCharacter.hasBinaryProperty(cp, UProperty.XID_START)); + !invalidPlane && isPerlIdentifierStart(cp); boolean mustValidateStart = utf8Enabled || id.length() > 1; @@ -662,16 +679,23 @@ public static String parseSubroutineIdentifier(Parser parser, boolean allowTrail // Track if we're at the start of the identifier boolean isFirstToken = true; + boolean apostrophePackageSeparator = parser.ctx.symbolTable + .isFeatureCategoryEnabled("apostrophe_as_package_separator"); // A leading quote is the deprecated package separator before the first // component, not an empty `main` package component. Thus // `sub 'Hello'_he_said` declares `Hello::_he_said`. - if (isFirstToken && token.text.equals("'")) { + if (isFirstToken && token.text.equals("'") && apostrophePackageSeparator) { parser.tokenIndex++; token = parser.tokens.get(parser.tokenIndex); nextToken = parser.tokens.get(parser.tokenIndex + 1); isFirstToken = false; // We've consumed the leading ' // Continue to parse the rest + } else if (isFirstToken && token.text.equals("'")) { + // With the compatibility feature disabled, leave the quote for + // ordinary expression parsing. It may begin a quote, rather + // than silently manufacturing a legacy package component. + return null; } // Numbers are not allowed at the very beginning (unless after a leading ' or ::) @@ -689,6 +713,9 @@ public static String parseSubroutineIdentifier(Parser parser, boolean allowTrail // Handle single quote as package separator in subroutine names if (token.text.equals("'") && variableName.length() > 0) { + if (!apostrophePackageSeparator) { + return variableName.toString(); + } // Check if next token can continue the identifier if (nextToken.type == LexerTokenType.IDENTIFIER || nextToken.type == LexerTokenType.NUMBER) { // Convert ' to :: for internal representation @@ -743,6 +770,10 @@ public static String parseSubroutineIdentifier(Parser parser, boolean allowTrail } if (nextToken.text.equals("'")) { + if (!apostrophePackageSeparator) { + parser.tokenIndex++; + return variableName.toString(); + } // Look ahead to see what follows the ' LexerToken afterQuote = parser.tokens.get(parser.tokenIndex + 2); if (afterQuote.type == LexerTokenType.IDENTIFIER || afterQuote.type == LexerTokenType.NUMBER) { diff --git a/src/main/java/org/perlonjava/frontend/parser/ListParser.java b/src/main/java/org/perlonjava/frontend/parser/ListParser.java index 93370ce85c..956be2f418 100644 --- a/src/main/java/org/perlonjava/frontend/parser/ListParser.java +++ b/src/main/java/org/perlonjava/frontend/parser/ListParser.java @@ -62,6 +62,16 @@ static ListNode parseZeroOrOneList(Parser parser, int minItems, String tooManyAr expr = new ListNode(parseList(parser, ")", 0), parser.tokenIndex); if (expr.elements.size() > 1) { if (tooManyArgsForBuiltin != null) { + if (tooManyArgsForBuiltin.equals("undef")) { + int closeIndex = Math.max(0, parser.tokenIndex - 1); + int argumentIndex = Math.max(0, closeIndex - 1); + var location = parser.ctx.errorUtil.getSourceLocationAccurate(closeIndex); + String near = TokenUtils.toText(parser.tokens, argumentIndex, closeIndex); + parser.deferDiagnostic("Too many arguments for undef operator at " + + location.fileName() + " line " + location.lineNumber() + + ", near \"" + near + "\"\n"); + return expr; + } parser.throwError("Too many arguments for " + tooManyArgsForBuiltin); } else { parser.throwError("syntax error"); @@ -334,6 +344,11 @@ static boolean isListTerminator(Parser parser, LexerToken token) { * @throws PerlCompilerException If the syntax is incorrect or the minimum number of items is not met. */ static List parseList(Parser parser, String close, int minItems) { + return parseList(parser, close, minItems, -1); + } + + /** Parse a delimited list, optionally retaining its opening token for diagnostics. */ + static List parseList(Parser parser, String close, int minItems, int openingTokenIndex) { if (CompilerOptions.DEBUG_ENABLED) parser.ctx.logDebug("parseList start"); ListNode expr; @@ -344,11 +359,28 @@ static List parseList(Parser parser, String close, int minItems) { TokenUtils.consume(parser); expr = new ListNode(parser.tokenIndex); } else { - expr = ListNode.makeList(parser.parseExpression(0)); + try { + expr = ListNode.makeList(parser.parseExpression(0)); + } catch (PerlCompilerException error) { + int previousToken = parser.tokenIndex - 1; + if (openingTokenIndex >= 0 && previousToken >= 0 + && ((close.equals("]") && tokensText(parser, previousToken).equals("}")) + || (close.equals("}") && tokensText(parser, previousToken).equals("]")))) { + throw new PerlCompilerException( + parser.ctx.errorUtil.errorMessageIncludingDelimiter(openingTokenIndex, "syntax error")); + } + throw error; + } if (CompilerOptions.DEBUG_ENABLED) parser.ctx.logDebug("parseList end at " + TokenUtils.peek(parser)); // Check for closing delimiter with better error message for hash/array literals LexerToken closingToken = TokenUtils.peek(parser); + if (openingTokenIndex >= 0 && closingToken.type == LexerTokenType.OPERATOR + && ((close.equals("]") && closingToken.text.equals("}")) + || (close.equals("}") && closingToken.text.equals("]")))) { + throw new PerlCompilerException( + parser.ctx.errorUtil.errorMessageIncludingDelimiter(openingTokenIndex, "syntax error")); + } if (closingToken.type == LexerTokenType.EOF && (close.equals("}") || close.equals("]"))) { String fileName = parser.ctx.errorUtil.getFileName(); int lineNum = parser.ctx.errorUtil.getLineNumber(parser.tokenIndex); @@ -369,6 +401,10 @@ static List parseList(Parser parser, String close, int minItems) { return expr.elements; } + private static String tokensText(Parser parser, int index) { + return parser.tokens.get(index).text; + } + /** * Determines if the current token sequence looks like an empty list. * diff --git a/src/main/java/org/perlonjava/frontend/parser/NumberParser.java b/src/main/java/org/perlonjava/frontend/parser/NumberParser.java index 07637204aa..87903c06ee 100644 --- a/src/main/java/org/perlonjava/frontend/parser/NumberParser.java +++ b/src/main/java/org/perlonjava/frontend/parser/NumberParser.java @@ -10,9 +10,14 @@ import org.perlonjava.frontend.lexer.LexerToken; import org.perlonjava.frontend.lexer.LexerTokenType; import org.perlonjava.runtime.operators.WarnDie; +import org.perlonjava.runtime.HintHashRegistry; import org.perlonjava.runtime.runtimetypes.GlobalContext; import org.perlonjava.runtime.runtimetypes.GlobalVariable; +import org.perlonjava.runtime.runtimetypes.PerlParserException; import org.perlonjava.runtime.runtimetypes.RuntimeHash; +import org.perlonjava.runtime.runtimetypes.RuntimeArray; +import org.perlonjava.runtime.runtimetypes.RuntimeCode; +import org.perlonjava.runtime.runtimetypes.RuntimeContextType; import org.perlonjava.runtime.runtimetypes.RuntimeScalar; import org.perlonjava.runtime.runtimetypes.RuntimeScalarCache; import org.perlonjava.runtime.runtimetypes.RuntimeScalarType; @@ -66,14 +71,16 @@ public class NumberParser { * @return {@code literal} unchanged when no handler is active, or a * {@code $handler->(originalText, literal, category)} call AST */ - private static Node wrapWithConstantHandler(Node literal, String originalText, + private static Node wrapWithConstantHandler(Parser parser, Node literal, String originalText, String category, int tokenIndex) { RuntimeHash hh = GlobalVariable.getGlobalHash(GlobalContext.encodeSpecialVar("H")); if (hh == null || hh.elements.isEmpty()) { + rejectClearedConstantHandler(parser, originalText, category, tokenIndex); return literal; } RuntimeScalar handler = hh.elements.get(category); if (handler == null) { + rejectClearedConstantHandler(parser, originalText, category, tokenIndex); return literal; } // Accept both a CODE scalar (rare) and a CODE reference (normal). @@ -85,31 +92,47 @@ private static Node wrapWithConstantHandler(Node literal, String originalText, return literal; } - // Stash the handler into a uniquely-named package global so it - // remains reachable at runtime (unlike %^H, which is cleared). + // Perl applies :constant handlers while compiling the literal. Keep + // the category out of %^H while the callback runs so eval STRING in + // the callback cannot recursively re-enter the same handler. + RuntimeScalar saved = hh.elements.remove(category); + RuntimeScalar result; + try { + RuntimeArray callArgs = new RuntimeArray(); + callArgs.elements.add(new RuntimeScalar(originalText)); + callArgs.elements.add(new RuntimeScalar(originalText)); + callArgs.elements.add(new RuntimeScalar(category)); + result = RuntimeCode.apply(handler, callArgs, RuntimeContextType.SCALAR).scalar(); + } finally { + if (saved != null) hh.elements.put(category, saved); + } + if (result.type == RuntimeScalarType.UNDEF) { + var location = parser.ctx.errorUtil.getSourceLocationAccurate(Math.max(0, tokenIndex - 1)); + parser.deferDiagnostic("Constant(" + originalText + "): Call to &{$^H{" + category + + "}} did not return a defined value at " + location.fileName() + + " line " + location.lineNumber() + ", at end of line\n"); + return literal; + } + + // Retain the compile-time result in a synthetic global for emitted + // bytecode; %^H itself is cleared before execution. int id = CONSTANT_HANDLER_COUNTER.incrementAndGet(); String varName = "overload::__poj_const_handler_" + id; - GlobalVariable.getGlobalVariable(varName).set(handler); - - // Emit overload::__poj_const_call($handler, $text, $literal, $category) - // rather than a direct $handler->($text, $literal, $category) call. - // The helper temporarily removes %^H{$category} for the duration of - // the handler's execution so that patterns like - // sub { return eval $_[0] } - // in `overload::constant float => ...` don't infinite-recurse when - // the handler's body reparses the original source text. + GlobalVariable.getGlobalVariable(varName).set(result); + + // Emit the captured scalar result. OperatorNode handlerVar = new OperatorNode("$", new IdentifierNode(varName, tokenIndex), tokenIndex); - ListNode args = new ListNode(tokenIndex); - args.elements.add(handlerVar); - args.elements.add(new StringNode(originalText, tokenIndex)); - args.elements.add(literal); - args.elements.add(new StringNode(category, tokenIndex)); - return new BinaryOperatorNode("(", - new OperatorNode("&", - new IdentifierNode("overload::__poj_const_call", tokenIndex), - tokenIndex), - args, tokenIndex); + return handlerVar; + } + + private static void rejectClearedConstantHandler(Parser parser, String originalText, String category, + int tokenIndex) { + if (HintHashRegistry.constantHandlerWasCleared(category)) { + var location = parser.ctx.errorUtil.getSourceLocationAccurate(Math.max(0, tokenIndex - 1)); + throw new PerlParserException("Constant(" + originalText + ") unknown at " + + location.fileName() + " line " + location.lineNumber() + ", at end of line\n"); + } } /** @@ -218,13 +241,23 @@ public static Node parseNumber(Parser parser, LexerToken token) { String originalText = number.toString(); NumberNode numberNode = new NumberNode(originalText, parser.tokenIndex); String category = (hasFractional || hasExponent) ? "float" : "integer"; - return wrapWithConstantHandler(numberNode, originalText, category, parser.tokenIndex); + return wrapWithConstantHandler(parser, numberNode, originalText, category, parser.tokenIndex); } /** * Unified parsing method for special number formats (binary, octal, hex) */ private static Node parseSpecialNumber(Parser parser, String initialPart, NumberFormat format) { + if (!containsDigitForFormat(initialPart, format) + && !hasLeadingFractionalDigit(parser, format)) { + PerlParserException adjacentNumberError = + missingOperatorBeforeIncompleteBaseLiteral(parser, format); + if (adjacentNumberError != null) { + throw adjacentNumberError; + } + deferNoDigitsForLiteral(parser, initialPart, format); + return new NumberNode("0", parser.tokenIndex); + } StringBuilder numberStr = new StringBuilder(); boolean hasFractionalPart = false; String exponentStr = ""; @@ -252,6 +285,7 @@ private static Node parseSpecialNumber(Parser parser, String initialPart, Number TokenUtils.consume(parser); // consume '.' StringBuilder fractionalPart = new StringBuilder(); + boolean invalidFractionalDigit = false; while (parser.tokenIndex < parser.tokens.size()) { String currentToken = parser.tokens.get(parser.tokenIndex).text; @@ -259,7 +293,13 @@ private static Node parseSpecialNumber(Parser parser, String initialPart, Number if (parser.tokens.get(parser.tokenIndex).type == LexerTokenType.NUMBER) { String digitStr = cleanUnderscores(TokenUtils.consume(parser).text); if (!format.digitValidator.test(digitStr)) { - parser.throwError("Invalid " + format.name + " digit in fractional part"); + // A non-base digit means this was not a base-specific + // floating literal after all. Perl leaves the dot for + // the ordinary concatenation parser (for example, + // `07.8p0` is `07 . 8p0`), which then diagnoses the + // trailing bareword. + invalidFractionalDigit = true; + break; } fractionalPart.append(digitStr); } else if (parser.tokens.get(parser.tokenIndex).type == LexerTokenType.IDENTIFIER) { @@ -295,7 +335,10 @@ private static Node parseSpecialNumber(Parser parser, String initialPart, Number break; } } - if (format == HEX_FORMAT && exponentStr.isEmpty()) { + if (invalidFractionalDigit) { + parser.tokenIndex = beforeFractionalPart; + hasFractionalPart = false; + } else if (format == HEX_FORMAT && exponentStr.isEmpty()) { if (numberStr.isEmpty()) { parser.throwError("Invalid hexadecimal number"); } @@ -365,7 +408,7 @@ private static Node parseSpecialNumber(Parser parser, String initialPart, Number } NumberNode numberNode = new NumberNode(Double.toString(value), parser.tokenIndex); - return wrapWithConstantHandler(numberNode, originalText, "float", parser.tokenIndex); + return wrapWithConstantHandler(parser, numberNode, originalText, "float", parser.tokenIndex); } else { // Integer number try { @@ -377,12 +420,12 @@ private static Node parseSpecialNumber(Parser parser, String initialPart, Number if (value.bitLength() > 64) { if (hasConstantHandler("binary")) { NumberNode numberNode = new NumberNode("0", parser.tokenIndex); - return wrapWithConstantHandler(numberNode, originalText, "binary", parser.tokenIndex); + return wrapWithConstantHandler(parser, numberNode, originalText, "binary", parser.tokenIndex); } return new NumberNode(Double.toString(value.doubleValue()), parser.tokenIndex); } NumberNode numberNode = new NumberNode(value.toString(), parser.tokenIndex); - return wrapWithConstantHandler(numberNode, originalText, "binary", parser.tokenIndex); + return wrapWithConstantHandler(parser, numberNode, originalText, "binary", parser.tokenIndex); } catch (NumberFormatException overflow) { // Value doesn't fit in a Perl UV. If a `binary` // overload::constant handler is active (e.g. `use bigint`), @@ -391,7 +434,7 @@ private static Node parseSpecialNumber(Parser parser, String initialPart, Number // ignores the numeric-form argument in that case. if (hasConstantHandler("binary")) { NumberNode numberNode = new NumberNode("0", parser.tokenIndex); - return wrapWithConstantHandler(numberNode, originalText, "binary", parser.tokenIndex); + return wrapWithConstantHandler(parser, numberNode, originalText, "binary", parser.tokenIndex); } throw overflow; } @@ -402,6 +445,102 @@ private static Node parseSpecialNumber(Parser parser, String initialPart, Number return null; } + private static boolean containsDigitForFormat(String text, NumberFormat format) { + String digits = text.replace("_", ""); + for (int index = 0; index < digits.length(); index++) { + if (format.digitValidator.test(Character.toString(digits.charAt(index)))) { + return true; + } + } + return false; + } + + /** + * A hexadecimal float may omit the integer portion (for example + * {@code 0x.8p0}). At this point the prefix has been consumed, so its + * digit is in the fraction rather than {@code initialPart}; do not + * mistake that valid form for an incomplete {@code 0x} literal. + */ + private static boolean hasLeadingFractionalDigit(Parser parser, NumberFormat format) { + if (format != HEX_FORMAT || parser.tokenIndex + 1 >= parser.tokens.size() + || !parser.tokens.get(parser.tokenIndex).text.equals(".")) { + return false; + } + String fractionalStart = parser.tokens.get(parser.tokenIndex + 1).text; + return containsDigitForFormat(fractionalStart, format); + } + + private static void deferNoDigitsForLiteral(Parser parser, String initialPart, NumberFormat format) { + int prefixIndex = Math.max(0, parser.tokenIndex - 2); + var location = parser.ctx.errorUtil.getSourceLocationAccurate(prefixIndex); + String prefix = format == HEX_FORMAT ? "0x" : format == BINARY_FORMAT ? "0b" : "0"; + StringBuilder near = new StringBuilder(prefix).append(initialPart); + if (parser.tokenIndex < parser.tokens.size()) { + LexerToken next = parser.tokens.get(parser.tokenIndex); + if ((next.type == LexerTokenType.WHITESPACE && initialPart.isEmpty()) + || next.text.equals(";")) { + near.append(next.text); + } + } + parser.deferDiagnostic("No digits found for " + format.name + " literal at " + + location.fileName() + " line " + location.lineNumber() + ", near \"" + + near + "\"\n"); + while (parser.tokenIndex < parser.tokens.size()) { + LexerToken token = parser.tokens.get(parser.tokenIndex); + if (token.type == LexerTokenType.NEWLINE || token.type == LexerTokenType.EOF + || token.text.equals(";")) { + return; + } + parser.tokenIndex++; + } + } + + /** + * A base-literal prefix immediately after another number is not a second + * expression: Perl diagnoses the missing operator first, then preserves + * the incomplete-literal diagnostic. Do this before generic recovery + * consumes the trailing token, which would otherwise lose the shared + * {@code "0 0x"} source excerpt. + */ + private static PerlParserException missingOperatorBeforeIncompleteBaseLiteral( + Parser parser, NumberFormat format) { + int literalStart = parser.tokenIndex - 2; + if (literalStart <= 0 || literalStart >= parser.tokens.size() + || parser.tokens.get(literalStart).type != LexerTokenType.NUMBER) { + return null; + } + + int previous = literalStart - 1; + while (previous >= 0 && parser.tokens.get(previous).type == LexerTokenType.WHITESPACE) { + previous--; + } + if (previous < 0 || parser.tokens.get(previous).type != LexerTokenType.NUMBER + || previous == literalStart - 1) { + return null; + } + + String literal = TokenUtils.toText(parser.tokens, literalStart, parser.tokenIndex - 1); + String near = TokenUtils.toText(parser.tokens, previous, parser.tokenIndex - 1); + String noDigitsNear = near; + if (parser.tokenIndex < parser.tokens.size()) { + LexerToken trailing = parser.tokens.get(parser.tokenIndex); + if (trailing.type != LexerTokenType.EOF && trailing.type != LexerTokenType.NEWLINE) { + noDigitsNear += trailing.text; + } + } + + var location = parser.ctx.errorUtil.getSourceLocationAccurate(previous); + String at = " at " + location.fileName() + " line " + location.lineNumber(); + String message = "Number found where operator expected (Missing operator before \"" + + literal + "\"?)" + at + ", near \"" + near + "\"\n" + + "No digits found for " + format.name + " literal" + at + ", near \"" + + noDigitsNear + "\"\n" + + "syntax error" + at + ", near \"" + near + "\"\n" + + "Execution of " + location.fileName() + + " aborted due to compilation errors.\n"; + return new PerlParserException(message); + } + // Helper methods public static Node parseFractionalNumber(Parser parser) { StringBuilder number = new StringBuilder("0."); @@ -413,19 +552,29 @@ public static Node parseFractionalNumber(Parser parser) { checkNumberExponent(parser, number); String originalText = number.toString(); NumberNode numberNode = new NumberNode(originalText, parser.tokenIndex); - return wrapWithConstantHandler(numberNode, originalText, "float", parser.tokenIndex); + return wrapWithConstantHandler(parser, numberNode, originalText, "float", parser.tokenIndex); } public static void checkNumberExponent(Parser parser, StringBuilder number) { String exponentPart = parser.tokens.get(parser.tokenIndex).text; if (exponentPart.startsWith("e") || exponentPart.startsWith("E")) { - TokenUtils.consume(parser); int index = 1; for (; index < exponentPart.length(); index++) { if (!Character.isDigit(exponentPart.charAt(index)) && exponentPart.charAt(index) != '_') { parser.throwError("Malformed number"); } } + + // The lexer splits a decimal exponent into an identifier token for + // its `e` and separate sign/number tokens. Do not consume a bare + // `e` unless it is followed by a complete exponent: leaving it in + // place lets the ordinary parser identify it as the bareword in + // malformed input such as `1e--5`. + if (index == 1 && !hasDecimalExponentTail(parser)) { + return; + } + + TokenUtils.consume(parser); number.append(cleanUnderscores(exponentPart)); if (index == 1) { @@ -437,6 +586,20 @@ public static void checkNumberExponent(Parser parser, StringBuilder number) { } } + private static boolean hasDecimalExponentTail(Parser parser) { + int nextIndex = parser.tokenIndex + 1; + if (nextIndex >= parser.tokens.size()) { + return false; + } + LexerToken next = parser.tokens.get(nextIndex); + if (next.type == LexerTokenType.NUMBER) { + return true; + } + return (next.text.equals("-") || next.text.equals("+")) + && nextIndex + 1 < parser.tokens.size() + && parser.tokens.get(nextIndex + 1).type == LexerTokenType.NUMBER; + } + private static String checkHexExponent(Parser parser) { if (parser.tokenIndex >= parser.tokens.size()) { return ""; diff --git a/src/main/java/org/perlonjava/frontend/parser/OperatorParser.java b/src/main/java/org/perlonjava/frontend/parser/OperatorParser.java index 9ec3b439af..ce9d248acf 100644 --- a/src/main/java/org/perlonjava/frontend/parser/OperatorParser.java +++ b/src/main/java/org/perlonjava/frontend/parser/OperatorParser.java @@ -421,12 +421,14 @@ private static boolean isGlobalOnlyVariable(String name) { } if (allDigits) return true; - // Single ASCII non-alphanumeric, non-underscore character: $!, $/, $@, $;, etc. - // Only check ASCII range — Unicode characters (>= 128) may be valid identifiers - // even if Java's Character.isLetterOrDigit() doesn't recognize them. - if (name.length() == 1) { - char c = name.charAt(0); - if (c < 128 && !Character.isLetterOrDigit(c) && c != '_') return true; + // Single non-identifier character: $!, $/, $@, $;, and Unicode punctuation + // such as $¶ are all global-only. Inspect a Unicode code point rather + // than a UTF-16 code unit so Letter_Number identifiers (for example + // U+216B) are not mistaken for punctuation. + if (name.codePointCount(0, name.length()) == 1) { + int codePoint = name.codePointAt(0); + if (codePoint != '_' && !Character.isUnicodeIdentifierStart(codePoint) + && !isNewerPerlXidStart(codePoint)) return true; } // Control character prefix (caret variables like $^W stored as chr(23)) @@ -435,6 +437,11 @@ private static boolean isGlobalOnlyVariable(String name) { return false; } + private static boolean isNewerPerlXidStart(int cp) { + return cp == 0x088F || cp == 0x0C5C || cp == 0x0CDC + || cp == 0xA7CE || cp == 0xA7CF || cp == 0xA7D2 || cp == 0xA7D4 || cp == 0xA7F1; + } + /** * Format a variable name for display in error messages. * Converts internal control character representation back to ^X form. @@ -450,7 +457,8 @@ private static String formatVarNameForDisplay(String name) { return name; } - private static void addVariableToScope(EmitterContext ctx, String operator, OperatorNode node) { + private static void addVariableToScope(EmitterContext ctx, String operator, OperatorNode node, + int declarationSourceIndex) { String sigil = node.operator; if ("$@%".contains(sigil)) { // not "undef" @@ -464,7 +472,7 @@ private static void addVariableToScope(EmitterContext ctx, String operator, Oper if ((operator.equals("my") || operator.equals("state")) && isGlobalOnlyVariable(name)) { throw new PerlCompilerException( - node.getIndex(), + declarationSourceIndex, "Can't use global " + sigil + formatVarNameForDisplay(name) + " in \"" + operator + "\"", ctx.errorUtil @@ -541,7 +549,8 @@ && isGlobalOnlyVariable(name)) { } } - static OperatorNode parseVariableDeclaration(Parser parser, String operator, int currentIndex) { + static OperatorNode parseVariableDeclaration(Parser parser, String operator, int currentIndex, + int declarationSourceIndex) { String varType = null; if (peek(parser).type == IDENTIFIER) { @@ -620,6 +629,31 @@ static OperatorNode parseVariableDeclaration(Parser parser, String operator, int parser.parsingDeclaration = savedParsingDeclaration; if (CompilerOptions.DEBUG_ENABLED) parser.ctx.logDebug("parseVariableDeclaration " + operator + ": " + operand + " (ref=" + isDeclaredReference + ")"); + // A declaration list may only contain declaration targets. Keep the + // two special forms Perl diagnoses explicitly from falling through to + // the generic emitter's "Not implemented" error. + if (operand instanceof ListNode listNode && listNode.elements.size() == 1) { + Node declared = listNode.elements.getFirst(); + if (declared instanceof TernaryOperatorNode) { + throwDeclarationEofError(parser, + "Can't declare conditional expression in \"" + operator + "\""); + } + if (declared instanceof BlockNode block && block.getBooleanAnnotation("blockIsDoBlock")) { + throwDeclarationEofError(parser, + "Can't declare do block in \"" + operator + "\""); + } + } + + OperatorNode nestedDeclaration = findNestedDeclaration(operand); + if (nestedDeclaration != null) { + ErrorMessageUtil.SourceLocation location = + parser.ctx.errorUtil.getSourceLocationAccurate(nestedDeclaration.tokenIndex); + throw new PerlParserException("Can't redeclare \"" + nestedDeclaration.operator + + "\" in \"" + operator + "\" at " + location.fileName() + + " line " + location.lineNumber() + ", near \"" + + nestedDeclarationContext(parser, nestedDeclaration) + "\""); + } + // Add variables to the scope if (operand instanceof ListNode listNode) { // my ($a, $b) our ($a, $b) // process each item of the list; then returns the list @@ -629,6 +663,12 @@ static OperatorNode parseVariableDeclaration(Parser parser, String operator, int for (int i = 0; i < listNode.elements.size(); i++) { Node element = listNode.elements.get(i); if (element instanceof OperatorNode operandNode) { + if (operator.equals("state") && operandNode.id == 0) { + // Parenthesized declarations keep their targets in a + // ListNode. Give each target the same persistent id + // assigned to a direct `state $var` declaration. + operandNode.id = EmitterMethodCreator.classCounter.getAndIncrement(); + } // Check if this element is a reference operator (backslash) // This handles cases like my(\$x) where the backslash is inside the parentheses if (operandNode.operator.equals("\\") && operandNode.operand instanceof OperatorNode varNode) { @@ -666,7 +706,7 @@ static OperatorNode parseVariableDeclaration(Parser parser, String operator, int } scalarVarNode.setAnnotation("isDeclaredReference", true); scalarVarNode.setAnnotation("declaredReferenceOriginalSigil", varNode.operator); - addVariableToScope(parser.ctx, operator, scalarVarNode); + addVariableToScope(parser.ctx, operator, scalarVarNode, declarationSourceIndex); // Also mark the original nodes varNode.setAnnotation("isDeclaredReference", true); operandNode.setAnnotation("isDeclaredReference", true); @@ -678,7 +718,7 @@ static OperatorNode parseVariableDeclaration(Parser parser, String operator, int if (isDeclaredReference) { operandNode.setAnnotation("isDeclaredReference", true); } - addVariableToScope(parser.ctx, operator, operandNode); + addVariableToScope(parser.ctx, operator, operandNode, declarationSourceIndex); transformedElements.add(element); } } else { @@ -703,7 +743,7 @@ static OperatorNode parseVariableDeclaration(Parser parser, String operator, int if (isDeclaredReference) { operandNode.setAnnotation("isDeclaredReference", true); } - addVariableToScope(parser.ctx, operator, operandNode); + addVariableToScope(parser.ctx, operator, operandNode, declarationSourceIndex); } OperatorNode decl = new OperatorNode(operator, operand, currentIndex); @@ -715,6 +755,20 @@ static OperatorNode parseVariableDeclaration(Parser parser, String operator, int } if (varType != null) { decl.setAnnotation("varType", varType); + // Typed lexicals retain their type on the declaration target as + // well as on the wrapping `my` node. Later postfix parsing (for + // example $obj->{field} and @obj{...}) resolves the lexical via + // the symbol table and therefore cannot recover metadata kept + // solely on the declaration wrapper. + if (operand instanceof OperatorNode operandNode) { + operandNode.setAnnotation("varType", varType); + } else if (operand instanceof ListNode listNode) { + for (Node element : listNode.elements) { + if (element instanceof OperatorNode elementNode) { + elementNode.setAnnotation("varType", varType); + } + } + } } // Initialize a list to store any attributes the declaration might have. @@ -782,6 +836,73 @@ static OperatorNode parseVariableDeclaration(Parser parser, String operator, int return decl; } + /** A declaration list cannot contain another my/our/state declaration. */ + private static OperatorNode findNestedDeclaration(Node node) { + if (node instanceof OperatorNode operatorNode) { + if (operatorNode.operator.equals("my") || operatorNode.operator.equals("our") + || operatorNode.operator.equals("state")) { + return operatorNode; + } + return null; + } + if (node instanceof ListNode listNode) { + for (Node element : listNode.elements) { + OperatorNode nested = findNestedDeclaration(element); + if (nested != null) return nested; + } + } + return null; + } + + /** + * Perl includes the punctuation immediately preceding a nested declaration + * in its diagnostic, such as {@code (our} or {@code , our}. + */ + private static String nestedDeclarationContext(Parser parser, OperatorNode declaration) { + // Declaration nodes retain the parser position immediately after the + // declaration keyword. Locate the keyword itself before collecting + // the preceding punctuation and its intervening whitespace. + int declarationIndex = Math.min(declaration.tokenIndex, parser.tokens.size() - 1); + while (declarationIndex >= 0 + && !declaration.operator.equals(parser.tokens.get(declarationIndex).text)) { + declarationIndex--; + } + if (declarationIndex < 0) { + return declaration.operator; + } + + int contextStart = declarationIndex - 1; + while (contextStart >= 0 + && parser.tokens.get(contextStart).type == WHITESPACE) { + contextStart--; + } + StringBuilder context = new StringBuilder(); + for (int index = Math.max(0, contextStart); index <= declarationIndex; index++) { + context.append(parser.tokens.get(index).text); + } + return context.toString(); + } + + private static void throwDeclarationEofError(Parser parser, String message) { + int locationIndex = parser.tokenIndex; + if (locationIndex > 0 && locationIndex < parser.tokens.size() + && parser.tokens.get(locationIndex).type == NEWLINE) { + // Parsing stops on the terminator token; use the last token of the + // declaration rather than the next physical source line. + locationIndex--; + } else if (locationIndex > 1 && locationIndex < parser.tokens.size() + && parser.tokens.get(locationIndex).type == EOF + && parser.tokens.get(locationIndex - 1).type == NEWLINE) { + // The core-test harness writes a trailing newline. Attribute an + // EOF declaration error to the physical line that contains the + // declaration, as Perl does. + locationIndex -= 2; + } + var location = parser.ctx.errorUtil.getSourceLocationAccurate(locationIndex); + throw new PerlParserException(message + " at " + location.fileName() + + " line " + location.lineNumber() + ", at EOF"); + } + /** * Check if a variable in a my/our/state declaration is actually a dereference. * E.g., "our ${""}", "my $$foo" — Perl 5 errors with: @@ -813,6 +934,7 @@ static OperatorNode parseOperatorWithOneOptionalArgument(Parser parser, LexerTok Node operand; // Handle operators with one optional argument String text = token.text; + int argumentIndex = parser.tokenIndex; operand = ListParser.parseZeroOrOneList(parser, 0, text); if (((ListNode) operand).elements.isEmpty()) { switch (text) { @@ -853,6 +975,18 @@ static OperatorNode parseOperatorWithOneOptionalArgument(Parser parser, LexerTok break; } } + if ((text.equals("pop") || text.equals("shift")) && operand instanceof ListNode listNode + && !listNode.elements.isEmpty()) { + Node argument = listNode.elements.getFirst(); + if (!(argument instanceof OperatorNode operatorNode && operatorNode.operator.equals("@"))) { + String kind = arrayOperationArgumentKind(parser, argument); + String message = "Type of arg 1 to " + text + " must be array (not " + kind + ")"; + if (kind.equals("constant item")) { + parser.throwError(argumentIndex, message); + } + parser.deferErrorAtToken(argumentIndex, message); + } + } return new OperatorNode(text, operand, parser.tokenIndex); } @@ -901,6 +1035,7 @@ static OperatorNode parseKeys(Parser parser, LexerToken token, int currentIndex) int operandPrecedence = operator.equals("scalar") ? parser.getPrecedence("isa") + 1 : parser.getPrecedence("=~"); + int argumentIndex = parser.tokenIndex; operand = parser.parseExpression(operandPrecedence); // Check if operand is null (no argument provided) if (operand == null) { @@ -910,6 +1045,10 @@ static OperatorNode parseKeys(Parser parser, LexerToken token, int currentIndex) // but values/keys/each need single operand check if (!operator.equals("scalar")) { operand = ensureOneOperand(parser, token, operand); + if (operand instanceof IdentifierNode) { + parser.throwError(argumentIndex, + "Type of arg 1 to " + operator + " must be hash or array (not constant item)"); + } } } else { operand = ParsePrimary.parsePrimary(parser); @@ -958,11 +1097,57 @@ static OperatorNode parseDelete(Parser parser, LexerToken token, int currentInde // Handle &{string} patterns for delete/exists operators (no transformation, direct handling) if (operand instanceof ListNode listNode) { transformCodeRefPatterns(parser, listNode, token.text); + if (listNode.elements.size() == 1) { + Node argument = listNode.elements.getFirst(); + if (operatorNameIsInvalidExistsSubroutineCall(token.text, argument)) { + // At end of input the cursor sits after the synthetic newline; + // anchor this diagnostic at the closing call parenthesis. + parser.throwCleanError(Math.max(0, parser.tokenIndex - 2), + "exists argument is not a subroutine name"); + } + if (!isDeleteExistsTarget(argument)) { + String requirement = token.text.equals("exists") + ? "a HASH or ARRAY element or a subroutine" + : "a HASH or ARRAY element or slice"; + parser.throwCleanError(token.text + " argument is not " + requirement); + } + } } return new OperatorNode(token.text, operand, currentIndex); } + private static boolean operatorNameIsInvalidExistsSubroutineCall(String operator, Node argument) { + return operator.equals("exists") + && argument instanceof BinaryOperatorNode call + && call.operator.equals("(") + && call.left instanceof OperatorNode callee + && callee.operator.equals("&"); + } + + private static boolean isDeleteExistsTarget(Node argument) { + if (argument instanceof ListNode list && list.elements.size() == 1) { + return isDeleteExistsTarget(list.elements.getFirst()); + } + if (argument instanceof BlockNode block && block.elements.size() == 1) { + return isDeleteExistsTarget(block.elements.getFirst()); + } + // A leading + is a Perl parse disambiguator, not part of the + // lvalue target: exists +($ref // 0)->{key} is valid. + if (argument instanceof OperatorNode unaryPlus && unaryPlus.operator.equals("+")) { + return isDeleteExistsTarget(unaryPlus.operand); + } + if (argument instanceof OperatorNode operatorNode && operatorNode.operator.equals("&")) { + return true; + } + if (argument instanceof BinaryOperatorNode binaryOperatorNode) { + return binaryOperatorNode.operator.equals("{") + || binaryOperatorNode.operator.equals("[") + || binaryOperatorNode.operator.equals("->"); + } + return false; + } + static BinaryOperatorNode parseBless(Parser parser, int currentIndex) { // Handle 'bless' operator with special handling for class name Node ref; @@ -1250,12 +1435,19 @@ static BinaryOperatorNode parseSplit(Parser parser, LexerToken token, int curren return new BinaryOperatorNode(token.text, separator, operand, currentIndex); } - static BinaryOperatorNode parseJoin(Parser parser, LexerToken token, String operatorName, int currentIndex) { + static BinaryOperatorNode parseJoin(Parser parser, LexerToken token, String operatorName, int currentIndex, + int sourceIndex) { Node separator; ListNode operand; + if (TokenUtils.peek(parser).text.equals(",")) { + parser.throwError(sourceIndex, "Not enough arguments for " + operatorName + " or string"); + } int firstArgIndex = parser.tokenIndex; // Handle operators with a RuntimeList operand operand = ListParser.parseZeroOrMoreList(parser, 1, false, true, false, false); + if (operand.elements.isEmpty()) { + parser.throwError(sourceIndex, "Not enough arguments for " + operatorName + " or string"); + } separator = operand.elements.removeFirst(); if (token.text.equals("push") || token.text.equals("unshift")) { @@ -1276,17 +1468,50 @@ static BinaryOperatorNode parseJoin(Parser parser, LexerToken token, String oper if (!(op instanceof OperatorNode operatorNode && operatorNode.operator.equals("@"))) { // Perl 5.24+: pushing/unshifting onto scalar variable or expression is forbidden // But literals get a different error message - if (op instanceof OperatorNode || op instanceof BinaryOperatorNode) { + String argumentKind = arrayOperationArgumentKind(parser, op); + if (argumentKind.equals("constant item") + && (op instanceof OperatorNode || op instanceof BinaryOperatorNode)) { parser.throwError(firstArgIndex, "Experimental " + operatorName + " on scalar is now forbidden"); } - parser.throwError(firstArgIndex, "Type of arg 1 to " + operatorName + " must be array (not constant item)"); + // Perl points prototype-style push/unshift diagnostics at the + // value being inserted for aggregate and glob operands. + int errorIndex = argumentKind.equals("constant item") + ? firstArgIndex : Math.max(0, parser.tokenIndex - 1); + String message = "Type of arg 1 to " + operatorName + + " must be array (not " + argumentKind + ")"; + if (argumentKind.equals("constant item")) { + parser.throwError(errorIndex, message); + } + parser.deferErrorAtToken(errorIndex, message); } } return new BinaryOperatorNode(token.text, separator, operand, currentIndex); } + /** Return Perl's diagnostic category for a non-array array-operation operand. */ + private static String arrayOperationArgumentKind(Parser parser, Node operand) { + if (!(operand instanceof OperatorNode operatorNode)) { + return "constant item"; + } + if (operatorNode.operator.equals("*") || operatorNode.operator.equals("glob")) { + return "ref-to-glob cast"; + } + if (operatorNode.operator.equals("%") && operatorNode.operand instanceof IdentifierNode identifier) { + var entry = parser.ctx.symbolTable.getSymbolEntry("%" + identifier.name); + if (entry != null && (entry.decl().equals("my") || entry.decl().equals("state"))) { + return "private hash"; + } + return "hash dereference"; + } + return "constant item"; + } + static OperatorNode parseLast(Parser parser, LexerToken token, int currentIndex) { + if (parser.isInFieldInitializer && token.text.equals("last")) { + throw PerlCompilerException.withSourceLocation(currentIndex, + "Can't \"last\" out of field initialiser expression", parser.ctx.errorUtil); + } int savedIndex = parser.tokenIndex; LexerToken next = TokenUtils.peek(parser); @@ -1328,10 +1553,46 @@ static OperatorNode parseReturn(Parser parser, int currentIndex) { list.elements.add(expr); return new OperatorNode("return", list, currentIndex); } + rejectIndirectMapArgumentToReturn(parser); operand = ListParser.parseZeroOrMoreList(parser, 0, false, false, false, false); return new OperatorNode("return", operand, currentIndex); } + /** + * Perl rejects {@code return NAME map ...} as an attempted indirect + * argument; return has no filehandle/indirect-object form. Detect it + * before normal list parsing reaches map and reports a generic error. + */ + private static void rejectIndirectMapArgumentToReturn(Parser parser) { + int nameIndex = Whitespace.skipWhitespace(parser, parser.tokenIndex, parser.tokens); + if (nameIndex >= parser.tokens.size() || parser.tokens.get(nameIndex).type != IDENTIFIER + || isReturnStatementModifier(parser.tokens.get(nameIndex).text)) { + return; + } + int mapIndex = Whitespace.skipWhitespace(parser, nameIndex + 1, parser.tokens); + if (mapIndex >= parser.tokens.size() + || !parser.tokens.get(mapIndex).text.equals("map")) { + return; + } + + int argumentEnd = mapIndex; + for (int i = mapIndex + 1; i < parser.tokens.size(); i++) { + LexerToken token = parser.tokens.get(i); + if (token.type == NEWLINE || token.type == EOF || token.text.equals(";")) { + parser.throwError(argumentEnd, "Missing comma after first argument to return"); + } + if (token.type != WHITESPACE) { + argumentEnd = i; + } + } + } + + private static boolean isReturnStatementModifier(String token) { + return token.equals("if") || token.equals("unless") || token.equals("while") + || token.equals("until") || token.equals("for") || token.equals("foreach") + || token.equals("when"); + } + static OperatorNode parseGoto(Parser parser, int currentIndex) { Node operand; // Handle 'goto' keyword - operand is optional (bare `goto` is a runtime error) diff --git a/src/main/java/org/perlonjava/frontend/parser/ParseBlock.java b/src/main/java/org/perlonjava/frontend/parser/ParseBlock.java index 98256a8128..3bd8c3ff03 100644 --- a/src/main/java/org/perlonjava/frontend/parser/ParseBlock.java +++ b/src/main/java/org/perlonjava/frontend/parser/ParseBlock.java @@ -180,6 +180,14 @@ private static BlockWithScope parseBlockBody(Parser parser, boolean exitScope) { swallowedLookahead); statementNode.setAnnotation("statementStartIndex", coplineIndex); } + // A bare label before a direct subroutine call affects only the + // undefined-call diagnostic for that statement ("close to label + // 'LABEL'"). Preserve it on the statement so the call emitters + // can carry it to their direct-call preflight without changing + // ordinary label/control-flow handling. + if (label != null && statement instanceof AbstractNode statementNode) { + statementNode.setAnnotation("precedingLabel", label); + } statements.add(statement); } else { // This should never happen - log and skip diff --git a/src/main/java/org/perlonjava/frontend/parser/ParseHeredoc.java b/src/main/java/org/perlonjava/frontend/parser/ParseHeredoc.java index 970b5f3a0a..ae2ceed864 100644 --- a/src/main/java/org/perlonjava/frontend/parser/ParseHeredoc.java +++ b/src/main/java/org/perlonjava/frontend/parser/ParseHeredoc.java @@ -9,6 +9,7 @@ import org.perlonjava.frontend.lexer.LexerToken; import org.perlonjava.frontend.lexer.LexerTokenType; import org.perlonjava.runtime.runtimetypes.PerlCompilerException; +import org.perlonjava.runtime.runtimetypes.PerlParserException; import java.nio.charset.StandardCharsets; import java.util.ArrayList; @@ -74,16 +75,25 @@ static OperatorNode parseHeredoc(Parser parser, String tokenText) { identifier = tokenText; TokenUtils.consume(parser); } else { - throw new PerlCompilerException(parser.tokenIndex, "Use of bare << to mean <<\"\" is forbidden", parser.ctx.errorUtil); + throwBareHeredocDiagnostic(parser); } node.setAnnotation("delimiter", delimiter); if (identifier.isEmpty()) { // Consume identifier string using `q()` - Node identifierNode = parseRawString(parser, "q"); + Node identifierNode; + try { + identifierNode = parseRawString(parser, "q"); + } catch (PerlCompilerException e) { + if (e.getMessage() != null && e.getMessage().startsWith("Can't find string terminator")) { + throw PerlCompilerException.withSourceLocation(parser.tokenIndex, + "Unterminated delimiter for here document", parser.ctx.errorUtil); + } + throw e; + } if (identifierNode instanceof StringNode stringNode) { identifier = stringNode.value; } else { - throw new PerlCompilerException(parser.tokenIndex, "Use of bare << to mean <<\"\" is forbidden", parser.ctx.errorUtil); + throwBareHeredocDiagnostic(parser); } } node.setAnnotation("identifier", identifier); @@ -109,6 +119,13 @@ static OperatorNode parseHeredoc(Parser parser, String tokenText) { return node; } + /** Perl reports a bare heredoc marker without a generic parser excerpt. */ + private static void throwBareHeredocDiagnostic(Parser parser) { + var location = parser.ctx.errorUtil.getSourceLocationAccurate(parser.tokenIndex); + throw new PerlParserException("Use of bare << to mean <<\"\" is forbidden at " + + location.fileName() + " line " + location.lineNumber() + ".\n"); + } + static void heredocError(Parser parser) { // Try to get heredoc info if available, otherwise use generic message if (!parser.getHeredocNodes().isEmpty()) { diff --git a/src/main/java/org/perlonjava/frontend/parser/ParseInfix.java b/src/main/java/org/perlonjava/frontend/parser/ParseInfix.java index bec96f4bc6..2cfa0f6ea2 100644 --- a/src/main/java/org/perlonjava/frontend/parser/ParseInfix.java +++ b/src/main/java/org/perlonjava/frontend/parser/ParseInfix.java @@ -17,6 +17,7 @@ import org.perlonjava.runtime.runtimetypes.PerlCompilerException; import org.perlonjava.runtime.runtimetypes.PerlParserException; import org.perlonjava.runtime.runtimetypes.RuntimeCode; +import org.perlonjava.runtime.runtimetypes.RuntimeHash; import org.perlonjava.runtime.runtimetypes.RuntimeScalar; import java.util.ArrayList; @@ -34,6 +35,52 @@ */ public class ParseInfix { + private static OperatorNode typedFieldVariable(Node node) { + if (node instanceof OperatorNode operator) { + if (("$".equals(operator.operator) || "@".equals(operator.operator) + || "%".equals(operator.operator)) + && operator.operand instanceof IdentifierNode) { + return operator; + } + return typedFieldVariable(operator.operand); + } + if (node instanceof ListNode list && list.elements.size() == 1) { + return typedFieldVariable(list.elements.getFirst()); + } + if (node instanceof BlockNode block && block.elements.size() == 1) { + return typedFieldVariable(block.elements.getFirst()); + } + return null; + } + + private static void validateTypedFields( + Parser parser, Node left, HashLiteralNode keys, int tokenIndex) { + OperatorNode variable = typedFieldVariable(left); + if (variable == null || !(variable.operand instanceof IdentifierNode identifier)) return; + SymbolTable.SymbolEntry entry = parser.ctx.symbolTable + .getSymbolEntry(variable.operator + identifier.name); + if (entry == null || !(entry.ast() instanceof OperatorNode declared)) return; + Object typeValue = declared.getAnnotation("varType"); + if (!(typeValue instanceof String typeName)) return; + String fieldsName = typeName + "::FIELDS"; + // A forward declaration such as `sub FIELDS;` does not create the + // 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; + RuntimeHash fields = GlobalVariable.getGlobalHash(fieldsName); + for (Node key : keys.elements) { + String name = key instanceof StringNode string ? string.value + : key instanceof IdentifierNode id ? id.name : null; + if (name != null && !fields.containsKey(name)) { + throw PerlCompilerException.withSourceLocation(tokenIndex, + "No such class field \"" + name + "\" in variable $" + + identifier.name + " of type " + typeName, + parser.ctx.errorUtil); + } + } + } + // Non-chainable comparison operators (cannot be chained with any operator) private static final List NON_CHAINABLE_COMPARISON_OPS = Arrays.asList("<=>", "cmp", "~~"); @@ -213,6 +260,7 @@ public static Node parseInfixOperation(Parser parser, Node left, int precedence) validateNoStateInListAssignment(parser, left); validateConstantItemListLvalue(parser, left); validateKnownSubroutineLvalue(parser, left); + validateAggregateSubstrVecLvalue(parser, left, right); } if ((operator.equals("=~") || operator.equals("!~")) @@ -227,6 +275,8 @@ public static Node parseInfixOperation(Parser parser, Node left, int precedence) right = new OperatorNode("quoteRegex", regexOperand, right.getIndex()); } + rejectAggregateBitwiseAssignment(parser, operator, left, right); + if (operator.equals("=~") || operator.equals("!~")) { warnAggregateRegexBinding(parser, left, right, operatorIndex); rejectAggregateRegexMutation(parser, left, right); @@ -328,6 +378,7 @@ public static Node parseInfixOperation(Parser parser, Node left, int precedence) case "{": TokenUtils.consume(parser); right = new HashLiteralNode(parseHashSubscript(parser), parser.tokenIndex); + validateTypedFields(parser, left, (HashLiteralNode) right, parser.tokenIndex); return new BinaryOperatorNode(token.text, left, right, parser.tokenIndex); case "[": TokenUtils.consume(parser); @@ -479,6 +530,7 @@ public static Node parseInfixOperation(Parser parser, Node left, int precedence) case "{": // Handle hash subscripts right = new HashLiteralNode(parseHashSubscript(parser), parser.tokenIndex); + validateTypedFields(parser, left, (HashLiteralNode) right, parser.tokenIndex); // Check if left is $$var and transform to $var->{...} if (left instanceof OperatorNode leftOp && leftOp.operator.equals("$") && leftOp.operand instanceof OperatorNode innerOp && innerOp.operator.equals("$")) { @@ -501,6 +553,14 @@ public static Node parseInfixOperation(Parser parser, Node left, int precedence) // Handle postfix increment/decrement return new OperatorNode(token.text + "postfix", left, parser.tokenIndex); default: + if (left instanceof NumberNode number + && (token.text.equals("$") || token.text.equals("$#") || token.text.equals("@"))) { + throwMissingOperatorBeforeSigil(parser, number, token, operatorIndex); + } + if (left instanceof NumberNode number + && (token.text.equals("e") || token.text.equals("E"))) { + throwMissingOperatorBeforeIncompleteDecimalExponent(parser, number, token, operatorIndex); + } // `00my sub\0` reaches infix parsing after the numeric literal. // Perl nevertheless diagnoses the incomplete lexical-sub // declaration, rather than reporting a generic infix syntax @@ -526,6 +586,13 @@ public static Node parseInfixOperation(Parser parser, Node left, int precedence) } } } + if (token.type == LexerTokenType.IDENTIFIER + && !ParserTables.INFIX_OP.contains(token.text)) { + NumberNode concatenatedNumber = rightmostConcatenatedNumber(left); + if (concatenatedNumber != null) { + throwMissingOperatorBeforeBareword(parser, concatenatedNumber, token, operatorIndex); + } + } // Special check: if this is an IDENTIFIER that's a quote-like operator, it's not an infix operator // This handles cases where qr/q/qq/etc mistakenly reach here due to parser state issues if (token.type == LexerTokenType.IDENTIFIER && ParsePrimary.isIsQuoteLikeOperator(token.text)) { @@ -577,6 +644,121 @@ public static Node parseInfixOperation(Parser parser, Node left, int precedence) } } + /** + * Perl reports a missing operator before a sigil that immediately follows + * a numeric literal. The general fallback used to emit only the trailing + * syntax error, losing both the term kind and the source fragment. + */ + private static void throwMissingOperatorBeforeSigil(Parser parser, NumberNode left, + LexerToken sigil, int sigilIndex) { + String suffix = sigil.text; + String kind = sigil.text.equals("$") ? "Scalar" : "Array"; + int cursor = parser.tokenIndex; + + if (sigil.text.equals("$#")) { + kind = "Array length"; + } else if (sigil.text.equals("$") && cursor < parser.tokens.size() + && parser.tokens.get(cursor).text.equals("#")) { + suffix += "#"; + kind = "Array length"; + cursor++; + } + if (cursor < parser.tokens.size()) { + LexerToken following = parser.tokens.get(cursor); + if (following.text.equals("{") || following.type == LexerTokenType.IDENTIFIER) { + suffix += following.text; + } + } + + ErrorMessageUtil.SourceLocation location = + parser.ctx.errorUtil.getSourceLocationAccurate(left.getIndex()); + String near = left.value + suffix; + String syntaxNear = switch (suffix) { + case "@foo" -> near + "\n"; + default -> left.value + (suffix.startsWith("$#") ? "$#" : sigil.text); + }; + String at = " at " + location.fileName() + " line " + location.lineNumber() + + ", near \""; + String message = kind + " found where operator expected (Missing operator before \"" + + suffix + "\"?)" + at + near + "\"\n" + + "syntax error" + at + syntaxNear + "\"\n"; + throw new PerlParserException(message); + } + + /** + * A bare exponent marker after a decimal literal is not part of the + * literal unless a complete exponent follows. Perl diagnoses the marker + * as a bareword and points at the literal-plus-marker pair. + */ + private static void throwMissingOperatorBeforeIncompleteDecimalExponent(Parser parser, + NumberNode left, + LexerToken marker, + int markerIndex) { + ErrorMessageUtil.SourceLocation location = + parser.ctx.errorUtil.getSourceLocationAccurate(markerIndex); + String near = left.value + marker.text; + String at = " at " + location.fileName() + " line " + location.lineNumber() + + ", near \"" + near + "\"\n"; + String message = "Bareword found where operator expected (Missing operator before \"" + + marker.text + "\"?)" + at + + "syntax error" + at + + "Execution of " + location.fileName() + " aborted due to compilation errors.\n"; + throw new PerlParserException(message); + } + + private static NumberNode rightmostConcatenatedNumber(Node node) { + if (node instanceof NumberNode number) { + return number; + } + if (node instanceof BinaryOperatorNode binary && binary.operator.equals(".")) { + return rightmostConcatenatedNumber(binary.right); + } + return null; + } + + private static void throwMissingOperatorBeforeBareword(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"; + String message = "Bareword found where operator expected (Missing operator before \"" + + bareword.text + "\"?)" + at + "syntax error" + at; + throw new PerlParserException(message); + } + + /** + * Perl's bitwise compound assignments are scalar operations. Applying + * them to an aggregate is rejected during compilation rather than reaching + * the bytecode lvalue path (which cannot cast a RuntimeArray to a scalar). + */ + private static void rejectAggregateBitwiseAssignment(Parser parser, String operator, + Node left, Node right) { + if (!(left instanceof OperatorNode aggregate) + || !(aggregate.operator.equals("@") || aggregate.operator.equals("%"))) { + return; + } + String operation = switch (operator) { + case "binary&=" -> "numeric bitwise and (&)"; + case "binary|=" -> "numeric bitwise or (|)"; + case "binary^=" -> "numeric bitwise xor (^)"; + case "&.=" -> "string bitwise and (&.)"; + case "|.=" -> "string bitwise or (|.)"; + case "^.=" -> "string bitwise xor (^.)"; + default -> null; + }; + if (operation == null) { + return; + } + String aggregateName = aggregate.operator.equals("@") ? "array" : "hash"; + // Primary nodes retain the parser cursor after their final token; + // anchor the diagnostic on the RHS itself so Perl's context reads + // `near "1;"`, not merely the following semicolon. + parser.throwErrorAtToken(Math.max(0, right.getIndex() - 1), + "Can't modify " + aggregateName + " dereference in " + operation); + } + private static boolean isRegexOperator(Node node) { if (!(node instanceof OperatorNode operator)) return false; return operator.operator.equals("matchRegex") @@ -937,7 +1119,7 @@ private static void validateNoStateInListAssignment(Parser parser, Node left) { if (left instanceof OperatorNode opNode && opNode.operator.equals("state") && opNode.operand instanceof ListNode) { throw new PerlCompilerException( - parser.tokenIndex, + parser.tokenIndex - 1, "Initialization of state variables in list currently forbidden", parser.ctx.errorUtil); } @@ -946,7 +1128,7 @@ private static void validateNoStateInListAssignment(Parser parser, Node left) { // Left side is a ListNode that contains state declarations if (left instanceof ListNode listNode && containsStateDeclaration(listNode)) { throw new PerlCompilerException( - parser.tokenIndex, + parser.tokenIndex - 1, "Initialization of state variables in list currently forbidden", parser.ctx.errorUtil); } @@ -964,6 +1146,30 @@ private static void validateConstantItemListLvalue(Parser parser, Node left) { } } + /** Reject aggregate arguments to lvalue substr and vec before emission. */ + private static void validateAggregateSubstrVecLvalue(Parser parser, Node left, Node right) { + if (left instanceof ListNode list && list.elements.size() == 1) { + left = list.elements.getFirst(); + } + if (!(left instanceof OperatorNode operation) + || !(operation.operator.equals("substr") || operation.operator.equals("vec")) + || !(operation.operand instanceof ListNode args) + || args.elements.isEmpty()) { + return; + } + Node subject = args.elements.getFirst(); + if (subject instanceof OperatorNode scalar && scalar.operator.equals("scalar")) { + subject = scalar.operand; + } + if (!(subject instanceof OperatorNode aggregate) + || !(aggregate.operator.equals("@") || aggregate.operator.equals("%"))) { + return; + } + String kind = aggregate.operator.equals("@") ? "array" : "hash"; + parser.throwErrorAtToken(Math.max(0, right.getIndex() - 1), + "Can't modify " + kind + " dereference in " + operation.operator); + } + /** * Checks if a ListNode contains any state variable declarations, * either directly or nested within parenthesized sub-lists. diff --git a/src/main/java/org/perlonjava/frontend/parser/ParseMapGrepSort.java b/src/main/java/org/perlonjava/frontend/parser/ParseMapGrepSort.java index ec00564a53..06d3f7d25d 100644 --- a/src/main/java/org/perlonjava/frontend/parser/ParseMapGrepSort.java +++ b/src/main/java/org/perlonjava/frontend/parser/ParseMapGrepSort.java @@ -140,6 +140,11 @@ static BinaryOperatorNode parseSort(Parser parser, LexerToken token) { // into: sub { 123 } Node block = operand.handle; operand.handle = null; + if ((token.text.equals("all") || token.text.equals("any")) && block == null) { + // Unlike map and grep, the feature-gated all/any keywords do not + // accept a unary callback expression such as `any length, @list`. + parser.throwErrorAtToken(currentIndex - 2, "syntax error"); + } if (block == null) { // create default block for `sort`: { $a cmp $b } // Use the current package's $a and $b variables @@ -178,9 +183,18 @@ static BinaryOperatorNode parseMapGrep(Parser parser, LexerToken token) { String previousForbiddenContext = parser.futureAsyncAwaitForbiddenContext; parser.futureAsyncAwaitForbiddenContext = token.text; try { + // The feature-gated all/any keywords require a literal block; + // unlike map and grep they do not accept a unary callback. + if ((token.text.equals("all") || token.text.equals("any")) + && !startsAllAnyLiteralBlock(parser)) { + parser.throwErrorAtToken(currentIndex - 2, "syntax error"); + } // Handle 'map' keyword as a Binary operator with a Code and List operands operand = ListParser.parseZeroOrMoreList(parser, 1, true, false, false, false); } catch (PerlCompilerException e) { + if (token.text.equals("all") || token.text.equals("any")) { + throw e; + } // map chr, 1,2,3 parser.tokenIndex = currentIndex; @@ -224,4 +238,24 @@ static BinaryOperatorNode parseMapGrep(Parser parser, LexerToken token) { } return new BinaryOperatorNode(token.text, block, operand, parser.tokenIndex); } + + /** + * all/any require a literal block, but Perl permits that block and list + * to be wrapped in invocation parentheses: {@code any( { ... } @list)}. + */ + private static boolean startsAllAnyLiteralBlock(Parser parser) { + int index = parser.tokenIndex; + while (index < parser.tokens.size() + && parser.tokens.get(index).type == LexerTokenType.WHITESPACE) { + index++; + } + if (index < parser.tokens.size() && parser.tokens.get(index).text.equals("(")) { + index++; + while (index < parser.tokens.size() + && parser.tokens.get(index).type == LexerTokenType.WHITESPACE) { + index++; + } + } + return index < parser.tokens.size() && parser.tokens.get(index).text.equals("{"); + } } diff --git a/src/main/java/org/perlonjava/frontend/parser/ParsePrimary.java b/src/main/java/org/perlonjava/frontend/parser/ParsePrimary.java index a0741c7d81..7cc66fd964 100644 --- a/src/main/java/org/perlonjava/frontend/parser/ParsePrimary.java +++ b/src/main/java/org/perlonjava/frontend/parser/ParsePrimary.java @@ -340,11 +340,11 @@ static Node parseOperator(Parser parser, LexerToken token, String operator) { case "{": // Curly braces create anonymous hash references - return new HashLiteralNode(ListParser.parseList(parser, "}", 0), parser.tokenIndex); + return new HashLiteralNode(ListParser.parseList(parser, "}", 0, parser.tokenIndex - 1), parser.tokenIndex); case "[": // Square brackets create anonymous array references - return new ArrayLiteralNode(ListParser.parseList(parser, "]", 0), parser.tokenIndex); + return new ArrayLiteralNode(ListParser.parseList(parser, "]", 0, parser.tokenIndex - 1), parser.tokenIndex); case ".": // Dot at the beginning of a primary expression is a fractional number (.5) diff --git a/src/main/java/org/perlonjava/frontend/parser/Parser.java b/src/main/java/org/perlonjava/frontend/parser/Parser.java index 08b081fe03..49d9747ae9 100644 --- a/src/main/java/org/perlonjava/frontend/parser/Parser.java +++ b/src/main/java/org/perlonjava/frontend/parser/Parser.java @@ -6,6 +6,7 @@ import org.perlonjava.frontend.astnode.AbstractNode; import org.perlonjava.frontend.astnode.FormatNode; import org.perlonjava.frontend.astnode.Node; +import org.perlonjava.frontend.astnode.NumberNode; import org.perlonjava.frontend.astnode.OperatorNode; import org.perlonjava.frontend.lexer.LexerToken; import org.perlonjava.frontend.lexer.LexerTokenType; @@ -97,6 +98,7 @@ public boolean hasVisibleLexicalSubroutine(String name) { private final List formatNodes = new ArrayList<>(); // List to store completed format nodes after template parsing. private final List completedFormatNodes = new ArrayList<>(); + private final List deferredDiagnostics = new ArrayList<>(); // Current index in the token list. public int tokenIndex = 0; // Flags to indicate special parsing states. @@ -105,6 +107,9 @@ public boolean hasVisibleLexicalSubroutine(String name) { // sub declared here must be instantiated when the loop body runs so its // closure captures the iteration's localized lexical cell. public int parsingRuntimeLoopBodyDepth = 0; + // Nesting depth of given blocks currently being parsed. `when` and + // `default` are only valid within a topicalizer. + public int parsingGivenDepth = 0; public boolean parsingTakeReference = false; // Format argument lines are parsed by a short-lived child parser. Record // the lexical sub it resolved so the detached RuntimeFormat can retain @@ -141,8 +146,12 @@ public boolean hasVisibleLexicalSubroutine(String name) { public boolean isTopLevelScript = false; // Are we parsing inside a class block? public boolean isInClassBlock = false; + /** Name of the class whose body is currently being parsed, if any. */ + public String currentClassName = null; // Are we parsing inside a method? public boolean isInMethod = false; + /** True while parsing a class field initializer expression. */ + public boolean isInFieldInitializer = false; // Are we parsing inside a braced dereference like %{...} or @{...}? // When true, inner {} should default to hash constructor, not block. public boolean insideBracedDereference = false; @@ -292,12 +301,21 @@ public Node parse() { // attempts to reduce the surrounding statement. Doing this as a // lexical diagnostic is important for input such as "$_\n<<<<<<<": // the incomplete preceding expression must not mask the marker. + StringBuilder conflictDiagnostics = new StringBuilder(); for (int i = 0; i < tokens.size(); i++) { if (tokens.get(i).type == LexerTokenType.CONFLICT_MARKER) { - throw new PerlCompilerException(i, - "Version control conflict marker", ctx.errorUtil); + ErrorMessageUtil.SourceLocation location = + ctx.errorUtil.getSourceLocationAccurate(i); + conflictDiagnostics.append("Version control conflict marker at ") + .append(location.fileName()).append(" line ") + .append(location.lineNumber()).append(", near \"") + .append(tokens.get(i).text.substring(0, 7)) + .append("\"\n"); } } + if (!conflictDiagnostics.isEmpty()) { + throw new PerlParserException(conflictDiagnostics.toString()); + } if (tokens.get(tokenIndex).text.equals("=")) { // looks like pod: insert a newline to trigger pod parsing tokens.addFirst(new LexerToken(LexerTokenType.NEWLINE, "\n")); @@ -312,6 +330,16 @@ public Node parse() { Node ast; try { ast = ParseBlock.parseBlock(this); + } catch (PerlCompilerException | PerlParserException exception) { + // Recoverable diagnostics (such as strict vars) are normally + // reported after parsing. If a later syntax error aborts parsing, + // retain those earlier diagnostics ahead of the terminal error, + // matching Perl's multi-error compile output. + if (!deferredDiagnostics.isEmpty()) { + throw new PerlCompilerException( + String.join("", deferredDiagnostics) + exception.getMessage()); + } + throw exception; } finally { compilationState.unitcheckQueueStack.get().pop(); } @@ -338,9 +366,40 @@ public Node parse() { if (!getHeredocNodes().isEmpty()) { ParseHeredoc.heredocError(this); } + if (!deferredDiagnostics.isEmpty()) { + throw new PerlCompilerException(String.join("", deferredDiagnostics)); + } return ast; } + /** Record a parse-time diagnostic after consuming a recoverable statement. */ + public void deferErrorAtToken(int index, String message) { + deferredDiagnostics.add(ctx.errorUtil.errorMessage(index, message)); + } + + /** Record an already formatted recoverable diagnostic. */ + public void deferDiagnostic(String diagnostic) { + deferredDiagnostics.add(diagnostic); + // Perl stops after the tenth compile diagnostic, leaving this marker + // after the final reported error. Deferred recovery errors must count + // toward that limit just like immediately-thrown parser errors. + if (deferredDiagnostics.size() == 10) { + String fileName = ctx.errorUtil.getSourceLocationAccurate(Math.max(0, tokenIndex - 1)).fileName(); + deferredDiagnostics.add(fileName + " has too many errors.\n"); + } + } + + /** Number of recoverable compile diagnostics accumulated so far. */ + public int deferredDiagnosticCount() { + return deferredDiagnostics.size(); + } + + /** Record a diagnostic whose source excerpt must end at a trailing comma. */ + public void deferErrorAtTokenWithoutTrailingCommaWhitespace(int index, String message) { + String diagnostic = ctx.errorUtil.errorMessage(index, message); + deferredDiagnostics.add(diagnostic.replace(", \"\n", ",\"\n")); + } + /** * Parses an expression based on operator precedence. *

@@ -379,6 +438,12 @@ public Node parseExpression(int precedence) { break; // Exit the loop if we're done parsing. } + PerlParserException adjacentBaseLiteralError = + adjacentIncompleteBaseLiteralError(left, token); + if (adjacentBaseLiteralError != null) { + throw adjacentBaseLiteralError; + } + // Get the precedence of the current token. int tokenPrecedence = getPrecedence(token.text); @@ -449,6 +514,74 @@ public Node parseExpression(int precedence) { return left; } + /** + * A second numeric term normally ends the current expression before + * infix parsing is entered. Retain Perl's three diagnostics when that + * term begins an incomplete base literal, rather than letting the + * statement parser reduce it to a generic syntax error. + */ + private PerlParserException adjacentIncompleteBaseLiteralError(Node left, LexerToken token) { + if (!(left instanceof NumberNode) || token.type != LexerTokenType.NUMBER + || !"0".equals(token.text) || tokenIndex + 1 >= tokens.size()) { + return null; + } + + LexerToken prefixToken = tokens.get(tokenIndex + 1); + if (prefixToken.type != LexerTokenType.IDENTIFIER || prefixToken.text.isEmpty()) { + return null; + } + char prefixChar = Character.toLowerCase(prefixToken.text.charAt(0)); + String kind = switch (prefixChar) { + case 'x' -> "hexadecimal"; + case 'b' -> "binary"; + case 'o' -> "octal"; + default -> null; + }; + if (kind == null || hasBaseLiteralDigit(prefixToken.text.substring(1), prefixChar)) { + return null; + } + + int previous = tokenIndex - 1; + while (previous >= 0 && tokens.get(previous).type == LexerTokenType.WHITESPACE) { + previous--; + } + if (previous < 0 || tokens.get(previous).type != LexerTokenType.NUMBER + || previous == tokenIndex - 1) { + return null; + } + + String literal = TokenUtils.toText(tokens, tokenIndex, tokenIndex + 1); + String near = TokenUtils.toText(tokens, previous, tokenIndex + 1); + String noDigitsNear = near; + if (tokenIndex + 2 < tokens.size()) { + LexerToken trailing = tokens.get(tokenIndex + 2); + if (trailing.type != LexerTokenType.EOF && trailing.type != LexerTokenType.NEWLINE) { + noDigitsNear += trailing.text; + } + } + + ErrorMessageUtil.SourceLocation location = ctx.errorUtil.getSourceLocationAccurate(previous); + String at = " at " + location.fileName() + " line " + location.lineNumber(); + String message = "Number found where operator expected (Missing operator before \"" + + literal + "\"?)" + at + ", near \"" + near + "\"\n" + + "No digits found for " + kind + " literal" + at + ", near \"" + + noDigitsNear + "\"\n" + + "syntax error" + at + ", near \"" + near + "\"\n" + + "Execution of " + location.fileName() + + " aborted due to compilation errors.\n"; + return new PerlParserException(message); + } + + private static boolean hasBaseLiteralDigit(String text, char prefix) { + String expression = switch (prefix) { + case 'x' -> "[0-9a-fA-F_]"; + case 'b' -> "[01_]"; + case 'o' -> "[0-7_]"; + default -> ""; + }; + return text.matches(expression + "*") && !text.replace("_", "").isEmpty(); + } + public void throwError(String message) { int errorIndex = this.tokenIndex; if (errorIndex > 1 && tokens.get(errorIndex - 1).type == LexerTokenType.NEWLINE) { @@ -461,6 +594,14 @@ public void throwError(int index, String message) { throw new PerlCompilerException(index, message, this.ctx.errorUtil); } + /** + * Throws an error anchored at the supplied source token without the + * normal newline rewind used for parser-cursor diagnostics. + */ + public void throwErrorAtToken(int index, String message) { + throw new PerlCompilerException(this.ctx.errorUtil.errorMessageAtToken(index, message)); + } + /** * A source file without an encoding declaration is decoded byte-for-byte * when it contains invalid UTF-8. A BEGIN block may subsequently turn on @@ -498,6 +639,40 @@ public void validateRemainingByteSourceUtf8() { : value <= 0xFB ? 5 : value <= 0xFD ? 6 : value == 0xFE ? 7 : 13; + int followingByte = -1; + outer: + for (int j = i; j < tokens.size(); j++) { + if (tokens.get(j).type == LexerTokenType.EOF) { + break; + } + String text = tokens.get(j).text; + int start = j == i ? offset + 1 : 0; + for (int k = start; k < text.length(); k++) { + followingByte = text.charAt(k); + break outer; + } + } + if (followingByte >= 0 + && (followingByte < 0x80 || followingByte > 0xBF)) { + String sequence = byteText + String.format("\\x%02x", followingByte); + detail = "Malformed UTF-8 character: " + sequence + + " (unexpected non-continuation byte 0x" + + String.format("%02x", followingByte) + + ", immediately after start byte 0x" + + String.format("%02x", value) + + "; need " + needed + " bytes, got 1)"; + String at = " at " + location.fileName() + " line " + + location.lineNumber() + "."; + String overlong = (value == 0xC0 || value == 0xC1) + ? "\nMalformed UTF-8 character: " + byteText + + " (any UTF-8 sequence that starts with \"" + byteText + + "\" is overlong which can and should be represented with a different, shorter sequence)" + : ""; + String supplementalDiagnostic = overlong.isEmpty() + ? "" : overlong + at; + throw new PerlCompilerException(detail + at + supplementalDiagnostic + "\n" + + "Malformed UTF-8 character (fatal)" + at); + } int available = 1; for (int j = i; j < tokens.size(); j++) { String text = tokens.get(j).text; @@ -530,7 +705,11 @@ public void validateRemainingByteSourceUtf8() { * without additional context or stack traces. */ public void throwCleanError(String message) { - ErrorMessageUtil.SourceLocation loc = this.ctx.errorUtil.getSourceLocationAccurate(this.tokenIndex); + throwCleanError(this.tokenIndex, message); + } + + public void throwCleanError(int index, String message) { + ErrorMessageUtil.SourceLocation loc = this.ctx.errorUtil.getSourceLocationAccurate(index); String cleanMessage = message + " at " + loc.fileName() + " line " + loc.lineNumber() + "."; throw new PerlParserException(cleanMessage); } diff --git a/src/main/java/org/perlonjava/frontend/parser/SignatureParser.java b/src/main/java/org/perlonjava/frontend/parser/SignatureParser.java index 3f2adcba75..95c64ed208 100644 --- a/src/main/java/org/perlonjava/frontend/parser/SignatureParser.java +++ b/src/main/java/org/perlonjava/frontend/parser/SignatureParser.java @@ -48,9 +48,11 @@ public class SignatureParser { private final List requiredNamedParameterNames = new ArrayList<>(); private final List defaultValueNodes = new ArrayList<>(); private boolean hasOptional = false; + private boolean hasNamedParameter = false; private String namedArgsHashName = null; // Track the hash name for named parameters private String subroutineName = null; // Optional subroutine name for error messages private boolean isMethod = false; // True if parsing method signature (has implicit $self) + private int signatureOpenParenIndex; private SignatureParser(Parser parser) { this.parser = parser; @@ -103,6 +105,8 @@ public static ListNode parseSignature(Parser parser, String methodName, boolean } private ListNode parse() { + peekToken(); + signatureOpenParenIndex = parser.tokenIndex; consumeOpenParen(); // Handle empty signature @@ -111,6 +115,10 @@ private ListNode parse() { return generateSignatureAST(); } + if (peekToken().text.equals(",")) { + parser.throwErrorAtToken(previousSignificantToken(parser.tokenIndex), "syntax error"); + } + // Parse parameters while (true) { parseParameter(); @@ -130,7 +138,7 @@ private ListNode parse() { if (next.text.equals("$") || next.text.equals("@") || next.text.equals("%")) { parser.throwError("syntax error"); } - parser.throwError("Expected ',' or ')' in signature prototype"); + throwMalformedSeparator(); } } @@ -151,18 +159,37 @@ private void parseParameter() { LexerToken sigilToken = consumeToken(); String sigil = sigilToken.text; - validateSigil(sigil); + boolean immediatelyFollowedByHash = parser.tokenIndex < parser.tokens.size() + && "#".equals(parser.tokens.get(parser.tokenIndex).text); + if (validateSigil(sigil, paramStartIndex, isNamed, immediatelyFollowedByHash)) { + recoverImmediateHashAfterSigil(paramStartIndex); + return; + } - if (hasSlurpy) { - parser.throwError(paramStartIndex, "Slurpy parameter not last"); + // A slurpy array or hash is permitted after named parameters to + // collect their unrecognized arguments. Only a later ordinary + // positional scalar is forbidden. + if (!isNamed && hasNamedParameter && sigil.equals("$")) { + parser.throwError(paramStartIndex, "Positional parameter follows named parameter"); } // Check if this is a slurpy parameter boolean isSlurpy = sigil.equals("@") || sigil.equals("%"); + // Keep parsing after a slurpy parameter so Perl can report every + // following invalid parameter in the same signature. + if (hasSlurpy) { + String message = isSlurpy ? "Multiple slurpy parameters not allowed" : "Slurpy parameter not last"; + if (!isSlurpy && hasDefaultValueBeforeCloseParen()) { + parser.deferErrorAtToken(lastSignatureTokenBeforeCloseParen(), message); + } else { + parser.deferErrorAtTokenWithoutTrailingCommaWhitespace(paramStartIndex, message); + } + } + // Named parameters cannot be slurpy if (isNamed && isSlurpy) { - parser.throwError("Named parameters cannot be slurpy"); + throwNamedSlurpyParameterError(sigil); } // Parse parameter name (if present) @@ -172,12 +199,20 @@ private void parseParameter() { } if (paramName != null && paramName.equals("_")) { - parser.throwError(paramStartIndex, "Can't use global " + sigil + "_ in subroutine signature"); + var location = parser.ctx.errorUtil.getSourceLocationAccurate(signatureOpenParenIndex); + throw new PerlCompilerException("Can't use global " + sigil + "_ in subroutine signature at " + + location.fileName() + " line " + location.lineNumber() + ", near \"(" + + sigil + "_\"\n"); + } + + if (isNamed && paramName != null && namedParameterNames.contains(paramName)) { + parser.throwError(paramStartIndex, "Duplicated subroutine parameter name"); } // Named parameters must have a name if (isNamed && paramName == null) { - parser.throwError("Named parameters must actually have a name"); + parser.throwError(previousSignificantToken(paramStartIndex), + "Named parameters must actually have a name"); } // Check for illegal operator after parameter (e.g. $b += 1) @@ -186,7 +221,7 @@ private void parseParameter() { && !afterParam.text.equals("=") && !afterParam.text.equals("//=") && !afterParam.text.equals("||=") && !afterParam.text.equals("$") && !afterParam.text.equals("@") && !afterParam.text.equals("%")) { if (afterParam.type == LexerTokenType.OPERATOR) { - parser.throwError("Illegal operator following parameter in a subroutine signature"); + throwMalformedSeparator(); } } @@ -194,6 +229,12 @@ private void parseParameter() { Node paramVariable = createParameterVariable(sigil, paramName); if (isNamed) { + hasNamedParameter = true; + LexerToken namedDefault = peekToken(); + if (hasOptional && !namedDefault.text.equals("=") + && !namedDefault.text.equals("//=") && !namedDefault.text.equals("||=")) { + parser.throwError(paramStartIndex, "Mandatory parameter follows optional parameter"); + } // Named parameters are handled separately, not part of @_ unpacking namedParameterNodes.add(paramVariable); namedParameterNames.add(paramName); @@ -228,23 +269,191 @@ private void parseParameter() { } } - private void validateSigil(String sigil) { - // Check for $# which is tokenized as a single token - if (sigil.equals("$#")) { - parser.throwError("'#' not allowed immediately following a sigil in a subroutine signature"); + private int previousSignificantToken(int index) { + for (int previous = index - 1; previous >= 0; previous--) { + if (parser.tokens.get(previous).type != LexerTokenType.WHITESPACE) { + return previous; + } + } + return index; + } + + private boolean validateSigil(String sigil, int paramStartIndex, boolean isNamed, + boolean immediatelyFollowedByHash) { + // The lexer may combine a sigil and an immediately following '#' + // (for example, "$#") into one token. Diagnose all three sigils at + // the preceding open-paren context, which is the source position Perl + // reports. Keep parsing so the following line receives its ordinary + // recovered syntax diagnostic too. + if (sigil.length() == 2 && sigil.charAt(1) == '#' + && (sigil.charAt(0) == '$' || sigil.charAt(0) == '@' || sigil.charAt(0) == '%')) { + deferImmediateHashAfterSigilDiagnostic(paramStartIndex, sigil.charAt(0)); + return true; } if (!sigil.equals("$") && !sigil.equals("@") && !sigil.equals("%")) { - parser.throwError("A signature parameter must start with '$', '@' or '%'"); + recoverInvalidParameterStart(paramStartIndex, isNamed, sigil); + return true; } // Check for double sigil or invalid character after sigil + // Check the raw following token before peekToken() has a chance to + // interpret '#' as a comment and skip past its terminating newline. + // The recovery below needs that newline to emit Perl's second syntax + // error for the first token on the next line. + if (immediatelyFollowedByHash) { + deferImmediateHashAfterSigilDiagnostic(paramStartIndex, sigil.charAt(0)); + return true; + } LexerToken next = peekToken(); if (next.text.equals("$") || next.text.equals("@") || next.text.equals("%")) { - parser.throwError("Illegal character following sigil in a subroutine signature"); + throwDoubleSigilError(sigil, next.text); + } + if (next.type == LexerTokenType.NUMBER) { + var location = parser.ctx.errorUtil.getSourceLocationAccurate(signatureOpenParenIndex); + throw new PerlCompilerException("Illegal operator following parameter in a subroutine signature at " + + location.fileName() + " line " + location.lineNumber() + ", near \"(" + + sigil + next.text + "\"\n"); } if (next.text.equals("#")) { - parser.throwError("'#' not allowed immediately following a sigil in a subroutine signature"); + deferImmediateHashAfterSigilDiagnostic(paramStartIndex, sigil.charAt(0)); + return true; + } + return false; + } + + private void throwDoubleSigilError(String sigil, String followingSigil) { + var location = parser.ctx.errorUtil.getSourceLocationAccurate(signatureOpenParenIndex); + String closing = parser.tokenIndex + 1 < parser.tokens.size() + ? parser.tokens.get(parser.tokenIndex + 1).text : ""; + String trailingWhitespace = parser.tokenIndex + 2 < parser.tokens.size() + && parser.tokens.get(parser.tokenIndex + 2).type == LexerTokenType.WHITESPACE + ? parser.tokens.get(parser.tokenIndex + 2).text : ""; + throw new PerlCompilerException("Illegal character following sigil in a subroutine signature at " + + location.fileName() + " line " + location.lineNumber() + ", near \"(" + + sigil + "\"\nsyntax error at " + location.fileName() + " line " + + location.lineNumber() + ", near \"" + sigil + followingSigil + closing + + trailingWhitespace + "\"\n"); + } + + private void recoverInvalidParameterStart(int paramStartIndex, boolean isNamed, String token) { + int contextStart = previousSignificantToken(paramStartIndex); + var location = parser.ctx.errorUtil.getSourceLocationAccurate(contextStart); + String message = isNamed + ? "A named signature parameter must start with '$'" + : "A signature parameter must start with '$', '@' or '%'"; + throw new PerlCompilerException(message + " at " + location.fileName() + " line " + + location.lineNumber() + ", near \"" + signatureExcerpt(contextStart, true) + "\"\n" + + "syntax error at " + location.fileName() + " line " + + location.lineNumber() + ", near \"" + signatureExcerpt(contextStart, false) + "\"\n"); + } + + private String signatureExcerpt(int start, boolean onlyFirstCharacterOfLastToken) { + StringBuilder excerpt = new StringBuilder(); + int end = parser.tokenIndex - 1; + for (int i = start; i <= end; i++) { + LexerToken token = parser.tokens.get(i); + if (i == end && onlyFirstCharacterOfLastToken) { + excerpt.append(token.text.charAt(0)); + } else { + excerpt.append(token.text); + } + } + return excerpt.toString(); + } + + private void throwMalformedSeparator() { + var location = parser.ctx.errorUtil.getSourceLocationAccurate(signatureOpenParenIndex); + String excerpt = malformedSeparatorExcerpt(); + String diagnostic = "Illegal operator following parameter in a subroutine signature at " + + location.fileName() + " line " + location.lineNumber() + ", near \"" + + excerpt + "\"\n" + + "syntax error at " + location.fileName() + " line " + location.lineNumber() + + ", near \"" + excerpt + "\"\n"; + throw new PerlCompilerException(diagnostic); + } + + private String malformedSeparatorExcerpt() { + int end = parser.tokenIndex; + String unexpected = parser.tokens.get(end).text; + // A compound assignment after a signature parameter is rejected as + // one operator, but Perl's diagnostic includes the first token of the + // attempted default expression too: `($a += 1`. + if (unexpected.endsWith("=")) { + int expressionStart = end + 1; + while (expressionStart < parser.tokens.size() + && parser.tokens.get(expressionStart).type == LexerTokenType.WHITESPACE) { + expressionStart++; + } + if (expressionStart < parser.tokens.size() + && parser.tokens.get(expressionStart).type != LexerTokenType.EOF) { + end = expressionStart; + } + } + if (";".equals(unexpected) && end + 1 < parser.tokens.size() + && parser.tokens.get(end + 1).type == LexerTokenType.WHITESPACE) { + end++; + } + if ("{".equals(unexpected)) { + while (end + 1 < parser.tokens.size() && !"}".equals(parser.tokens.get(end).text)) { + end++; + } + } + StringBuilder excerpt = new StringBuilder(); + for (int i = signatureOpenParenIndex; i <= end; i++) { + LexerToken token = parser.tokens.get(i); + excerpt.append(token.text); + if (":".equals(unexpected) && i == end) { + break; + } + } + return excerpt.toString(); + } + + private void throwNamedSlurpyParameterError(String sigil) { + var location = parser.ctx.errorUtil.getSourceLocationAccurate(signatureOpenParenIndex); + String name = parser.tokenIndex < parser.tokens.size() ? parser.tokens.get(parser.tokenIndex).text : ""; + throw new PerlCompilerException("A named signature parameter must start with '$' at " + + location.fileName() + " line " + location.lineNumber() + ", near \"(:" + sigil + "\"\n" + + "syntax error at " + location.fileName() + " line " + location.lineNumber() + + ", near \":" + sigil + name + "\"\n"); + } + + private void deferImmediateHashAfterSigilDiagnostic(int paramStartIndex, char sigil) { + var location = parser.ctx.errorUtil.getSourceLocationAccurate( + previousSignificantToken(paramStartIndex)); + parser.deferDiagnostic("'#' not allowed immediately following a sigil in a subroutine signature at " + + location.fileName() + " line " + location.lineNumber() + + ", near \"(" + sigil + "\"\n"); + } + + /** + * Perl recovers from {@code $#foo} in a signature until the closing + * parenthesis, producing a second syntax error at the next line. Do the + * same without installing an invalid lexical such as {@code $#foo}. + */ + private void recoverImmediateHashAfterSigil(int paramStartIndex) { + int syntaxIndex = -1; + boolean afterNewline = false; + for (int i = parser.tokenIndex; i < parser.tokens.size(); i++) { + LexerToken token = parser.tokens.get(i); + if (token.type == LexerTokenType.NEWLINE) { + afterNewline = true; + continue; + } + if (afterNewline && token.type != LexerTokenType.WHITESPACE) { + syntaxIndex = i; + break; + } + } + if (syntaxIndex >= 0) { + var location = parser.ctx.errorUtil.getSourceLocationAccurate(syntaxIndex); + parser.deferDiagnostic("syntax error at " + location.fileName() + " line " + + location.lineNumber() + ", near \"" + + parser.tokens.get(syntaxIndex).text + "\"\n"); + } + while (!peekToken().text.equals(")") && peekToken().type != LexerTokenType.EOF) { + consumeToken(); } } @@ -262,21 +471,55 @@ private void handleSlurpyParameter() { LexerToken next = peekToken(); if (next.text.equals("=") || next.text.equals("//=") || next.text.equals("||=")) { - parser.throwError("A slurpy parameter may not have a default value"); - } - - // Verify no more parameters after slurpy - if (next.text.equals(",")) { - consumeToken(); // consume comma - next = peekToken(); - if (!next.text.equals(")")) { - if (next.text.equals("@") || next.text.equals("%")) { - parser.throwError("Multiple slurpy parameters not allowed"); - } else { - parser.throwError("Slurpy parameter not last"); - } + int defaultOperatorIndex = parser.tokenIndex; + consumeToken(); + // Perl points this error at the default expression, not its '='. + LexerToken defaultExpression = peekToken(); + int diagnosticIndex = defaultExpression.text.equals(")") + ? defaultOperatorIndex + : parser.tokenIndex; + parser.throwError(diagnosticIndex, "A slurpy parameter may not have a default value"); + } + + } + + private boolean hasDefaultValueBeforeCloseParen() { + int nested = 0; + for (int index = parser.tokenIndex; index < parser.tokens.size(); index++) { + LexerToken token = parser.tokens.get(index); + if (token.type == LexerTokenType.EOF) break; + if (token.text.equals(")") && nested == 0) break; + if (token.text.equals("(")) { + nested++; + } else if (token.text.equals(")") && nested > 0) { + nested--; + } else if (token.text.equals("=") || token.text.equals("//=") || token.text.equals("||=")) { + return true; + } + } + return false; + } + + /** Perl points slurpy-order errors at the last significant signature token. */ + private int lastSignatureTokenBeforeCloseParen() { + int index = parser.tokenIndex; + int last = index; + int nested = 0; + while (index < parser.tokens.size()) { + LexerToken token = parser.tokens.get(index); + if (token.type == LexerTokenType.EOF) break; + if (token.text.equals(")") && nested == 0) break; + if (token.text.equals("(")) { + nested++; + } else if (token.text.equals(")") && nested > 0) { + nested--; } + if (token.type != LexerTokenType.WHITESPACE && !token.text.equals("=")) { + last = index; + } + index++; } + return last; } private void handleScalarParameter(Node paramVariable, int paramStartIndex) { @@ -293,7 +536,10 @@ private void handleScalarParameter(Node paramVariable, int paramStartIndex) { } } else { if (hasOptional) { - parser.throwError(paramStartIndex, "Mandatory parameter follows optional parameter"); + // Perl reports every mandatory parameter after the first + // optional one, so retain this diagnostic and keep parsing + // the remainder of the signature. + parser.deferErrorAtToken(paramStartIndex, "Mandatory parameter follows optional parameter"); } minParams++; } @@ -376,7 +622,7 @@ private Node parseDefaultValue(Node paramVariable) { if (next.type == LexerTokenType.EOF || next.text.equals(",") || next.text.equals(")")) { boolean isUndef = paramVariable instanceof OperatorNode && ((OperatorNode) paramVariable).operator.equals("undef"); if (paramVariable != null && !isUndef) { - parser.throwError("Optional parameter lacks default expression"); + parser.throwError(previousDefaultOperatorIndex(), "Optional parameter lacks default expression"); } return null; } @@ -397,6 +643,18 @@ private Node parseDefaultValue(Node paramVariable) { return value; } + private int previousDefaultOperatorIndex() { + for (int index = parser.tokenIndex - 1; index >= 0; index--) { + LexerToken token = parser.tokens.get(index); + if (token.type == LexerTokenType.WHITESPACE) continue; + if (token.text.equals("=") || token.text.equals("//=") || token.text.equals("||=")) { + return index; + } + break; + } + return parser.tokenIndex; + } + private void qualifySelfReference(Node node, String name) { if (node instanceof OperatorNode op) { if ("$".equals(op.operator) && op.operand instanceof IdentifierNode id diff --git a/src/main/java/org/perlonjava/frontend/parser/SpecialBlockParser.java b/src/main/java/org/perlonjava/frontend/parser/SpecialBlockParser.java index b3106ebb1f..2efaa71f3a 100644 --- a/src/main/java/org/perlonjava/frontend/parser/SpecialBlockParser.java +++ b/src/main/java/org/perlonjava/frontend/parser/SpecialBlockParser.java @@ -164,6 +164,8 @@ static Node parseSpecialBlock(Parser parser) { block, false, parser.tokenIndex); + adjustSub.setAnnotation("classAdjustBlock", Boolean.TRUE); + block.setAnnotation("classAdjustBlock", Boolean.TRUE); // Store in parser's ADJUST blocks list parser.classAdjustBlocks.add(adjustSub); @@ -494,6 +496,17 @@ static RuntimeList runSpecialBlock(Parser parser, String blockPhase, Node block, if (message == null) { message = t.getClass().getSimpleName() + " during " + blockPhase; } + if ("BEGIN".equals(blockPhase) && parser.currentClassName != null + && message.contains("Can't locate object method \"new\" via package \"" + + parser.currentClassName + "\"")) { + ErrorMessageUtil.SourceLocation loc = + parser.ctx.errorUtil.getSourceLocationAccurate(tokenIndex); + String location = " at " + loc.fileName() + " line " + loc.lineNumber() + ".\n"; + throw new PerlCompilerException( + "Cannot create an object of incomplete class \"" + parser.currentClassName + + "\"" + location + + "BEGIN failed--compilation aborted" + location); + } if (!message.endsWith("\n")) { message += "\n"; } diff --git a/src/main/java/org/perlonjava/frontend/parser/StatementParser.java b/src/main/java/org/perlonjava/frontend/parser/StatementParser.java index aa6c36de51..7bcb00896d 100644 --- a/src/main/java/org/perlonjava/frontend/parser/StatementParser.java +++ b/src/main/java/org/perlonjava/frontend/parser/StatementParser.java @@ -46,6 +46,21 @@ * use declarations, and package declarations. */ public class StatementParser { + /** Mark the source-side subtree synthesized into a given block. Backends + * need this provenance to distinguish a legal internal goto from a jump + * which enters the block and skips topicalizer setup. */ + private static void markInsideGiven(Node node) { + if (node == null) return; + node.setAnnotation("insideGivenBlock", true); + if (node instanceof BlockNode block) { for (Node child : block.elements) markInsideGiven(child); return; } + if (node instanceof ListNode list) { for (Node child : list.elements) markInsideGiven(child); return; } + if (node instanceof ArrayLiteralNode array) { for (Node child : array.elements) markInsideGiven(child); return; } + if (node instanceof HashLiteralNode hash) { for (Node child : hash.elements) markInsideGiven(child); return; } + if (node instanceof OperatorNode op) { markInsideGiven(op.operand); return; } + if (node instanceof BinaryOperatorNode binary) { markInsideGiven(binary.left); markInsideGiven(binary.right); return; } + if (node instanceof IfNode conditional) { markInsideGiven(conditional.condition); markInsideGiven(conditional.thenBranch); markInsideGiven(conditional.elseBranch); return; } + if (node instanceof TernaryOperatorNode ternary) { markInsideGiven(ternary.condition); markInsideGiven(ternary.trueExpr); markInsideGiven(ternary.falseExpr); } + } private static Stack cloneBitSetStack(Stack source) { Stack copy = new Stack<>(); for (BitSet flags : source) { @@ -138,7 +153,7 @@ public static Node parseForStatement(Parser parser, String label) { int declIndex = parser.tokenIndex; parser.parsingForLoopVariable = true; TokenUtils.consume(parser, LexerTokenType.IDENTIFIER); - varNode = OperatorParser.parseVariableDeclaration(parser, token.text, declIndex); + varNode = OperatorParser.parseVariableDeclaration(parser, token.text, declIndex, declIndex); parser.parsingForLoopVariable = false; } else if (token.type == LexerTokenType.IDENTIFIER && token.text.equals("CORE") && parser.tokens.get(parser.tokenIndex).text.equals("CORE") @@ -153,7 +168,7 @@ public static Node parseForStatement(Parser parser, String label) { int declIndex = parser.tokenIndex; parser.parsingForLoopVariable = true; TokenUtils.consume(parser, LexerTokenType.IDENTIFIER); - varNode = OperatorParser.parseVariableDeclaration(parser, coreOp.text, declIndex); + varNode = OperatorParser.parseVariableDeclaration(parser, coreOp.text, declIndex, declIndex); parser.parsingForLoopVariable = false; } else { parser.parsingForLoopVariable = true; @@ -175,6 +190,20 @@ public static Node parseForStatement(Parser parser, String label) { varNode = new OperatorNode("\\", operand, parser.tokenIndex); } + validateDeclaredReferenceForeachVariables(parser, varNode); + + // A foreach iterator may be a scalar, an aggregate, or a declared + // reference, but never a typeglob. Parsing `our *name` as a normal + // declaration leaves the later loop-header parser with an unrelated + // syntax error. Perl diagnoses the missing scalar sigil instead. + if (varNode instanceof OperatorNode declaration + && (declaration.operator.equals("my") || declaration.operator.equals("our") + || declaration.operator.equals("state")) + && declaration.operand instanceof OperatorNode target + && target.operator.equals("*")) { + parser.throwCleanError("Missing $ on loop variable"); + } + // If we didn't parse a loop variable, Perl expects the '(' of the for(..) header next. // When something else appears (e.g. a bare identifier), perl5 reports: // Missing $ on loop variable ... @@ -219,6 +248,36 @@ public static Node parseForStatement(Parser parser, String label) { return node; } + /** + * Perl limits foreach iterator declarations to 256 variables when any + * declaration is a declared reference, and permits a declared-reference + * iterator only among the first 24 variables. + */ + private static void validateDeclaredReferenceForeachVariables(Parser parser, Node variable) { + if (!(variable instanceof OperatorNode declaration) + || !(declaration.operator.equals("my") + || declaration.operator.equals("our") + || declaration.operator.equals("state")) + || !(declaration.operand instanceof ListNode variables)) { + return; + } + + int declaredReferenceIndex = -1; + for (int i = 0; i < variables.elements.size(); i++) { + Node item = variables.elements.get(i); + if (item instanceof AbstractNode annotated + && annotated.getBooleanAnnotation("isDeclaredReference")) { + declaredReferenceIndex = i; + if (i >= 24) { + parser.throwCleanError("Cannot use declared reference iterator variables in foreach loop past the 24th variable"); + } + } + } + if (declaredReferenceIndex >= 0 && variables.elements.size() > 256) { + parser.throwCleanError("Cannot use more than 256 iterator variables on a foreach loop if any are declared refs"); + } + } + /** * Helper method to parse a one-argument for loop (foreach-like). */ @@ -445,6 +504,17 @@ public static Node parseTryStatement(Parser parser) { // Parse the catch block TokenUtils.consume(parser, LexerTokenType.IDENTIFIER); // "catch" TokenUtils.consume(parser, LexerTokenType.OPERATOR, "("); + LexerToken catchToken = TokenUtils.peek(parser); + if (catchToken.type == LexerTokenType.IDENTIFIER + && (catchToken.text.equals("my") || catchToken.text.equals("our") + || catchToken.text.equals("state"))) { + var location = parser.ctx.errorUtil.getSourceLocationAccurate(parser.tokenIndex); + String near = "(" + catchToken.text; + String at = " at " + location.fileName() + " line " + location.lineNumber(); + throw new PerlParserException("Can't redeclare catch variable as \"" + + catchToken.text + "\"" + at + ", near \"" + near + "\"\n" + + "syntax error" + at + ", near \"" + near + " \"\n"); + } // Suppress strict vars check for the catch variable — catch ($e) implicitly // declares $e as a lexical variable, similar to my $e. boolean savedParsingDeclaration = parser.parsingDeclaration; @@ -562,6 +632,9 @@ public static Node parseCancelStatement(Parser parser) { */ public static Node parseWhenStatement(Parser parser) { int index = parser.tokenIndex; + if (parser.parsingGivenDepth == 0) { + parser.throwCleanError(index, "Can't \"when\" outside a topicalizer"); + } TokenUtils.consume(parser, LexerTokenType.IDENTIFIER); // "when" // Parse the when condition (can be parenthesized or not) @@ -596,6 +669,11 @@ public static Node parseWhenStatement(Parser parser) { if (whenResult == null) { whenResult = new OperatorNode("undef", new ListNode(index), index); } + // The final expression is moved to the synthetic last annotation and + // is therefore no longer reachable from the enclosing given block by + // ordinary tree traversal. Preserve its lexical provenance for goto + // entry validation in the backends. + whenResult.setAnnotation("insideGivenBlock", true); OperatorNode implicitLast = new OperatorNode("last", new ListNode(index), index); implicitLast.setAnnotation("implicitGivenLast", true); // Store the value out-of-band so generic visitors never mistake it for @@ -661,6 +739,10 @@ private static boolean whenIsBoolean(Node node) { * @return A BlockNode representing the default block */ public static Node parseDefaultStatement(Parser parser) { + int index = parser.tokenIndex; + if (parser.parsingGivenDepth == 0) { + parser.throwCleanError(index, "Can't \"default\" outside a topicalizer"); + } TokenUtils.consume(parser, LexerTokenType.IDENTIFIER); // "default" // Parse the default block @@ -701,7 +783,13 @@ public static Node parseGivenStatement(Parser parser) { // Parse the entire block content as a normal block // This handles regular statements as well as when/default - BlockNode blockContent = ParseBlock.parseBlock(parser); + parser.parsingGivenDepth++; + BlockNode blockContent; + try { + blockContent = ParseBlock.parseBlock(parser); + } finally { + parser.parsingGivenDepth--; + } TokenUtils.consume(parser, LexerTokenType.OPERATOR, "}"); @@ -723,9 +811,11 @@ public static Node parseGivenStatement(Parser parser) { index)); // Add all the statements from the block + markInsideGiven(blockContent); statements.addAll(blockContent.elements); BlockNode givenBlock = new BlockNode(statements, index, parser); + givenBlock.setAnnotation("givenBlock", true); // Mark as a loop block so that the implicit `last` emitted by each // when-clause breaks out of this given-block instead of escaping // to an outer loop or the program top level. @@ -825,6 +915,7 @@ public static Node parseUseDeclaration(Parser parser, LexerToken token) { Configuration.getPerlVersionVString(), versionScalar, "Perl"); + rejectRepeatedUseVersion(parser, versionScalar); } if (!isNoDeclaration) { @@ -1146,6 +1237,33 @@ public static Node parseUseDeclaration(Parser parser, LexerToken token) { return result; } + private static void rejectRepeatedUseVersion(Parser parser, RuntimeScalar version) { + String requested = normalizeVersion(version); + String previous = parser.ctx.symbolTable.getUseVersion(); + if (previous != null) { + String message; + if (versionAtLeast(requested, 5, 39)) { + message = "use VERSION of 5.39 or above is not permitted while another use VERSION is in scope"; + } else if (versionAtLeast(previous, 5, 39)) { + message = "use VERSION is not permitted while another use VERSION of 5.39 or above is in scope"; + } else if (versionAtLeast(previous, 5, 11) && !versionAtLeast(requested, 5, 11)) { + message = "Downgrading a use VERSION declaration to below v5.11 is not permitted"; + } else { + message = "Changing use VERSION while another use VERSION is in scope is not permitted"; + } + var loc = parser.ctx.errorUtil.getSourceLocationAccurate(parser.tokenIndex); + throw new PerlParserException(message + " at " + loc.fileName() + " line " + loc.lineNumber() + "."); + } + parser.ctx.symbolTable.setUseVersion(requested); + } + + private static boolean versionAtLeast(String version, int major, int minor) { + String[] parts = version.split("\\."); + int actualMajor = Integer.parseInt(parts[0]); + int actualMinor = parts.length > 1 ? Integer.parseInt(parts[1]) : 0; + return actualMajor > major || (actualMajor == major && actualMinor >= minor); + } + /** * Parses a package declaration. * @@ -1185,6 +1303,23 @@ public static Node parsePackageDeclaration(Parser parser, LexerToken token) { // Register this as a Perl 5.38+ class for proper stringification if (isClass) { + if (GlobalVariable.existsGlobalArray(packageName + "::ISA") + && !GlobalVariable.getGlobalArray(packageName + "::ISA").elements.isEmpty()) { + throw PerlCompilerException.withSourceLocation(parser.tokenIndex, + "Cannot create class " + packageName + " as it already has a non-empty @ISA", + parser.ctx.errorUtil); + } + if (ClassRegistry.isClass(packageName)) { + // An eval may catch an incomplete class body's parse error before + // this declaration parser can roll back the provisional registry + // entry. Such a class never finished method registration, so it + // has no constructor and may be replaced by a complete class. + if (GlobalVariable.existsGlobalCodeRef(packageName + "::new")) { + throw PerlCompilerException.withSourceLocation(parser.tokenIndex, + "Cannot reopen existing class \"" + packageName + "\"", parser.ctx.errorUtil); + } + ClassRegistry.unregisterClass(packageName); + } ClassRegistry.registerClass(packageName); } @@ -1216,10 +1351,21 @@ public static Node parsePackageDeclaration(Parser parser, LexerToken token) { // Parse class attributes (e.g., :isa(ParentClass)) if (isClass) { - parseClassAttributes(parser, packageNode); + parseClassAttributes(parser, packageNode, packageName); } - BlockNode block = parseOptionalPackageBlock(parser, nameNode, packageNode); + BlockNode block; + try { + block = parseOptionalPackageBlock(parser, nameNode, packageNode); + } catch (PerlCompilerException error) { + // A class must be visible while its body is parsed so direct method + // calls receive class semantics. Do not leave that provisional + // registration behind if an incomplete class body fails to parse. + if (isClass) { + ClassRegistry.unregisterClass(packageName); + } + throw error; + } if (block != null) return block; StatementResolver.parseStatementTerminator(parser); @@ -1244,7 +1390,7 @@ public static Node parsePackageDeclaration(Parser parser, LexerToken token) { if (deferredMethods != null) { for (SubroutineNode method : deferredMethods) { SubroutineParser.handleNamedSubWithFilter(parser, method.name, method.prototype, - method.attributes, (BlockNode) method.block, false, null); + method.attributes, (BlockNode) method.block, false, "method"); } } @@ -1280,7 +1426,7 @@ public static Node parsePackageDeclaration(Parser parser, LexerToken token) { * @param parser The Parser instance * @param packageNode The OperatorNode representing the class declaration */ - private static void parseClassAttributes(Parser parser, OperatorNode packageNode) { + private static void parseClassAttributes(Parser parser, OperatorNode packageNode, String className) { LexerToken token = TokenUtils.peek(parser); // Check for :isa attribute @@ -1317,6 +1463,22 @@ private static void parseClassAttributes(Parser parser, OperatorNode packageNode // Store parent class in annotations packageNode.setAnnotation("parentClass", parentClass); + // A class declared as a nested package loads its enclosing + // class before validating :isa. Perl does this while loading + // `A/B.pm` for `class A::B :isa(A)`, so A need not have been + // explicitly used by the child module. + if (!ClassRegistry.isClass(parentClass) + && className.startsWith(parentClass + "::")) { + ModuleOperators.require(new RuntimeScalar( + NameNormalizer.moduleToFilename(parentClass))); + } + + if (!ClassRegistry.isClass(parentClass)) { + throw PerlCompilerException.withSourceLocation(packageNode.getIndex(), + "Class :isa attribute requires a class but \"" + parentClass + "\" is not one", + parser.ctx.errorUtil); + } + // Register in FieldRegistry for field inheritance tracking // We'll register this after we know the class name @@ -1403,8 +1565,10 @@ public static BlockNode parseOptionalPackageBlock(Parser parser, IdentifierNode // Set flag if we're entering a class block boolean wasInClassBlock = parser.isInClassBlock; + String previousClassName = parser.currentClassName; if (isClass) { parser.isInClassBlock = true; + parser.currentClassName = nameNode.name; } BlockNode block; @@ -1425,6 +1589,7 @@ public static BlockNode parseOptionalPackageBlock(Parser parser, IdentifierNode } finally { // Always restore the isInClassBlock flag parser.isInClassBlock = wasInClassBlock; + parser.currentClassName = previousClassName; } // Mark as scoped so BytecodeCompiler emits PUSH_PACKAGE (not SET_PACKAGE) @@ -1467,7 +1632,7 @@ public static BlockNode parseOptionalPackageBlock(Parser parser, IdentifierNode if (deferredMethods != null) { for (SubroutineNode method : deferredMethods) { SubroutineParser.handleNamedSubWithFilter(parser, method.name, method.prototype, - method.attributes, (BlockNode) method.block, false, null); + method.attributes, (BlockNode) method.block, false, "method"); } } diff --git a/src/main/java/org/perlonjava/frontend/parser/StatementResolver.java b/src/main/java/org/perlonjava/frontend/parser/StatementResolver.java index bd5f9eb822..3fa7491c73 100644 --- a/src/main/java/org/perlonjava/frontend/parser/StatementResolver.java +++ b/src/main/java/org/perlonjava/frontend/parser/StatementResolver.java @@ -48,7 +48,7 @@ public class StatementResolver { "skip", "warning_like", "warning_is", "warnings_like"); private static final Set CORE_QUALIFIED_CONTROL_STATEMENTS = Set.of( - "if", "unless", "for", "foreach", "while", "until"); + "if", "unless", "for", "foreach", "while", "until", "given"); /** * Parses a single statement from the parser's token stream. @@ -61,6 +61,7 @@ public static Node parseStatement(Parser parser, String label) { parser.validateRemainingByteSourceUtf8(); int currentIndex = parser.tokenIndex; LexerToken token = peek(parser); + boolean coreQualifiedControl = false; // Perl permits control-flow keywords to be explicitly qualified, e.g. // CORE::for (...) { ... }. ParsePrimary handles CORE:: function-style @@ -72,6 +73,7 @@ public static Node parseStatement(Parser parser, String label) { LexerToken coreKeyword = parser.tokens.get(parser.tokenIndex + 2); if (coreKeyword.type == LexerTokenType.IDENTIFIER && CORE_QUALIFIED_CONTROL_STATEMENTS.contains(coreKeyword.text)) { + coreQualifiedControl = true; consume(parser, LexerTokenType.IDENTIFIER); // CORE consume(parser, LexerTokenType.OPERATOR, "::"); currentIndex = parser.tokenIndex; @@ -92,6 +94,14 @@ public static Node parseStatement(Parser parser, String label) { parser.tokenIndex = currentIndex; yield SpecialBlockParser.parseSpecialBlock(parser); } + // A diamond after a special block name is parsed as an + // attempted declaration, not an ordinary subroutine call. + // Preserve Perl's dedicated diagnostic instead of allowing + // the diamond parser to report a generic syntax error. + if (!"ADJUST".equals(token.text) && peek(parser).text.equals("<")) { + parser.throwCleanError(currentIndex, + "Illegal declaration of subroutine " + token.text); + } // Not a special block, backtrack parser.tokenIndex = currentIndex; yield null; @@ -114,7 +124,7 @@ public static Node parseStatement(Parser parser, String label) { case "while", "until" -> StatementParser.parseWhileStatement(parser, label); - case "given" -> parser.ctx.symbolTable.isFeatureCategoryEnabled("switch") + case "given" -> (coreQualifiedControl || parser.ctx.symbolTable.isFeatureCategoryEnabled("switch")) ? StatementParser.parseGivenStatement(parser) : null; @@ -372,10 +382,39 @@ && nextNonWhitespaceTokenIs(parser, parser.tokenIndex + 1, "sub")) { consume(parser); // consume "sub" LexerToken nameToken = peek(parser); + // A lexical/package-qualified declaration without a + // name is distinct from an anonymous sub expression. + // Preserve Perl's declaration-specific diagnostic for + // `my sub;`, `our sub;`, and `state sub;`. + if (nameToken.text.equals(";") || nameToken.type == LexerTokenType.EOF) { + parser.throwCleanError("Missing name in \"" + declaration + " sub\""); + } + if (nameToken.type == LexerTokenType.IDENTIFIER) { String subName = consume(parser).text; int subNameIndex = parser.tokenIndex - 1; // Save the token index of the sub name + int qualifiedStart = Whitespace.skipWhitespace(parser, parser.tokenIndex, parser.tokens); + if (qualifiedStart < parser.tokens.size() + && parser.tokens.get(qualifiedStart).text.equals("::")) { + int end = qualifiedStart; + StringBuilder qualified = new StringBuilder(subName); + while (end + 1 < parser.tokens.size() + && parser.tokens.get(end).text.equals("::") + && parser.tokens.get(end + 1).type == LexerTokenType.IDENTIFIER) { + qualified.append("::").append(parser.tokens.get(end + 1).text); + end += 2; + } + var location = parser.ctx.errorUtil.getSourceLocationAccurate(subNameIndex); + String diagnostic = declaration.equals("our") + ? "No package name allowed for subroutine &" + qualified + " in \"our\"" + : "\"" + declaration + "\" subroutine &" + qualified + + " can't be in a package"; + parser.deferDiagnostic(diagnostic + " at " + location.fileName() + + " line " + location.lineNumber() + ", near \"" + + declaration + " sub " + qualified + "\"\n"); + } + if (declaration.equals("our")) { // our sub works like our var - it creates a package sub AND a lexical alias // The lexical alias stores the fully qualified name so it always resolves @@ -870,6 +909,10 @@ && nextNonWhitespaceTokenIs(parser, parser.tokenIndex + 1, "sub")) { || nextToken.text.equals("'") || nextToken.text.equals("::")) { // Accept legacy package separator ' and leading :: like sub names + if (nextToken.text.equals("'") + && !parser.ctx.symbolTable.isFeatureCategoryEnabled("apostrophe_as_package_separator")) { + throwDisabledLeadingApostropheFormatError(parser); + } formatName = IdentifierParser.parseSubroutineIdentifier(parser); } @@ -1672,4 +1715,34 @@ private static Node handleStatementModifierWithMy(Node expression, Node modifier // No 'my' declaration, use simple short-circuit return new BinaryOperatorNode(operator, modifierExpression, expression, tokenIndex); } + + /** Report Perl's recovery diagnostic for a disabled apostrophe format name. */ + private static void throwDisabledLeadingApostropheFormatError(Parser parser) { + int quoteIndex = parser.tokenIndex; + int lineStart = quoteIndex; + while (lineStart < parser.tokens.size() && parser.tokens.get(lineStart).type != LexerTokenType.NEWLINE) { + lineStart++; + } + if (lineStart >= parser.tokens.size()) { + return; + } + lineStart = Whitespace.skipWhitespace(parser, lineStart + 1, parser.tokens); + int end = lineStart; + while (end < parser.tokens.size() && !parser.tokens.get(end).text.equals("'")) { + end++; + } + if (end >= parser.tokens.size()) { + return; + } + StringBuilder near = new StringBuilder(); + for (int i = lineStart; i <= end; i++) { + near.append(parser.tokens.get(i).text); + } + var location = parser.ctx.errorUtil.getSourceLocationAccurate(lineStart); + var start = parser.ctx.errorUtil.getSourceLocationAccurate(quoteIndex); + String message = "syntax error at " + location.fileName() + " line " + location.lineNumber() + + ", near \"" + near + "\"\n" + + " (Might be a runaway multi-line '' string starting on line " + start.lineNumber() + ")\n"; + throw new PerlCompilerException(message); + } } diff --git a/src/main/java/org/perlonjava/frontend/parser/StringParser.java b/src/main/java/org/perlonjava/frontend/parser/StringParser.java index 1ae643c8e5..831ae9516c 100644 --- a/src/main/java/org/perlonjava/frontend/parser/StringParser.java +++ b/src/main/java/org/perlonjava/frontend/parser/StringParser.java @@ -15,8 +15,14 @@ import org.perlonjava.runtime.NamedCharacterExpansionMap; import org.perlonjava.runtime.runtimetypes.PerlCompilerException; import org.perlonjava.runtime.runtimetypes.GlobalVariable; +import org.perlonjava.runtime.runtimetypes.GlobalContext; +import org.perlonjava.runtime.runtimetypes.RuntimeHash; +import org.perlonjava.runtime.runtimetypes.RuntimeArray; import org.perlonjava.runtime.runtimetypes.RuntimeScalar; import org.perlonjava.runtime.runtimetypes.RuntimeCode; +import org.perlonjava.runtime.runtimetypes.RuntimeContextType; +import org.perlonjava.runtime.runtimetypes.RuntimeScalarType; +import org.perlonjava.runtime.runtimetypes.WarningFlags; import org.perlonjava.runtime.regex.RuntimeRegex; import org.perlonjava.runtime.regex.RegexMarkers; import org.perlonjava.runtime.regex.RegexQuoteMeta; @@ -90,10 +96,12 @@ public class StringParser { */ private static final Map EXTRA_QUOTE_PAIR = Map.of( '\u00ab', '\u00bb', - '\u00bb', '\u00ab' + '\u00bb', '\u00ab', + '\u300a', '\u300b', + '\u300b', '\u300a' ); - private static Character pairedDelimiter(EmitterContext ctx, char delimiter) { + private static Character pairedDelimiter(EmitterContext ctx, char delimiter, int delimiterIndex) { Character builtinPair = QUOTE_PAIR.get(delimiter); if (builtinPair != null) { return builtinPair; @@ -105,13 +113,16 @@ private static Character pairedDelimiter(EmitterContext ctx, char delimiter) { if (ctx.symbolTable.isFeatureCategoryEnabled("extra_paired_delimiters")) { if (ctx.symbolTable.isWarningCategoryEnabled("experimental::extra_paired_delimiters")) { WarnDie.warn(new RuntimeScalar("Use of '" + delimiter + "' is experimental as a string delimiter"), - new RuntimeScalar(ctx.errorUtil.warningLocation(0))); + new RuntimeScalar(ctx.errorUtil.warningLocation(delimiterIndex))); } return extraPair; } - if (ctx.symbolTable.isWarningCategoryEnabled("deprecated::delimiter_will_be_paired")) { + // This compatibility notice is on by default in Perl. A lexical + // `no warnings 'deprecated'` must still suppress it. + if (!WarningFlags.areWarningsForcedOff() + && !ctx.symbolTable.isWarningCategoryDisabled("deprecated::delimiter_will_be_paired")) { WarnDie.warn(new RuntimeScalar("Use of '" + delimiter + "' is deprecated as a string delimiter"), - new RuntimeScalar(ctx.errorUtil.warningLocation(0))); + new RuntimeScalar(ctx.errorUtil.warningLocation(delimiterIndex))); } return null; } @@ -157,15 +168,13 @@ public static ParsedString parseRawStringWithDelimiter(EmitterContext ctx, List< "Can't find string terminator \"" + identifier + "\" anywhere before EOF", ctx.errorUtil); } - boolean extraPairedDelimiter = EXTRA_QUOTE_PAIR.containsKey(startDelim) - || EXTRA_QUOTE_PAIR.containsKey(endDelim); + String delimiterDescription = markerDelimiter != null ? "\".\"" + : endDelim == '"' ? "'\"'" : "\"" + endDelim + "\""; String errorMsg = isRegex ? "Search pattern not terminated" - : "Can't find string terminator " - + (markerDelimiter != null ? "\".\"" - : (extraPairedDelimiter ? "\"" + endDelim + "\"" : endDelim)) + : "Can't find string terminator " + delimiterDescription + " anywhere before EOF"; - throw new PerlCompilerException(tokPos, errorMsg, ctx.errorUtil); + throw PerlCompilerException.withSourceLocation(index, errorMsg, ctx.errorUtil); } // A beyond-Unicode quote delimiter is represented by one internal @@ -250,7 +259,7 @@ public static ParsedString parseRawStringWithDelimiter(EmitterContext ctx, List< case START: startDelim = ch; endDelim = startDelim; - Character pairedDelimiter = pairedDelimiter(ctx, startDelim); + Character pairedDelimiter = pairedDelimiter(ctx, startDelim, tokPos); if (pairedDelimiter != null) { // Check if the delimiter is a pair isPair = true; endDelim = pairedDelimiter; @@ -798,8 +807,24 @@ public static OperatorNode parseRegexMatch(EmitterContext ctx, String operator, literalSyntaxValidated = true; } catch (PerlCompilerException exception) { String message = exception.getMessage(); + if (message != null && message.startsWith("Unknown charname ''") + && literalSyntax.contains("\\N{}") + && literalSource.contains("(?{})")) { + var location = ctx.errorUtil.getSourceLocationAccurate(rawStr.index); + throw new PerlCompilerException("Unknown charname '' at " + + location.fileName() + " line " + location.lineNumber() + + ", near \"{})\"\n"); + } + // The final literal compilation has the source map needed + // to attach Perl's one #line-aware location. Deferring a + // U+ overflow avoids adding this parser pass's physical + // source location before that compilation. + if (shouldDeferRegexDiagnostic(message)) { + literalSyntaxValidated = false; + } else { throw PerlCompilerException.withSourceLocation( rawStr.index, message, ctx.errorUtil); + } } } } @@ -872,6 +897,21 @@ static void captureLexicalNamedCharacterTranslator( } } + /** Whether a regex U+ overflow must be rendered at final compilation. */ + public static boolean isUPlusOverflowRegexDiagnostic(String message) { + return message != null + && message.startsWith("Use of code point 0x") + && message.contains("the permissible max is 0x7FFFFFFFFFFFFFFF") + && message.contains("; marked by <-- HERE in m/"); + } + + /** Diagnostics whose final compilation is responsible for #line-aware location. */ + public static boolean shouldDeferRegexDiagnostic(String message) { + return isUPlusOverflowRegexDiagnostic(message) + || (message != null + && message.startsWith("Too many nested open parens in regex; marked by")); + } + /** Validate a constant regex operand and retain any custom lexical results on its AST. */ public static void validateLiteralNamedCharacters( ListNode operand, String pattern, String modifiers, String diagnosticPattern) { @@ -1074,6 +1114,9 @@ public static OperatorNode parseTransliteration(EmitterContext ctx, ParsedString String replacementList = rawStr.buffers.get(1); String modifiers = rawStr.buffers.get(2); + rejectNamedSequencesInTransliteration(searchList); + rejectNamedSequencesInTransliteration(replacementList); + Node searchNode; Node replacementNode; @@ -1093,8 +1136,11 @@ public static OperatorNode parseTransliteration(EmitterContext ctx, ParsedString rawStr.endDelim, ' ', ' ' ); - // searchNode = StringDoubleQuoted.parseDoubleQuotedString(ctx, searchParsed, true, false); - searchNode = StringDoubleQuoted.parseDoubleQuotedString(ctx, searchParsed, false, false, false); + // Transliteration lists use double-quoted escape rules but do not + // interpolate variables. Preserving every escape here lets an + // invalid \\o reach range compilation instead of reporting Perl's + // braced-octal diagnostic at the source escape. + searchNode = StringDoubleQuoted.parseDoubleQuotedString(ctx, searchParsed, true, false, false); } // Same logic for replacement list @@ -1110,8 +1156,7 @@ public static OperatorNode parseTransliteration(EmitterContext ctx, ParsedString rawStr.secondBufferEndDelim, ' ', ' ' ); - // replacementNode = StringDoubleQuoted.parseDoubleQuotedString(ctx, replaceParsed, true, false); - replacementNode = StringDoubleQuoted.parseDoubleQuotedString(ctx, replaceParsed, false, false, false); + replacementNode = StringDoubleQuoted.parseDoubleQuotedString(ctx, replaceParsed, true, false, false); } Node modifierNode = new StringNode(modifiers, rawStr.index); @@ -1125,6 +1170,22 @@ public static OperatorNode parseTransliteration(EmitterContext ctx, ParsedString return new OperatorNode(operator, list, rawStr.index); } + /** Perl rejects Unicode named sequences in either side of tr/// before + * expanding the double-quoted escape into its multiple code points. */ + private static void rejectNamedSequencesInTransliteration(String list) { + for (int start = list.indexOf("\\N{"); start >= 0; ) { + int nameStart = start + 3; + int end = list.indexOf('}', nameStart); + if (end < 0) return; + String name = list.substring(nameStart, end).trim(); + if (org.perlonjava.runtime.regex.PerlUnicodeNamedSequenceData.isNamedSequence(name)) { + throw new PerlCompilerException("\\N{" + name + + "} must not be a named sequence in transliteration operator"); + } + start = list.indexOf("\\N{", end + 1); + } + } + public static Node parseRawString(Parser parser, String operator) { // handle special quotes for operators: q qq qx qw // s/// m// if (operator.equals("<") || operator.equals("<<") || operator.equals("'") || operator.equals("\"") || operator.equals("/") || operator.equals("//") || operator.equals("/=") @@ -1148,6 +1209,35 @@ public static Node parseRawString(Parser parser, String operator) { rawStr = parseRawStrings(parser, parser.ctx, parser.tokens, parser.tokenIndex, stringParts, isRegex); parser.tokenIndex = rawStr.next; + // A bracket-delimited regex followed by a second closing bracket is + // not an array access after a complete regex. Perl owns the error at + // the complete quote-like construct, including that final bracket. + if (operator.equals("m") && rawStr.startDelim == '[' + && parser.tokenIndex < parser.tokens.size() + && parser.tokens.get(parser.tokenIndex).text.equals("]")) { + var location = parser.ctx.errorUtil.getSourceLocationAccurate(parser.tokenIndex); + String pattern = rawStr.buffers.getFirst(); + String message = "syntax error at " + location.fileName() + " line " + + location.lineNumber() + ", near \"m[" + pattern + "]]\"\n" + + "Execution of " + location.fileName() + " aborted due to compilation errors.\n"; + throw new PerlCompilerException(message); + } + + PerlCompilerException runawayMultilineQuote = runawayMultilineQuoteError(parser, rawStr, operator); + if (runawayMultilineQuote != null) { + throw runawayMultilineQuote; + } + PerlCompilerException runawayMultilineRegex = runawayMultilineRegexDelimiterError(parser, rawStr, operator); + if (runawayMultilineRegex != null) { + throw runawayMultilineRegex; + } + PerlCompilerException malformedAttributeQuote = malformedAttributeQuoteError(parser, rawStr); + if (malformedAttributeQuote != null) { + throw malformedAttributeQuote; + } + rejectClearedConstantHandler(parser, rawStr, operator); + rejectUndefinedStringConstantHandler(parser, rawStr, operator); + switch (operator) { case "`": case "qx": @@ -1160,7 +1250,22 @@ public static Node parseRawString(Parser parser, String operator) { case "/": case "//": case "/=": - return parseRegexMatch(parser.ctx, operator, rawStr, parser); + try { + return parseRegexMatch(parser.ctx, operator, rawStr, parser); + } catch (PerlCompilerException e) { + if (e.getMessage() != null + && e.getMessage().startsWith("Missing right curly or square bracket") + && e.getMessage().contains("at end of line")) { + var location = parser.ctx.errorUtil.getSourceLocationAccurate(rawStr.index); + throw new PerlCompilerException("Missing right curly or square bracket at " + + location.fileName() + " line " + location.lineNumber() + ", within pattern\n" + + "syntax error at " + location.fileName() + " line " + + location.lineNumber() + ", at EOF\n" + + "Execution of " + location.fileName() + + " aborted due to compilation errors.\n"); + } + throw e; + } case "s": return parseRegexReplace(parser.ctx, rawStr, parser); case "\"": @@ -1207,6 +1312,203 @@ public static Node parseRawString(Parser parser, String operator) { return new OperatorNode(operator, list, rawStr.index); } + /** + * When a quote-like delimiter is repeated at the start of the next line, + * Perl treats the following word as evidence of a runaway quote instead of + * continuing with the ordinary missing-operator recovery. + */ + private static PerlCompilerException runawayMultilineQuoteError( + Parser parser, ParsedString rawStr, String operator) { + if (!operator.equals("q") || rawStr.buffers.size() != 1 + || !rawStr.buffers.get(0).equals("\n")) { + return null; + } + int next = rawStr.next; + while (next < parser.tokens.size() + && parser.tokens.get(next).type == LexerTokenType.WHITESPACE) { + next++; + } + if (next >= parser.tokens.size() + || parser.tokens.get(next).type != LexerTokenType.IDENTIFIER) { + return null; + } + + LexerToken trailing = parser.tokens.get(next); + var location = parser.ctx.errorUtil.getSourceLocationAccurate(next); + String delimiter = Character.toString(rawStr.startDelim); + String message = "syntax error at " + location.fileName() + " line " + + location.lineNumber() + ", near \"" + delimiter + " " + trailing.text + "\"\n" + + " (Might be a runaway multi-line " + delimiter + delimiter + + " string starting on line " + rawStr.sourceLine + ")\n"; + return new PerlCompilerException(message); + } + + /** + * Perl diagnoses an unclosed character class that crosses a quote-like + * regex delimiter newline as a runaway delimiter before compiling the + * pattern. Preserve that source-level diagnostic precedence. + */ + private static PerlCompilerException runawayMultilineRegexDelimiterError( + Parser parser, ParsedString rawStr, String operator) { + if (!(operator.equals("m") || operator.equals("qr") || operator.equals("/")) + || rawStr.buffers.isEmpty()) { + return null; + } + String pattern = rawStr.buffers.getFirst(); + int newline = pattern.indexOf('\n'); + int openingBracket = pattern.lastIndexOf('[', newline); + if (newline < 0 || openingBracket < 0 || !hasUnclosedCharacterClass(pattern)) { + return null; + } + + int sourceNewline = rawStr.index; + while (sourceNewline < rawStr.next + && parser.tokens.get(sourceNewline).type != LexerTokenType.NEWLINE) { + sourceNewline++; + } + if (sourceNewline >= rawStr.next) return null; + int afterNewline = sourceNewline + 1; + while (afterNewline < parser.tokens.size() + && parser.tokens.get(afterNewline).type == LexerTokenType.WHITESPACE) { + afterNewline++; + } + if (afterNewline >= parser.tokens.size()) return null; + + var location = parser.ctx.errorUtil.getSourceLocationAccurate(afterNewline); + int previewEnd = Math.min(pattern.length(), newline + 3); + String near = pattern.substring(openingBracket, previewEnd); + String delimiter = Character.toString(rawStr.startDelim); + String message = "syntax error at " + location.fileName() + " line " + + location.lineNumber() + ", near \"" + near + "\"\n" + + " (Might be a runaway multi-line " + delimiter + delimiter + + " string starting on line " + rawStr.sourceLine + ")\n"; + return new PerlCompilerException(message); + } + + private static boolean hasUnclosedCharacterClass(String pattern) { + boolean escaped = false; + boolean inClass = false; + for (int index = 0; index < pattern.length(); index++) { + char ch = pattern.charAt(index); + if (escaped) { + escaped = false; + } else if (ch == '\\') { + escaped = true; + } else if (ch == '[') { + inClass = true; + } else if (ch == ']') { + inClass = false; + } + } + return inClass; + } + + /** + * Perl recovers a quote that crosses an attribute entry and reports the + * later {@code isa => ...} as both a bareword and a runaway-string hint. + * Keep this deliberately scoped to the malformed {@code is => '...\nisa} + * shape so valid multiline strings are unaffected. + */ + private static PerlCompilerException malformedAttributeQuoteError(Parser parser, ParsedString rawStr) { + if (rawStr.startDelim != '\'' && rawStr.startDelim != '"') return null; + int close = rawStr.next - 1; + if (close <= rawStr.index) return null; + + int before = rawStr.index - 1; + while (before >= 0 && parser.tokens.get(before).type == LexerTokenType.WHITESPACE) before--; + if (before < 0 || !parser.tokens.get(before).text.equals("=>")) return null; + before--; + while (before >= 0 && parser.tokens.get(before).type == LexerTokenType.WHITESPACE) before--; + if (before < 0 || !parser.tokens.get(before).text.equals("is")) return null; + + boolean crossedNewline = false; + for (int index = rawStr.index + 1; index < close; index++) { + LexerToken token = parser.tokens.get(index); + if (token.type == LexerTokenType.NEWLINE) crossedNewline = true; + if (!crossedNewline || !token.text.equals("isa")) continue; + int arrow = index + 1; + while (arrow < close && parser.tokens.get(arrow).type == LexerTokenType.WHITESPACE) arrow++; + if (arrow >= close || !parser.tokens.get(arrow).text.equals("=>")) continue; + + var location = parser.ctx.errorUtil.getSourceLocationAccurate(index); + // The lexer has already consumed the closing quoted value here. + // Perl's recovery is deterministic for the two attribute forms: + // a plain single quote reaches Int', while an interpolated double + // quote reaches the package separator before $subpackage. + String near = rawStr.startDelim == '\'' ? "isa => 'Int" : "isa => \"Foo"; + String badName = rawStr.startDelim == '\'' ? "Int'" : "Foo::"; + var start = parser.ctx.errorUtil.getSourceLocationAccurate(rawStr.index); + String message = "Bareword found where operator expected (Do you need to predeclare \"isa\"?) at " + + location.fileName() + " line " + location.lineNumber() + ", near \"" + near + "\"\n" + + " (Might be a runaway multi-line " + rawStr.startDelim + rawStr.startDelim + + " string starting on line " + start.lineNumber() + ")\n" + + "Bad name after " + badName + " at " + location.fileName() + " line " + + location.lineNumber() + ".\n"; + return new PerlCompilerException(message); + } + return null; + } + + /** Preserve Perl's compile-time failure when undef *^H clears a constant hook. */ + private static void rejectClearedConstantHandler(Parser parser, ParsedString rawStr, String operator) { + String installed = switch (operator) { + case "q", "'", "qq", "\"", "tr", "y", "s" -> "q"; + case "m", "qr", "/", "//", "/=" -> "qr"; + default -> null; + }; + if (installed == null || !HintHashRegistry.constantHandlerWasCleared(installed)) return; + boolean tooManyPriorDiagnostics = parser.deferredDiagnosticCount() >= 9; + // Perl reduces this final double-quoted diagnostic before its + // ten-error cap when the cleared q hook follows nine errors. + String kind; + if ((operator.equals("qq") || operator.equals("\"")) + && installed.equals("q") && tooManyPriorDiagnostics) { + kind = "q"; + } else { + kind = switch (operator) { + case "q", "'", "m" -> "q"; + case "tr", "y" -> "tr"; + case "s" -> "s"; + default -> "qq"; + }; + } + var location = parser.ctx.errorUtil.getSourceLocationAccurate(rawStr.index); + String suffix = (operator.equals("q") || operator.equals("'") + || ((operator.equals("qq") || operator.equals("\"")) && kind.equals("q"))) + ? ", near \"" + operator + rawStr.buffers.getFirst() + operator + "\"\n" + : (installed.equals("qr") ? ", within pattern\n" : ", within string\n"); + parser.deferDiagnostic("Constant(" + kind + ") unknown at " + location.fileName() + + " line " + location.lineNumber() + suffix); + } + + /** Apply q constant hooks during parsing, as Perl requires. */ + private static void rejectUndefinedStringConstantHandler(Parser parser, ParsedString rawStr, String operator) { + String kind = switch (operator) { + case "q", "'" -> "q"; + case "qq", "\"" -> "qq"; + case "tr", "y" -> "tr"; + case "s" -> "s"; + default -> null; + }; + if (kind == null) return; + RuntimeHash hints = GlobalVariable.getGlobalHash(GlobalContext.encodeSpecialVar("H")); + RuntimeScalar handler = hints == null ? null : hints.elements.get("q"); + if (handler == null || (handler.type != RuntimeScalarType.CODE + && !(handler.type == RuntimeScalarType.REFERENCE && handler.value instanceof RuntimeScalar ref + && ref.type == RuntimeScalarType.CODE))) return; + RuntimeArray args = new RuntimeArray(); + String value = rawStr.buffers.getFirst(); + args.elements.add(new RuntimeScalar(value)); + args.elements.add(new RuntimeScalar(value)); + args.elements.add(new RuntimeScalar(kind)); + RuntimeScalar result = RuntimeCode.apply(handler, args, RuntimeContextType.SCALAR).scalar(); + if (result.type != RuntimeScalarType.UNDEF) return; + var location = parser.ctx.errorUtil.getSourceLocationAccurate(rawStr.index); + String suffix = (kind.equals("q")) ? ", near \"'" + value + "'\"\n" : ", within string\n"; + parser.deferDiagnostic("Constant(" + kind + "): Call to &{$^H{q}} did not return a defined value at " + + location.fileName() + " line " + location.lineNumber() + suffix); + } + private static RuntimeScalar findGlobOverride(Parser parser) { String currentGlob = normalizeVariableName("glob", parser.ctx.symbolTable.getCurrentPackage()); if (GlobalVariable.existsGlobalCodeRef(currentGlob)) { diff --git a/src/main/java/org/perlonjava/frontend/parser/StringSegmentParser.java b/src/main/java/org/perlonjava/frontend/parser/StringSegmentParser.java index 8c9e880482..ec712e2cff 100644 --- a/src/main/java/org/perlonjava/frontend/parser/StringSegmentParser.java +++ b/src/main/java/org/perlonjava/frontend/parser/StringSegmentParser.java @@ -264,7 +264,8 @@ protected void addStringSegment(Node node) { protected Node prepareStringSegment(Node node) { if (isRegex && node instanceof StringNode stringNode) { return ConstantOverloadParser.wrapRegexSegment( - stringNode, stringNode.value, tokenIndex, + parser, stringNode, stringNode.value, tokenIndex, + interpolateVariable ? "qq" : "q", ctx.symbolTable.isStrictOptionEnabled( org.perlonjava.runtime.perlmodule.Strict.HINT_UTF8) || ctx.compilerOptions.isUnicodeSource); @@ -394,6 +395,14 @@ protected void parseVariableInterpolation(String sigil) { operand = Variable.parseBracedVariable(parser, sigil, true, isRegex ? "pattern" : "string"); } catch (PerlCompilerException e) { + if (e.getMessage().startsWith("Can't find string terminator")) { + PerlCompilerException outerSyntaxError = + malformedNestedQuoteLikeInterpolationError(); + if (outerSyntaxError != null) { + throw outerSyntaxError; + } + throw e; + } // Extract the core error message, removing any existing "Syntax error in braced variable:" prefix String coreMessage = e.getMessage(); if (coreMessage.startsWith("Syntax error in braced variable: ")) { @@ -410,6 +419,27 @@ protected void parseVariableInterpolation(String sigil) { operand = Variable.parseBracedVariable(parser, sigil, true, isRegex ? "pattern" : "string"); } catch (PerlCompilerException e) { + if (e.getMessage().startsWith("Can't find string terminator")) { + PerlCompilerException outerSyntaxError = + malformedNestedQuoteLikeInterpolationError(); + if (outerSyntaxError != null) { + throw outerSyntaxError; + } + throw e; + } + PerlCompilerException malformedRegexError = + malformedNestedRegexInterpolationError(); + if (malformedRegexError != null) { + throw malformedRegexError; + } + // A nested quote-like parser may already have produced + // Perl's complete diagnostic (including its own source + // excerpt and compilation-abort line). Do not turn that + // into a generic braced-variable interpolation error. + if (e.getMessage().contains("\nExecution of ") + && e.getMessage().contains("aborted due to compilation errors.")) { + throw e; + } // Extract the core error message, removing any existing "Syntax error in braced variable:" prefix String coreMessage = e.getMessage(); if (coreMessage.startsWith("Syntax error in braced variable: ")) { @@ -486,6 +516,12 @@ protected void parseVariableInterpolation(String sigil) { } else if (!postfixDerefFollows || postfixDerefInterpolationEnabled) { operand = parseArrayHashAccess(parser, operand, isRegex); } + } catch (PerlCompilerException e) { + // Do not replace a nested parser's primary diagnostic with a + // generic interpolation-access error. In particular, eval + // of a malformed regex in a subscript must retain the regex + // location and excerpt. + throw e; } catch (Exception e) { if (isRegex && e.getMessage() != null && e.getMessage().contains("Unterminated array")) { @@ -1315,6 +1351,57 @@ public void setOriginalStringContent(String content) { this.originalStringContent = content; } + /** + * A quote-like expression in a braced interpolation is parsed using the + * nested string token stream. If that expression chooses a delimiter + * which is never closed, its low-level error has no useful connection to + * the outer source. Perl instead reports a syntax error at the enclosing + * quote, retaining the delimiter pair that makes the malformed expression + * apparent (for example {@code "})"} in {@code qr!@{s{0})(?{!}). + */ + private PerlCompilerException malformedNestedQuoteLikeInterpolationError() { + int interpolation = originalStringContent.indexOf("@{"); + if (interpolation < 0) { + return null; + } + int closingBrace = originalStringContent.indexOf('}', interpolation + 2); + if (closingBrace < 0 || closingBrace + 1 >= originalStringContent.length() + || originalStringContent.charAt(closingBrace + 1) != ')') { + return null; + } + + String excerpt; + if (isRegex) { + excerpt = originalStringContent.substring(closingBrace, closingBrace + 2); + } else if (closingBrace + 2 < originalStringContent.length() + && originalStringContent.charAt(closingBrace + 2) == '(') { + excerpt = originalStringContent.substring(closingBrace + 1, closingBrace + 3); + } else { + return null; + } + + var location = ctx.errorUtil.getSourceLocationAccurate(originalTokenOffset); + return new PerlCompilerException("syntax error at " + location.fileName() + " line " + + location.lineNumber() + ", near \"" + excerpt + "\"\nExecution of " + + location.fileName() + " aborted due to compilation errors.\n"); + } + + /** + * Preserve the useful token excerpt for an unterminated empty regex inside + * a braced interpolation. The nested expression parser otherwise reports + * this as a generic interpolation error after the closing bracket has + * already been consumed. + */ + private PerlCompilerException malformedNestedRegexInterpolationError() { + if (!originalStringContent.contains("//]")) { + return null; + } + + var location = ctx.errorUtil.getSourceLocationAccurate(originalTokenOffset); + return new PerlCompilerException("syntax error at " + location.fileName() + " line " + + location.lineNumber() + ", near \"//]\"\n"); + } + /** * Creates and throws an offset-aware error with correct context. * Matches Perl's actual error format for string interpolation errors. @@ -1627,8 +1714,7 @@ void handleHexEscape() { try { String hs = hexStr.toString(); BigInteger bi = new BigInteger(hs, 16); - long hexUv = - bi.and(BigInteger.ONE.shiftLeft(64).subtract(BigInteger.ONE)).longValue(); + long hexUv = checkedEscapeCodePoint(bi); if (Long.compareUnsigned(hexUv, 0x10FFFFL) > 0) { appendToCurrentSegment(PerlUtfString.encodeBeyondUnicode(hexUv)); } else if (hexUv >= 0xD800L && hexUv <= 0xDFFFL) { @@ -1692,7 +1778,7 @@ void handleOctalEscape() { } if (chr.isEmpty()) { - parser.throwError("Missing right brace on \\o{}"); + throwOctalEscapeDiagnostic("Missing right brace on \\o{}"); } // Skip trailing non-digits @@ -1703,15 +1789,17 @@ void handleOctalEscape() { TokenUtils.consumeChar(parser); } else { - parser.throwError("Missing braces on \\o{}"); + throwOctalEscapeDiagnostic("Missing braces on \\o{}"); } if (!octStr.isEmpty()) { try { - var octValue = Integer.parseInt(octStr.toString(), 8); + long octValue = checkedEscapeCodePoint(new BigInteger(octStr.toString(), 8)); var result = octValue <= 0xFFFF ? String.valueOf((char) octValue) - : new String(Character.toChars(octValue)); + : octValue > 0x10FFFFL + ? PerlUtfString.encodeBeyondUnicode(octValue) + : new String(Character.toChars((int) octValue)); appendToCurrentSegment(result); } catch (NumberFormatException e) { // Invalid hex sequence, treat as literal @@ -1807,8 +1895,16 @@ void handleUnicodeNameEscape() { throwNamedSequenceExtendedClassDiagnostic(expansion.sequence()); } if (!expansion.resolved()) { + String diagnostic = expansion.diagnostic(); + // A U+ value beyond Perl's signed-long ceiling is a + // regex-parser diagnostic: it marks the closing brace + // in the complete pattern. Preserve the raw message + // here so RuntimeRegex can render that source-aware + // form instead of attaching a generic string-parser + // location. appendToCurrentSegment(RegexMarkers.literalDiagnostic( - namedCharacterDiagnostic(expansion.diagnostic()))); + isUPlusOverflowDiagnostic(diagnostic) + ? diagnostic : namedCharacterDiagnostic(diagnostic))); } } appendToCurrentSegment("\\N{" + name + "}"); @@ -1913,8 +2009,41 @@ private String namedCharacterDiagnostic(String diagnostic) { + ", within " + (isRegex ? "pattern" : "string"); } + private boolean isUPlusOverflowDiagnostic(String diagnostic) { + return diagnostic != null + && diagnostic.startsWith("Use of code point 0x") + && diagnostic.contains("the permissible max is 0x7FFFFFFFFFFFFFFF"); + } + + /** + * Perl's braced numeric escapes accept code points through signed IV max, + * including values beyond Unicode. Do not truncate an overlarge value to + * a Java long: that would silently turn an invalid escape into another + * character instead of its required compile-time diagnostic. + */ + private long checkedEscapeCodePoint(BigInteger codePoint) { + if (codePoint.compareTo(BigInteger.valueOf(Long.MAX_VALUE)) > 0) { + var location = ctx.errorUtil.getSourceLocationAccurate(tokenIndex); + throw new PerlParserException("Use of code point 0x" + + codePoint.toString(16).toUpperCase(java.util.Locale.ROOT) + + " is not allowed; the permissible max is 0x7FFFFFFFFFFFFFFF at " + + location.fileName() + " line " + location.lineNumber() + ".\n"); + } + return codePoint.longValueExact(); + } + + /** Render braced-octal syntax failures as quoted-string diagnostics. */ + private void throwOctalEscapeDiagnostic(String diagnostic) { + var location = ctx.errorUtil.getSourceLocationAccurate(tokenIndex); + throw new PerlParserException(diagnostic + " at " + location.fileName() + + " line " + location.lineNumber() + ", within string\n"); + } + private void throwMissingNamedCharacterBraceDiagnostic() { - var location = ctx.errorUtil.getSourceLocationAccurate(parser.tokenIndex); + // The parser cursor has already advanced past the unterminated regex + // delimiter. Attribute this lexical error to the regex source token + // itself, as Perl does for /\\N{/. + var location = ctx.errorUtil.getSourceLocationAccurate(tokenIndex); String message = isRegex ? "Missing right brace on \\N{} or unescaped left brace after \\N" : "Missing right brace on \\N{}"; diff --git a/src/main/java/org/perlonjava/frontend/parser/SubroutineParser.java b/src/main/java/org/perlonjava/frontend/parser/SubroutineParser.java index 9dcdb75485..1cea87a657 100644 --- a/src/main/java/org/perlonjava/frontend/parser/SubroutineParser.java +++ b/src/main/java/org/perlonjava/frontend/parser/SubroutineParser.java @@ -40,6 +40,32 @@ public class SubroutineParser { // Create a static semaphore with 1 permit private static final Semaphore semaphore = new Semaphore(1); + /** + * With apostrophe package separators disabled, a leading quote after + * {@code sub} starts an expression rather than a package component. + */ + private static void throwDisabledLeadingApostropheSubError(Parser parser) { + int quoteIndex = parser.tokenIndex; + int firstNameIndex = quoteIndex + 1; + int closingQuoteIndex = firstNameIndex + 1; + int trailingNameIndex = closingQuoteIndex + 1; + if (trailingNameIndex >= parser.tokens.size() + || parser.tokens.get(firstNameIndex).type != LexerTokenType.IDENTIFIER + || !parser.tokens.get(closingQuoteIndex).text.equals("'") + || parser.tokens.get(trailingNameIndex).type != LexerTokenType.IDENTIFIER) { + return; + } + + var location = parser.ctx.errorUtil.getSourceLocationAccurate(quoteIndex); + String firstName = parser.tokens.get(firstNameIndex).text; + String trailingName = parser.tokens.get(trailingNameIndex).text; + String at = " at " + location.fileName() + " line " + location.lineNumber(); + String message = "Bareword found where operator expected (Missing operator before \"" + + trailingName + "\"?)" + at + ", near \"'" + firstName + "'" + trailingName + "\"\n" + + "Illegal declaration of anonymous subroutine" + at + ", near \"sub '" + firstName + "'\"\n"; + throw new PerlCompilerException(message); + } + /** * Parses a subroutine call. * @@ -492,6 +518,12 @@ && isValidIndirectMethod(sourceSubName, parser) return parseIndirectMethodCall(parser, nameNode); } LexerToken nextTok = peek(parser); + // An unresolved bareword followed by a number is not an + // unparenthesized call. Perl diagnoses the missing infix operator + // before it can become a runtime undefined-subroutine call. + if (nextTok.type == LexerTokenType.NUMBER) { + throwNumberAfterBarewordDiagnostic(parser, sourceSubName, currentIndex, nextTok); + } boolean terminator = nextTok.text.equals(";") || nextTok.text.equals("}") || nextTok.text.equals(")") @@ -617,7 +649,10 @@ && isValidIndirectMethod(sourceSubName, parser) new OperatorNode("&", nameNode, currentIndex), arguments, currentIndex); - return new BinaryOperatorNode("->", invocant, methodCall, currentIndex); + BinaryOperatorNode indirectBlockCall = new BinaryOperatorNode( + "->", invocant, methodCall, currentIndex); + indirectBlockCall.setAnnotation("indirectBlockMethod", true); + return indirectBlockCall; } ListNode arguments = consumeArgsWithPrototype(parser, "@"); @@ -694,6 +729,13 @@ && isValidIndirectMethod(sourceSubName, parser) && !GlobalVariable.isSubs.containsKey(fullName); if (!unshadowedCoreBuiltin) { codeRefNode.setAnnotation("directNamedCall", true); + int separator = fullName.lastIndexOf("::"); + if (separator >= 0 && !"new".equals(subName)) { + String packageName = fullName.substring(0, separator); + if (ClassRegistry.isClass(packageName)) { + codeRefNode.setAnnotation("directClassMethod", packageName); + } + } } if (!isMethod && parseTimeCodeRef == null && !unshadowedCoreBuiltin) { // Perl allocates and pins the call site's GV while parsing an @@ -706,6 +748,19 @@ && isValidIndirectMethod(sourceSubName, parser) parseTimeCodeRef = GlobalVariable.getGlobalCodeRefForFreshLookup(fullName); } if (parseTimeCodeRef != null) { + // The parser's class registry is intentionally compile-time + // state. Preserve the declaring-class identity on this + // call site's CV now, before execution switches to its own + // runtime state. + int separator = fullName.lastIndexOf("::"); + if (separator >= 0 && parseTimeCodeRef.value instanceof RuntimeCode code) { + String packageName = fullName.substring(0, separator); + if (!"new".equals(code.subName) && code.isClassMethod) { + code.isClassMethod = true; + code.declaringClass = packageName; + codeRefNode.setAnnotation("directClassMethod", packageName); + } + } codeRefNode.setAnnotation("parseTimeCodeRef", parseTimeCodeRef); } return new BinaryOperatorNode("(", @@ -718,6 +773,18 @@ && isValidIndirectMethod(sourceSubName, parser) } } + private static void throwNumberAfterBarewordDiagnostic(Parser parser, String subName, + int subNameIndex, LexerToken number) { + ErrorMessageUtil.SourceLocation location = + parser.ctx.errorUtil.getSourceLocationAccurate(subNameIndex); + String near = subName + " " + number.text; + String at = " at " + location.fileName() + " line " + location.lineNumber() + + ", near \"" + near + "\"\n"; + throw new PerlParserException( + "Number found where operator expected (Do you need to predeclare \"" + + subName + "\"?)" + at + "syntax error" + at); + } + private static boolean isValidIndirectMethod(String subName) { return isValidIndirectMethod(subName, null); } @@ -814,6 +881,11 @@ public static Node parseSubroutineDefinition( // (e.g., namespaced, fully qualified names). It may return null if no valid name is found. subName = IdentifierParser.parseSubroutineIdentifier(parser); + if (subName == null && peek(parser).text.equals("'") + && !parser.ctx.symbolTable.isFeatureCategoryEnabled("apostrophe_as_package_separator")) { + throwDisabledLeadingApostropheSubError(parser); + } + // Mark named subroutines as non-packages in packageExistsCache immediately // This helps indirect object detection distinguish subs from packages. // IMPORTANT: Use the fully qualified name so that `sub error` in Template::Base @@ -930,7 +1002,17 @@ public static Node parseSubroutineDefinition( // If the signatures feature is not enabled, we just parse the prototype as a string. // If a prototype exists, we parse it using 'parseRawString' method which handles it like the 'q()' operator. // This means it will take everything inside the parentheses as a literal string. - prototype = ((StringNode) StringParser.parseRawString(parser, "q")).value; + int prototypeStartIndex = parser.tokenIndex; + try { + prototype = ((StringNode) StringParser.parseRawString(parser, "q")).value; + } catch (PerlCompilerException e) { + if (e.getMessage() != null && e.getMessage().contains("Can't find string terminator")) { + var location = parser.ctx.errorUtil.getSourceLocationAccurate(prototypeStartIndex); + throw new PerlParserException("Prototype not terminated at " + location.fileName() + + " line " + location.lineNumber() + ".\n"); + } + throw e; + } // Validate prototype - certain characters are not allowed if (prototype.contains("<>") || prototype.contains("__FILE__")) { @@ -1658,7 +1740,8 @@ public static ListNode handleNamedSubWithFilter(Parser parser, String subName, S // Emit "Prototype mismatch" and "Subroutine redefined" warnings // Skip warnings for Java-registered (XS-like) built-in methods being overridden by Perl stubs - if (isRedefinition && block != null && !isBuiltinSub) { + if (isRedefinition && block != null && !isBuiltinSub + && !block.getBooleanAnnotation("generatedClassConstructor")) { String location = ""; if (parser.ctx.errorUtil != null) { int line = parser.ctx.errorUtil.getLineNumber(parser.tokenIndex); @@ -1748,6 +1831,13 @@ public static ListNode handleNamedSubWithFilter(Parser parser, String subName, S placeholder.packageName = lastSep >= 0 ? fullName.substring(0, lastSep) : parser.ctx.symbolTable.getCurrentPackage(); + placeholder.isClassMethod = "method".equals(declaration) + || (block != null && block.getBooleanAnnotation("isClassMethod")); + placeholder.declaringClass = placeholder.isClassMethod ? placeholder.packageName : null; + placeholder.generatedClassConstructor = block != null + && block.getBooleanAnnotation("generatedClassConstructor"); + placeholder.classAdjustBlock = block != null + && block.getBooleanAnnotation("classAdjustBlock"); placeholder.isConstantCv = isConstantCvBody(prototype, block); // Compile-time attribute handlers can inspect the still-lazy CV with @@ -2167,6 +2257,10 @@ && isLexicalSubStorageReferenced(explicitlyUsedVars, entry.name()) interpretedCode.attributes = placeholder.attributes; interpretedCode.subName = placeholder.subName; interpretedCode.packageName = placeholder.packageName; + interpretedCode.isClassMethod = placeholder.isClassMethod; + interpretedCode.declaringClass = placeholder.declaringClass; + interpretedCode.generatedClassConstructor = placeholder.generatedClassConstructor; + interpretedCode.classAdjustBlock = placeholder.classAdjustBlock; interpretedCode.lexicalVariableNames = placeholder.lexicalVariableNames; interpretedCode.ourVariableRegistry = placeholder.ourVariableRegistry; interpretedCode.lexicalAliases = placeholder.lexicalAliases; @@ -2213,6 +2307,10 @@ && isLexicalSubStorageReferenced(explicitlyUsedVars, entry.name()) interpretedCode.attributes = placeholder.attributes; interpretedCode.subName = placeholder.subName; interpretedCode.packageName = placeholder.packageName; + interpretedCode.isClassMethod = placeholder.isClassMethod; + interpretedCode.declaringClass = placeholder.declaringClass; + interpretedCode.generatedClassConstructor = placeholder.generatedClassConstructor; + interpretedCode.classAdjustBlock = placeholder.classAdjustBlock; interpretedCode.lexicalVariableNames = placeholder.lexicalVariableNames; interpretedCode.ourVariableRegistry = placeholder.ourVariableRegistry; interpretedCode.lexicalAliases = placeholder.lexicalAliases; diff --git a/src/main/java/org/perlonjava/frontend/parser/Variable.java b/src/main/java/org/perlonjava/frontend/parser/Variable.java index d42679f9cd..dd43c58c95 100644 --- a/src/main/java/org/perlonjava/frontend/parser/Variable.java +++ b/src/main/java/org/perlonjava/frontend/parser/Variable.java @@ -239,6 +239,33 @@ && peek(parser).text.equals("(") && !sigil.equals("&") String localVar = sigil + varName; + // Fields are lexically visible while their class body is parsed, + // including within nested class declarations. They are not, + // however, ordinary lexicals: Perl permits them only in methods, + // ADJUST blocks, and field initializers of their own class (or a + // subclass). Diagnose an attempted use before ordinary strict + // variable handling can turn it into a package global. + SymbolTable.SymbolEntry fieldEntry = parser.ctx.symbolTable.getSymbolEntry("field:" + varName); + SymbolTable.SymbolEntry variableEntry = parser.ctx.symbolTable.getSymbolEntry(localVar); + boolean isUnshadowedField = fieldEntry != null + && "field".equals(fieldEntry.decl()) + && (variableEntry == null || "field".equals(variableEntry.decl())); + if (isUnshadowedField) { + String fieldOwner = fieldEntry.perlPackage(); + String currentClass = parser.ctx.symbolTable.getCurrentPackage(); + if (!parser.isInMethod) { + throw PerlCompilerException.withSourceLocation(startIndex, + "Field " + sigil + varName + " is not accessible outside a method", + parser.ctx.errorUtil); + } + if (!FieldRegistry.isClassOrAncestor(currentClass, fieldOwner)) { + throw PerlCompilerException.withSourceLocation(startIndex, + "Field " + sigil + varName + " of \"" + fieldOwner + + "\" is not accessible in a method of \"" + currentClass + "\"", + parser.ctx.errorUtil); + } + } + // Check if this is a field (in current or parent class) and not a locally declared variable // Note: We check if the variable is NOT defined locally (only in current scope) // but we DO check for fields in all scopes (fields are in parent scope) @@ -273,9 +300,11 @@ && isFieldInClassHierarchy(parser, varName) } } - // Check strict vars at parse time — catches undeclared variables in - // lazily-compiled named sub bodies that would otherwise be missed - checkStrictVarsAtParseTime(parser, sigil, varName); + // Diagnose undeclared strict variables while parsing. This must + // also cover file-level code: a later syntax error prevents code + // generation, which otherwise hides Perl's earlier strict-vars + // diagnostic. + checkStrictVarsAtParseTime(parser, sigil, varName, false); SymbolTable.SymbolEntry lexicalExport = getLexicalExportEntry(parser, sigil, varName); if (lexicalExport != null) { @@ -378,9 +407,9 @@ private static void checkStrictVarsAtParseTime( // compile time for them. All other contexts (file-level, anonymous // subs, eval STRING) are handled correctly by the code-generation check. if (lazySubroutinesOnly) { - if (!parser.ctx.symbolTable.isInSubroutineBody()) return; + if (!parser.ctx.symbolTable.isInSubroutineBody() && !parser.isInFieldInitializer) return; String currentSub = parser.ctx.symbolTable.getCurrentSubroutine(); - if (currentSub == null || currentSub.isEmpty()) return; + if (!parser.isInFieldInitializer && (currentSub == null || currentSub.isEmpty())) return; } // Check if strict vars is enabled in the current scope @@ -405,8 +434,15 @@ private static void checkStrictVarsAtParseTime( // Qualified names (Pkg::var) — always allowed if (varName.contains("::")) return; - // Regex capture variables ($1, $2, ...) but not $01, $02 - if (ScalarUtils.isInteger(varName) && !varName.startsWith("0")) return; + // Numeric array/hash names and regex capture variables ($1, $2, ...) + // are exempt from strict vars. In particular, @0 is valid as the + // indirect-method argument in `E { 0; readline @0 }`. + if (ScalarUtils.isInteger(varName) + && (!sigil.equals("$") || !varName.startsWith("0"))) return; + + // A malformed sigil sequence has its own parser diagnostic; do not + // replace it with a strict-vars error while recovering the statement. + if (varName.startsWith("$") || varName.startsWith("@") || varName.startsWith("%")) return; // Sort variables $a and $b if (sigil.equals("$") && (varName.equals("a") || varName.equals("b"))) return; @@ -490,12 +526,22 @@ private static void checkStrictVarsAtParseTime( if (existsGlobally) return; - // Undeclared variable under strict vars - throw new PerlCompilerException(parser.tokenIndex, - "Global symbol \"" + sigil + varName - + "\" requires explicit package name (did you forget to declare \"my " - + sigil + varName + "\"?)", - parser.ctx.errorUtil); + // File-level parsing must continue after a strict-vars failure: Perl + // reports subsequent recoverable syntax diagnostics in the same + // compilation unit. Lazy named subroutine bodies still need the + // immediate failure that prevents delayed compilation from hiding it. + String message = "Global symbol \"" + sigil + varName + + "\" requires explicit package name (did you forget to declare \"my " + + sigil + varName + "\"?)"; + if (!lazySubroutinesOnly) { + ErrorMessageUtil.SourceLocation location = parser.ctx.errorUtil + .getSourceLocationAccurate(parser.tokenIndex); + parser.deferDiagnostic(message + " at " + location.fileName() + + " line " + location.lineNumber() + ".\n"); + return; + } + throw PerlCompilerException.withSourceLocation( + parser.tokenIndex, message, parser.ctx.errorUtil); } /** @@ -586,6 +632,12 @@ static Node parseArrayHashAccessInBraces(Parser parser, Node operand, boolean is return operand; } } + } catch (PerlCompilerException e) { + // Preserve the primary parser diagnostic (for example a + // malformed regex within a subscript expression). Wrapping + // it here loses both its source ownership and useful near + // excerpt. + throw e; } catch (Exception e) { // If parsing fails, throw a more informative error throw new PerlCompilerException(parser.tokenIndex, "syntax error: Unterminated array or hash access", parser.ctx.errorUtil); @@ -691,6 +743,8 @@ static Node parseArrayHashAccess(Parser parser, Node operand, boolean isRegex) { Node result = null; try { result = ParseInfix.parseInfixOperation(parser, operand, 0); + } catch (PerlCompilerException e) { + throw e; } catch (Exception e) { parser.tokenIndex = savedIndex; throw new PerlCompilerException(parser.tokenIndex, "syntax error: Unterminated array access", parser.ctx.errorUtil); @@ -1044,6 +1098,19 @@ public static Node parseBracedVariable(Parser parser, String sigil, int startLineNumber = parser.ctx.errorUtil.getLineNumber(parser.tokenIndex - 1); // Save line number before peek() side effects TokenUtils.consume(parser); // Consume the '{' + // `$#` and `$*` stopped being special variables in Perl 5.30. The + // unbraced forms are rejected by ParsePrimary/parseVariable, but the + // braced spelling used to bypass that check. In particular `${#}` + // fell through into the generic braced-expression parser and could + // run past EOF. Keep the check here, before interpreting the brace + // contents as either a symbolic variable name or an expression. + if ("$".equals(sigil) && isRemovedPunctuationVariable(parser, "#")) { + parser.throwCleanError("$# is no longer supported as of Perl 5.30"); + } + if ("$".equals(sigil) && isRemovedPunctuationVariable(parser, "*")) { + parser.throwCleanError("$* is no longer supported as of Perl 5.30"); + } + // Files with malformed UTF-8 are represented byte-for-byte until a // parser context consumes them. A raw non-ASCII byte cannot start a // name inside a braced aggregate dereference such as @{\xD7}; reject @@ -1270,22 +1337,24 @@ public static Node parseBracedVariable(Parser parser, String sigil, // Check for heredoc constructs like ${<} where $< is a special variable if (parser.tokenIndex < parser.tokens.size()) { + int heredocTokenIndex = parser.tokenIndex; var currentToken = parser.tokens.get(parser.tokenIndex); if (currentToken.text.equals("<")) { - // Look ahead to see if this is < (angle brackets) - if (parser.tokenIndex + 1 < parser.tokens.size()) { - var nextToken = parser.tokens.get(parser.tokenIndex + 1); - // If the next token after < is an identifier (not another <), this could be < 0 && parser.baseSourceFileName != null) { + throw new PerlCompilerException(message + " at " + parser.baseSourceFileName + + " line " + parser.sourceLineAt(heredocTokenIndex) + ".\n"); + } + throw PerlCompilerException.withSourceLocation( + heredocTokenIndex, message, parser.ctx.errorUtil); } TokenUtils.consume(parser, LexerTokenType.OPERATOR, "}"); @@ -1384,6 +1460,52 @@ public static Node parseBracedVariable(Parser parser, String sigil, } } + /** + * True when the just-opened braced scalar contains one of the removed + * punctuation variables, either directly (`${#}`) or as its symbolic + * quoted name (`${"#"}`). Do not match a general expression: these + * spellings are deliberately restricted to a single punctuation token. + */ + private static boolean isRemovedPunctuationVariable(Parser parser, String punctuation) { + // Do not use Whitespace.skipWhitespace here: it treats `#` as the + // beginning of a source comment, which is exactly the punctuation we + // need to recognize in `${#}`. + int index = skipLiteralWhitespace(parser, parser.tokenIndex); + if (index >= parser.tokens.size()) { + return false; + } + if (punctuation.equals(parser.tokens.get(index).text)) { + index = skipLiteralWhitespace(parser, index + 1); + return index < parser.tokens.size() && "}".equals(parser.tokens.get(index).text); + } + + String quote = parser.tokens.get(index).text; + if (!"'".equals(quote) && !"\"".equals(quote)) { + return false; + } + int valueIndex = index + 1; + if (valueIndex >= parser.tokens.size() || !punctuation.equals(parser.tokens.get(valueIndex).text)) { + return false; + } + int closeQuoteIndex = valueIndex + 1; + if (closeQuoteIndex >= parser.tokens.size() || !quote.equals(parser.tokens.get(closeQuoteIndex).text)) { + return false; + } + int closeBraceIndex = skipLiteralWhitespace(parser, closeQuoteIndex + 1); + return closeBraceIndex < parser.tokens.size() && "}".equals(parser.tokens.get(closeBraceIndex).text); + } + + private static int skipLiteralWhitespace(Parser parser, int index) { + while (index < parser.tokens.size()) { + LexerTokenType type = parser.tokens.get(index).type; + if (type != LexerTokenType.WHITESPACE && type != LexerTokenType.NEWLINE) { + break; + } + index++; + } + return index; + } + private static boolean hasMalformedBracedInterpolation(Parser parser, int start) { for (int i = start + 1; i + 1 < parser.tokens.size(); i++) { if (parser.tokens.get(i).type == LexerTokenType.EOF) { diff --git a/src/main/java/org/perlonjava/frontend/semantic/ScopedSymbolTable.java b/src/main/java/org/perlonjava/frontend/semantic/ScopedSymbolTable.java index 5b18fe7bb3..beb5aa299e 100644 --- a/src/main/java/org/perlonjava/frontend/semantic/ScopedSymbolTable.java +++ b/src/main/java/org/perlonjava/frontend/semantic/ScopedSymbolTable.java @@ -114,6 +114,9 @@ public void inheritAllWarningsForRegisteredCategory(String category) { // execute ownership without baking a particular engine's bit layout into // the AST. private final Stack regexDebugFlagsStack = new Stack<>(); + // `use VERSION` is lexical: a second declaration in the same scope is + // rejected, while an inner block gets its own declaration state. + private final Stack useVersionStack = new Stack<>(); // A stack to manage nested scopes of symbol tables. private final Stack symbolTableStack = new Stack<>(); private final Stack packageStack = new Stack<>(); @@ -150,6 +153,13 @@ public ScopedSymbolTable() { if (sayBit != null) { defaultFeatures |= (1 << sayBit); } + // This compatibility feature belongs to Perl's default bundle. Its + // bit must be present even when the rest of the current-version + // bundle remains opt-in, so `no feature` can disable it lexically. + Integer apostropheSeparatorBit = featureBitPositions.get("apostrophe_as_package_separator"); + if (apostropheSeparatorBit != null) { + defaultFeatures |= (1 << apostropheSeparatorBit); + } featureFlagsStack.push(defaultFeatures); postderefQqStack.push(false); enhancedXxStack.push(false); @@ -157,6 +167,7 @@ public ScopedSymbolTable() { strictOptionsStack.push(0); regexModifierStack.push(""); regexDebugFlagsStack.push(0); + useVersionStack.push(null); // Initialize the package name packageStack.push(new PackageInfo("main", false, null)); // Initialize the subroutine stack with empty string (no subroutine) @@ -235,6 +246,7 @@ public int enterScope() { strictOptionsStack.push(strictOptionsStack.peek()); regexModifierStack.push(regexModifierStack.peek()); regexDebugFlagsStack.push(regexDebugFlagsStack.peek()); + useVersionStack.push(null); // Return the current size of the symbol table stack as the scope index return symbolTableStack.size() - 1; @@ -278,6 +290,7 @@ public void exitScope(int scopeIndex) { strictOptionsStack.pop(); regexModifierStack.pop(); regexDebugFlagsStack.pop(); + useVersionStack.pop(); } // Propagate the child scope's index to the parent to prevent slot reuse. // This ensures that local variable slots allocated inside conditional branches @@ -288,6 +301,14 @@ public void exitScope(int scopeIndex) { } } + public String getUseVersion() { + return useVersionStack.peek(); + } + + public void setUseVersion(String version) { + useVersionStack.set(useVersionStack.size() - 1, version); + } + /** * Returns the JVM local variable slot indices for all {@code my} variables * declared in the scopes being exited (from the current top of the symbol diff --git a/src/main/java/org/perlonjava/runtime/CompilationRuntimeState.java b/src/main/java/org/perlonjava/runtime/CompilationRuntimeState.java index 2d8fa362a4..3e0b8c8b24 100644 --- a/src/main/java/org/perlonjava/runtime/CompilationRuntimeState.java +++ b/src/main/java/org/perlonjava/runtime/CompilationRuntimeState.java @@ -8,6 +8,7 @@ import java.util.ArrayDeque; import java.util.Deque; import java.util.HashMap; +import java.util.HashSet; import java.util.Map; import java.util.Set; import java.util.concurrent.ConcurrentHashMap; @@ -16,6 +17,9 @@ /** Runtime-owned lexical hint and warning state used across compilation and execution. */ public final class CompilationRuntimeState { public final Deque> hintCompileTimeStack = new ArrayDeque<>(); + /** Constant-handler categories removed by {@code undef *^H} in this lexical scope. */ + public Set clearedConstantHandlerCategories = new HashSet<>(); + public final Deque> clearedConstantHandlerCategoryStack = new ArrayDeque<>(); public final Map> hintSnapshots = new ConcurrentHashMap<>(); public final Map> hintScalarSnapshots = new ConcurrentHashMap<>(); public final AtomicInteger nextHintSnapshotId = new AtomicInteger(); @@ -68,6 +72,8 @@ public EndOfScopeCompileScope(String ownerFile) { public void clear() { hintCompileTimeStack.clear(); + clearedConstantHandlerCategories.clear(); + clearedConstantHandlerCategoryStack.clear(); hintSnapshots.clear(); hintScalarSnapshots.clear(); nextHintSnapshotId.set(0); diff --git a/src/main/java/org/perlonjava/runtime/HintHashRegistry.java b/src/main/java/org/perlonjava/runtime/HintHashRegistry.java index 14c347a202..7e37836593 100644 --- a/src/main/java/org/perlonjava/runtime/HintHashRegistry.java +++ b/src/main/java/org/perlonjava/runtime/HintHashRegistry.java @@ -46,6 +46,8 @@ public static void enterScope() { snapshot.put(entry.getKey(), new RuntimeScalar(entry.getValue())); } state().hintCompileTimeStack.push(snapshot); + state().clearedConstantHandlerCategoryStack.push( + new HashSet<>(state().clearedConstantHandlerCategories)); } /** @@ -59,6 +61,8 @@ public static void exitScope() { // Restore global %^H to the state saved when we entered this scope RuntimeHash hintHash = GlobalVariable.getGlobalHash(GlobalContext.encodeSpecialVar("H")); restoreHintHash(hintHash, savedState); + state().clearedConstantHandlerCategories = + state().clearedConstantHandlerCategoryStack.pop(); // %^H scope guards implement compile-time callbacks in DESTROY. // They must run before parsing/executing the next statement, not // at the interpreter's later top-level mortal sweep. @@ -78,6 +82,7 @@ public static void exitSpecialBlockScope() { } Map savedState = stack.pop(); RuntimeHash hintHash = GlobalVariable.getGlobalHash(GlobalContext.encodeSpecialVar("H")); + state().clearedConstantHandlerCategoryStack.pop(); Map pragmaUpdates = new HashMap<>(); Set pragmaDeletes = new HashSet<>(); for (Map.Entry entry : hintHash.elements.entrySet()) { @@ -135,6 +140,30 @@ public static RuntimeScalar getCompileTimeHint(String key) { return value == null ? null : new RuntimeScalar(value); } + /** + * Clears the active lexical {@code %^H}. This is used by {@code undef *^H}, + * whose typeglob operation removes the hint hash rather than merely + * replacing the public {@code $^H} bitmask scalar. + */ + public static void clearCurrentHintHash() { + RuntimeHash hintHash = GlobalVariable.getGlobalHash(GlobalContext.encodeSpecialVar("H")); + for (Map.Entry entry : hintHash.elements.entrySet()) { + RuntimeScalar handler = entry.getValue(); + if (handler.type == org.perlonjava.runtime.runtimetypes.RuntimeScalarType.CODE + || (handler.type == org.perlonjava.runtime.runtimetypes.RuntimeScalarType.REFERENCE + && handler.value instanceof RuntimeScalar reference + && reference.type == org.perlonjava.runtime.runtimetypes.RuntimeScalarType.CODE)) { + state().clearedConstantHandlerCategories.add(entry.getKey()); + } + } + restoreHintHash(hintHash, Collections.emptyMap()); + } + + /** Whether {@code undef *^H} removed this category's active constant handler. */ + public static boolean constantHandlerWasCleared(String category) { + return state().clearedConstantHandlerCategories.contains(category); + } + // ---- Snapshot registration (compile-time) ---- /** diff --git a/src/main/java/org/perlonjava/runtime/NamedCharacterExpansion.java b/src/main/java/org/perlonjava/runtime/NamedCharacterExpansion.java index 1079ddf88f..355106e226 100644 --- a/src/main/java/org/perlonjava/runtime/NamedCharacterExpansion.java +++ b/src/main/java/org/perlonjava/runtime/NamedCharacterExpansion.java @@ -11,6 +11,7 @@ import org.perlonjava.runtime.runtimetypes.RuntimeScalarType; import java.nio.charset.StandardCharsets; +import java.math.BigInteger; import org.perlonjava.runtime.operators.PerlUtfString; @@ -65,14 +66,17 @@ public static NamedCharacterExpansion resolve(String name, SourceMode inputMode) public static NamedCharacterExpansion resolve( String name, RuntimeScalar translator, SourceMode inputMode) { if (name != null && name.regionMatches(true, 0, "U+", 0, 2)) { - if (name.matches("(?i)U\\+[0-9A-F]+")) { + if (name.matches("(?i)U\\+[0-9A-F]+(?:_[0-9A-F]+)*")) { try { - long codePoint = Long.parseUnsignedLong(name.substring(2), 16); - if (codePoint < 0) { + String digits = name.substring(2); + BigInteger exactCodePoint = new BigInteger(digits.replace("_", ""), 16); + if (exactCodePoint.compareTo(BigInteger.valueOf(Long.MAX_VALUE)) > 0) { return new NamedCharacterExpansion( "", SourceMode.UNICODE, true, Status.INVALID, - "Invalid hexadecimal number in \\N{U+...}"); + "Use of code point 0x" + digits.toUpperCase() + + " is not allowed; the permissible max is 0x7FFFFFFFFFFFFFFF"); } + long codePoint = exactCodePoint.longValueExact(); String sequence; if (codePoint > 0x10FFFFL) { sequence = PerlUtfString.encodeBeyondUnicode(codePoint); @@ -89,11 +93,25 @@ public static NamedCharacterExpansion resolve( "Invalid hexadecimal number in \\N{U+...}"); } } - if (name.matches("(?i)U\\+[0-9A-F]+(?:\\.[0-9A-F]+)+")) { + if (name.matches("(?i)U\\+[0-9A-F]+(?:_[0-9A-F]+)*(?:\\.[0-9A-F]+(?:_[0-9A-F]+)*)+")) { try { StringBuilder sequence = new StringBuilder(); for (String scalar : name.substring(2).split("\\.")) { - sequence.appendCodePoint(Integer.parseInt(scalar, 16)); + BigInteger exactCodePoint = new BigInteger(scalar.replace("_", ""), 16); + if (exactCodePoint.compareTo(BigInteger.valueOf(Long.MAX_VALUE)) > 0) { + return new NamedCharacterExpansion( + "", SourceMode.UNICODE, true, Status.INVALID, + "Use of code point 0x" + scalar.toUpperCase() + + " is not allowed; the permissible max is 0x7FFFFFFFFFFFFFFF"); + } + long codePoint = exactCodePoint.longValueExact(); + if (codePoint > 0x10FFFFL) { + sequence.append(PerlUtfString.encodeBeyondUnicode(codePoint)); + } else if (codePoint >= 0xD800L && codePoint <= 0xDFFFL) { + sequence.append(PerlUtfString.encodeSurrogate(codePoint)); + } else { + sequence.appendCodePoint((int) codePoint); + } } return new NamedCharacterExpansion( sequence.toString(), SourceMode.UNICODE, diff --git a/src/main/java/org/perlonjava/runtime/operators/Directory.java b/src/main/java/org/perlonjava/runtime/operators/Directory.java index 756f40107e..b064267300 100644 --- a/src/main/java/org/perlonjava/runtime/operators/Directory.java +++ b/src/main/java/org/perlonjava/runtime/operators/Directory.java @@ -129,6 +129,14 @@ public static RuntimeScalar opendir(RuntimeList args) { RuntimeScalar dirHandle = (RuntimeScalar) args.elements.get(0); String dirPath = args.elements.get(1).toString(); + RuntimeIO existingHandle = dirHandle.getRuntimeIO(); + if (existingHandle != null + && existingHandle.ioHandle != null + && !(existingHandle.ioHandle instanceof org.perlonjava.runtime.io.ClosedIOHandle)) { + throw new PerlCompilerException("Cannot open " + filehandleName(dirHandle) + + " as a dirhandle: it is already open as a filehandle"); + } + try { // Close existing directory stream if present if ((dirHandle.type == RuntimeScalarType.GLOB || dirHandle.type == RuntimeScalarType.GLOBREFERENCE) @@ -159,6 +167,22 @@ public static RuntimeScalar opendir(RuntimeList args) { } } + private static String filehandleName(RuntimeScalar handle) { + RuntimeIO io = handle.getRuntimeIO(); + String name = io != null ? io.globName : null; + if (name == null && handle.value instanceof RuntimeGlob glob) { + name = glob.globName; + } + if (name == null) { + name = handle.lexicalDisplayName; + } + if (name == null || name.isEmpty()) { + return "$fh"; + } + int separator = name.lastIndexOf("::"); + return separator >= 0 ? name.substring(separator + 2) : name; + } + public static RuntimeScalar closedir(RuntimeScalar runtimeScalar) { RuntimeIO dirIO = runtimeScalar.getRuntimeIO(); if (dirIO.directoryIO != null) { diff --git a/src/main/java/org/perlonjava/runtime/operators/IOOperator.java b/src/main/java/org/perlonjava/runtime/operators/IOOperator.java index 994afe80f9..975d510e4b 100644 --- a/src/main/java/org/perlonjava/runtime/operators/IOOperator.java +++ b/src/main/java/org/perlonjava/runtime/operators/IOOperator.java @@ -674,6 +674,11 @@ public static RuntimeScalar open(int ctx, RuntimeBase... args) { || fileHandle == scalarUndef) { throw new PerlCompilerException("Modification of a read-only value attempted"); } + RuntimeIO existingHandle = fileHandle.getRuntimeIO(); + if (existingHandle != null && existingHandle.directoryIO != null) { + throw new PerlCompilerException("Cannot open " + filehandleName(fileHandle) + + " as a filehandle: it is already open as a dirhandle"); + } if (args.length < 2) { // 1-argument open: open FILEHANDLE // Per Perl semantics, the global scalar variable of the same name as the @@ -1010,6 +1015,21 @@ private static String normalizeAggregateHandleName(String sourceName) { if (!base.startsWith("$")) return null; return base + (array >= 0 && (hash < 0 || array < hash) ? "[...]" : "{...}"); } + private static String filehandleName(RuntimeScalar handle) { + RuntimeIO io = handle.getRuntimeIO(); + String name = io != null ? io.globName : null; + if (name == null && handle.value instanceof RuntimeGlob glob) { + name = glob.globName; + } + if (name == null) { + name = handle.lexicalDisplayName; + } + if (name == null || name.isEmpty()) { + return "$fh"; + } + int separator = name.lastIndexOf("::"); + return separator >= 0 ? name.substring(separator + 2) : name; + } /** * Close a file handle. @@ -1365,7 +1385,7 @@ public static RuntimeScalar sysread(int ctx, RuntimeBase... args) { // Check for :utf8 layer if (hasUtf8Layer(fh)) { - throw new PerlCompilerException("sysread() is not supported on handles with :utf8 layer"); + throw new PerlCompilerException("sysread() isn't allowed on :utf8 handles"); } RuntimeScalar argumentTarget = args[1].scalar(); @@ -1512,7 +1532,7 @@ public static RuntimeScalar syswrite(int ctx, RuntimeBase... args) { // Check for :utf8 layer if (hasUtf8Layer(fh)) { - throw new PerlCompilerException("syswrite() is not supported on handles with :utf8 layer"); + throw new PerlCompilerException("syswrite() isn't allowed on :utf8 handles"); } String data = args[1].scalar().toString(); diff --git a/src/main/java/org/perlonjava/runtime/operators/OperatorHandler.java b/src/main/java/org/perlonjava/runtime/operators/OperatorHandler.java index 9453b0c8be..f29c05d5a2 100644 --- a/src/main/java/org/perlonjava/runtime/operators/OperatorHandler.java +++ b/src/main/java/org/perlonjava/runtime/operators/OperatorHandler.java @@ -264,6 +264,7 @@ public record OperatorHandler(String className, String methodName, int methodTyp // Misc put("isa", "isa", "org/perlonjava/runtime/operators/ReferenceOperators", "(Lorg/perlonjava/runtime/runtimetypes/RuntimeScalar;Lorg/perlonjava/runtime/runtimetypes/RuntimeScalar;)Lorg/perlonjava/runtime/runtimetypes/RuntimeScalar;"); put("bless", "bless", "org/perlonjava/runtime/operators/ReferenceOperators", "(Lorg/perlonjava/runtime/runtimetypes/RuntimeScalar;Lorg/perlonjava/runtime/runtimetypes/RuntimeScalar;)Lorg/perlonjava/runtime/runtimetypes/RuntimeScalar;"); + put("blessClassInstance", "blessClassInstance", "org/perlonjava/runtime/operators/ReferenceOperators", "(Lorg/perlonjava/runtime/runtimetypes/RuntimeScalar;Lorg/perlonjava/runtime/runtimetypes/RuntimeScalar;)Lorg/perlonjava/runtime/runtimetypes/RuntimeScalar;"); put("ref", "ref", "org/perlonjava/runtime/operators/ReferenceOperators", "(Lorg/perlonjava/runtime/runtimetypes/RuntimeScalar;)Lorg/perlonjava/runtime/runtimetypes/RuntimeScalar;"); put("caller", "callerWithSub", "org/perlonjava/runtime/runtimetypes/RuntimeCode", "(Lorg/perlonjava/runtime/runtimetypes/RuntimeList;ILorg/perlonjava/runtime/runtimetypes/RuntimeScalar;)Lorg/perlonjava/runtime/runtimetypes/RuntimeList;"); diff --git a/src/main/java/org/perlonjava/runtime/operators/Readline.java b/src/main/java/org/perlonjava/runtime/operators/Readline.java index 6f733cce5b..5c542ebdbb 100644 --- a/src/main/java/org/perlonjava/runtime/operators/Readline.java +++ b/src/main/java/org/perlonjava/runtime/operators/Readline.java @@ -65,8 +65,13 @@ public static RuntimeBase readline(RuntimeScalar fileHandle, int ctx) { } // Perl warns and returns undef for ordinary unopened filehandles, - // rather than dying. - WarnDie.warn(new RuntimeScalar("readline() on unopened filehandle"), new RuntimeScalar("\n")); + // rather than dying. The diagnostic belongs to the `unopened` + // warning category, so it must remain silent when that category + // is disabled (including Perl's default warning state). + WarnDie.warnWithCategory( + new RuntimeScalar("readline() on unopened filehandle"), + new RuntimeScalar("\n"), + "unopened"); return ctx == RuntimeContextType.LIST ? new RuntimeList() : scalarUndef; } diff --git a/src/main/java/org/perlonjava/runtime/operators/ReferenceOperators.java b/src/main/java/org/perlonjava/runtime/operators/ReferenceOperators.java index 97bc5d5a52..4100b5e301 100644 --- a/src/main/java/org/perlonjava/runtime/operators/ReferenceOperators.java +++ b/src/main/java/org/perlonjava/runtime/operators/ReferenceOperators.java @@ -21,7 +21,37 @@ public class ReferenceOperators { * @throws PerlCompilerException if attempting to bless a non-reference value */ public static RuntimeScalar bless(RuntimeScalar runtimeScalar, RuntimeScalar className) { + return bless(runtimeScalar, className, false); + } + + /** + * Bless the object allocated by a synthetic {@code class} constructor. + * User-visible {@code bless} must reject a class name, but the constructor + * is the language-defined mechanism that creates instances of that class. + */ + public static RuntimeScalar blessClassInstance(RuntimeScalar runtimeScalar, RuntimeScalar className) { + return bless(runtimeScalar, className, true); + } + + private static RuntimeScalar bless(RuntimeScalar runtimeScalar, RuntimeScalar className, + boolean classConstruction) { if (RuntimeScalarType.isReference(runtimeScalar)) { + // The class-name operand is an ordinary scalar read, so tied + // scalar magic must run before deciding whether it is a reference. + className = RuntimeScalar.fetchTiedOnce(className); + // A reference cannot be used directly as a class name. Perl does + // permit an object with an explicit stringification overload, so + // resolve that before rejecting ordinary references. + if (RuntimeScalarType.isReference(className)) { + OverloadContext overloadContext = OverloadContext.prepare( + RuntimeScalarType.blessedId(className)); + RuntimeScalar stringified = overloadContext == null ? null + : overloadContext.tryOverload("(\"\"", new RuntimeArray(className)); + if (stringified == null) { + throw new PerlCompilerException("Attempt to bless into a reference"); + } + className = stringified; + } // Match Perl's diagnostics for `bless`: // - undef class name produces "Use of uninitialized value $class in bless" // - empty class name produces "Explicit blessing to '' (assuming package main)" @@ -63,6 +93,13 @@ public static RuntimeScalar bless(RuntimeScalar runtimeScalar, RuntimeScalar cla str = GlobalVariable.resolveStashAlias(str); RuntimeBase referent = (RuntimeBase) runtimeScalar.value; + if (!classConstruction && ClassRegistry.isClass(str)) { + throw new PerlCompilerException("Attempt to bless into a class"); + } + if (referent.blessId != 0 + && ClassRegistry.isClass(NameNormalizer.getBlessStr(referent.blessId))) { + throw new PerlCompilerException("Can't bless an object reference"); + } int newBlessId = NameNormalizer.getBlessId(str); // Phase D-W6.10: arm targeted refCount tracing for classes diff --git a/src/main/java/org/perlonjava/runtime/operators/WarnDie.java b/src/main/java/org/perlonjava/runtime/operators/WarnDie.java index 719862a3be..b391ec5e79 100644 --- a/src/main/java/org/perlonjava/runtime/operators/WarnDie.java +++ b/src/main/java/org/perlonjava/runtime/operators/WarnDie.java @@ -616,7 +616,11 @@ public static RuntimeBase die(RuntimeBase message, RuntimeScalar where, String f String out = message.toString(); if (!out.endsWith("\n")) { // Add " at FILE line N" location - out += signatureMismatchLocation(out, where); + String location = signatureMismatchLocation(out, where); + if (location.isEmpty() && fileName != null && lineNumber > 0) { + location = " at " + fileName + " line " + lineNumber; + } + out += location; // Add filehandle context if available (e.g., ", chunk 1") String filehandleContext = getFilehandleContext(); if (filehandleContext != null && !filehandleContext.isEmpty()) { @@ -694,8 +698,8 @@ private static String signatureMismatchLocation(String message, RuntimeScalar de if (!message.startsWith("Too few arguments for subroutine '") && !message.startsWith("Too many arguments for subroutine '") && !message.startsWith("Odd name/value argument for subroutine '") - && !message.startsWith("Missing required named parameter '") - && !message.startsWith("Unrecognized named parameter '") + && !message.startsWith("Missing required named parameter") + && !message.startsWith("Unrecognized named parameter") // Native subs use Perl's conventional Usage: diagnostic for // arguments that cannot be represented by their prototype. // These errors, like signature errors, are reported at the @@ -712,10 +716,14 @@ private static String signatureMismatchLocation(String message, RuntimeScalar de return " at (eval 0) line 1"; } - RuntimeList caller = RuntimeCode.caller(new RuntimeList(), RuntimeContextType.LIST); - if (caller.size() >= 3 && caller.elements.get(1).getDefinedBoolean() - && caller.elements.get(2).getDefinedBoolean()) { - return " at " + caller.elements.get(1) + " line " + caller.elements.get(2); + for (int depth = 0; depth <= 1; depth++) { + RuntimeList arguments = new RuntimeList(); + if (depth != 0) arguments.add(new RuntimeScalar(depth)); + RuntimeList caller = RuntimeCode.caller(arguments, RuntimeContextType.LIST); + if (caller.size() >= 3 && caller.elements.get(1).getDefinedBoolean() + && caller.elements.get(2).getDefinedBoolean()) { + return " at " + caller.elements.get(1) + " line " + caller.elements.get(2); + } } return definitionWhere.toString(); } diff --git a/src/main/java/org/perlonjava/runtime/operators/WindowsBatchArgvLauncher.java b/src/main/java/org/perlonjava/runtime/operators/WindowsBatchArgvLauncher.java index 86e5f614f2..7c870788ca 100644 --- a/src/main/java/org/perlonjava/runtime/operators/WindowsBatchArgvLauncher.java +++ b/src/main/java/org/perlonjava/runtime/operators/WindowsBatchArgvLauncher.java @@ -13,12 +13,12 @@ * losslessly, including physical newlines and embedded double quotes. * *

The outer Java process receives URL-safe base64, so no cmd.exe parser can - * consume part of an argument. The decoded values are installed in the child - * environment and expanded with delayed expansion after cmd has parsed the - * command structure. Because the target batch inherits delayed expansion, a - * literal {@code !} in its path or argv cannot be transported safely through - * its later {@code %1}/{@code %*} expansion; reject that case explicitly - * instead of silently changing the child's arguments.

+ * consume part of an argument. Ordinary batch targets receive the decoded + * values through delayed environment expansion after cmd has parsed the + * command structure. A literal {@code !} cannot survive that expansion, so + * those targets reject it explicitly. The {@code jperl.bat} target is + * different: it dispatches straight to {@link Main} and never invokes + * {@code cmd.exe}, so it preserves literal exclamation marks losslessly.

*/ public final class WindowsBatchArgvLauncher { private WindowsBatchArgvLauncher() { @@ -39,6 +39,11 @@ public static void main(String[] encoded) throws Exception { return; } + rejectDelayedExpansionHazard(script, "batch script path"); + for (int i = 0; i < arguments.size(); i++) { + rejectDelayedExpansionHazard(arguments.get(i), "batch argument " + i); + } + ProcessBuilder builder = new ProcessBuilder(); builder.environment().put("PERLONJAVA_BATCH_SCRIPT", script); StringBuilder command = new StringBuilder("\"\"!PERLONJAVA_BATCH_SCRIPT!\""); @@ -59,8 +64,6 @@ static List decodeArguments(String[] encoded) { List decoded = new ArrayList<>(encoded.length); for (int i = 0; i < encoded.length; i++) { String value = decode(decoder, encoded[i]); - rejectDelayedExpansionHazard(value, - i == 0 ? "batch script path" : "batch argument " + (i - 1)); decoded.add(value); } return decoded; diff --git a/src/main/java/org/perlonjava/runtime/regex/PerlUnicodeNamedSequenceData.java b/src/main/java/org/perlonjava/runtime/regex/PerlUnicodeNamedSequenceData.java index 5f064a6d50..1f4d53a2bf 100644 --- a/src/main/java/org/perlonjava/runtime/regex/PerlUnicodeNamedSequenceData.java +++ b/src/main/java/org/perlonjava/runtime/regex/PerlUnicodeNamedSequenceData.java @@ -264,7 +264,7 @@ public static String sequence(String name) { } /** Returns whether a name identifies a sequence under Unicode loose matching. */ - static boolean isNamedSequence(String name) { + public static boolean isNamedSequence(String name) { if (name == null) return false; String loose = looseName(name); for (String candidate : NAMES) { diff --git a/src/main/java/org/perlonjava/runtime/regex/RuntimeRegex.java b/src/main/java/org/perlonjava/runtime/regex/RuntimeRegex.java index c9eab2e845..710fa691b7 100644 --- a/src/main/java/org/perlonjava/runtime/regex/RuntimeRegex.java +++ b/src/main/java/org/perlonjava/runtime/regex/RuntimeRegex.java @@ -779,6 +779,14 @@ private static synchronized RuntimeRegex compileSynchronized( String displayDiagnosticPattern = sourceDiagnosticPattern == null ? originalPatternString : RegexMarkers.stripLiteralDiagnostics(sourceDiagnosticPattern); + enforceCompileRecursionLimit(displayDiagnosticPattern); + if (isNamedCharacterDiagnostic(literalFrontendDiagnostic)) { + String diagnostic = malformedUPlusDiagnostic( + displayDiagnosticPattern, literalFrontendDiagnostic); + if (diagnostic != null) { + throw new PerlCompilerException(diagnostic); + } + } // Lexical regex debugging changes the compiled representation. // A lexical charname translator may return a different expansion for // each compilation. Literal syntax validation is the first leg of one @@ -1018,6 +1026,11 @@ private static synchronized RuntimeRegex compileSynchronized( } if (e instanceof IllegalArgumentException && isNamedCharacterDiagnostic(e.getMessage())) { + String diagnostic = malformedUPlusDiagnostic( + displayDiagnosticPattern, e.getMessage()); + if (diagnostic != null) { + throw new PerlCompilerException(diagnostic); + } throw new PerlCompilerException(e.getMessage()); } if (e instanceof IllegalArgumentException @@ -1118,6 +1131,14 @@ && containsExecutableSource(originalPatternString, && message.matches("undefined group <\\d+> reference")) { message = "Reference to nonexistent group"; } + if ("\\K not permitted in lookahead/lookbehind in regex".equals(message)) { + int keepOffset = displayDiagnosticPattern.indexOf("\\K"); + if (keepOffset >= 0) { + throw new PerlCompilerException(RegexDiagnosticFormatter.markedPerl( + displayDiagnosticPattern, keepOffset + 2, + "\\K not permitted in lookahead/lookbehind")); + } + } int bytePosition = ((SyntaxException) e).getPatternPosition(); if (bytePosition != SyntaxException.UNKNOWN_PATTERN_POSITION) { int characterPosition = utf8ByteOffsetToCharacterOffset( @@ -1221,6 +1242,46 @@ && containsExecutableSource(originalPatternString, return regex; } + /** Implements ${^RE_COMPILE_RECURSION_LIMIT} for nested regex groups. */ + private static void enforceCompileRecursionLimit(String pattern) { + RuntimeScalar limitScalar = GlobalVariable.getGlobalVariable( + GlobalContext.encodeSpecialVar("RE_COMPILE_RECURSION_LIMIT")); + if (!limitScalar.getDefinedBoolean()) return; + int limit = limitScalar.getInt(); + if (limit <= 0 || pattern == null) return; + boolean escaped = false; + boolean characterClass = false; + int depth = 0; + for (int i = 0; i < pattern.length(); i++) { + char current = pattern.charAt(i); + if (escaped) { + escaped = false; + continue; + } + if (current == '\\') { + escaped = true; + continue; + } + if (current == '[') { + characterClass = true; + continue; + } + if (current == ']' && characterClass) { + characterClass = false; + continue; + } + if (characterClass) continue; + if (current == '(') { + if (++depth >= limit) { + throw new PerlCompilerException(RegexDiagnosticFormatter.markedPerl( + pattern, i + 1, "Too many nested open parens")); + } + } else if (current == ')' && depth > 0) { + depth--; + } + } + } + /** * Perl finishes collecting recoverable regex warnings after recognizing an * invalid modifier. Nonfatal warnings still reach the warning handler; @@ -2540,10 +2601,46 @@ private static boolean isNamedCharacterDiagnostic(String message) { return "Invalid character in \\N{...}".equals(message) || "Zero length \\N{}".equals(message) || "Invalid hexadecimal number in \\N{U+...}".equals(message) + || (message != null && message.startsWith("Use of code point 0x") + && message.contains("the permissible max is 0x7FFFFFFFFFFFFFFF")) || (message != null && message.startsWith( "charnames alias definitions may not contain ")); } + /** Formats malformed U+ named-character escapes at their source location. */ + private static String malformedUPlusDiagnostic(String pattern, String message) { + if (pattern == null) { + return null; + } + boolean overflow = message != null && message.startsWith("Use of code point 0x"); + if (!overflow && !"Invalid hexadecimal number in \\N{U+...}".equals(message)) return null; + int start = pattern.indexOf("\\N{U+"); + if (start < 0) return null; + int bodyStart = start + "\\N{U+".length(); + int close = pattern.indexOf('}', bodyStart); + if (close < 0) return null; + if (overflow) { + return RegexDiagnosticFormatter.markedPerl(pattern, close, message); + } + int marker = bodyStart; + boolean sawDigit = false; + for (; marker < close; marker++) { + char ch = pattern.charAt(marker); + if (Character.digit(ch, 16) >= 0) { + sawDigit = true; + continue; + } + if (ch == '_' && sawDigit && marker + 1 < close + && Character.digit(pattern.charAt(marker + 1), 16) >= 0) { + continue; + } + marker++; + break; + } + return RegexDiagnosticFormatter.markedPerl(pattern, marker, + "Invalid hexadecimal number in \\N{U+...}"); + } + static boolean containsExecutableSource(String pattern, boolean extended) { return scanExecutableSource(pattern, extended, false, false).executable(); @@ -3834,6 +3931,11 @@ public static RuntimeBase replaceRegex(RuntimeScalar quotedRegex, RuntimeScalar || (regex.regexFlags.taintResults() && inputTainted); boolean destructiveReplacement = !regex.regexFlags.isNonDestructive(); + if (!destructiveReplacement && ctx == RuntimeContextType.VOID) { + Warnings.emitCategoryWarning( + "void", "Useless use of non-destructive substitution (s///r)"); + } + // Don't reset state().globalMatcher here - only reset it if we actually find a match // This preserves capture variables from previous matches when substitution doesn't match diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/ClassRegistry.java b/src/main/java/org/perlonjava/runtime/runtimetypes/ClassRegistry.java index bb1189da0d..97801e230a 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/ClassRegistry.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/ClassRegistry.java @@ -21,6 +21,11 @@ public static void registerClass(String className) { classNames().add(className); } + /** Remove a class declaration whose enclosing source failed to compile. */ + public static void unregisterClass(String className) { + classNames().remove(className); + } + /** * Check if a package name is a registered Perl 5.38+ class. * diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/ErrorMessageUtil.java b/src/main/java/org/perlonjava/runtime/runtimetypes/ErrorMessageUtil.java index 5a34586791..3071edcb1e 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/ErrorMessageUtil.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/ErrorMessageUtil.java @@ -325,8 +325,31 @@ public void setTokenIndex(int index) { * @return the formatted error message with context */ public String errorMessage(int index, String message) { + return errorMessage(index, message, true, 3, false); + } + + /** + * Formats a syntax error whose source context must include a mismatched + * collection delimiter. Most syntax excerpts stop before braces so that + * enclosing blocks do not leak into the diagnostic; Perl retains the + * mismatched delimiter for errors such as {@code near "[ }"}. + */ + public String errorMessageIncludingDelimiter(int index, String message) { + return errorMessage(index, message, true, 3, true); + } + + /** + * Formats an error whose index intentionally identifies the first token + * in its source context, including when that token follows a newline. + */ + public String errorMessageAtToken(int index, String message) { + return errorMessage(index, message, false, 2, false); + } + + private String errorMessage(int index, String message, boolean rewindAfterNewline, + int maxContextTokens, boolean includeDelimiters) { int effectiveIndex = index; - if ("syntax error".equals(message) && index > 1 + if (rewindAfterNewline && "syntax error".equals(message) && index > 1 && tokens.get(index - 1).type == LexerTokenType.NEWLINE) { effectiveIndex = index - 2; } @@ -337,7 +360,7 @@ public String errorMessage(int index, String message) { return message + " at " + loc.fileName() + " line " + loc.lineNumber() + ".\n"; } - String nearString = buildNearString(effectiveIndex, message); + String nearString = buildNearString(effectiveIndex, message, maxContextTokens, includeDelimiters); String quotedNear = errorMessageQuote(nearString); // Perl prints a malformed quoted-string escape verbatim in its @@ -361,7 +384,8 @@ public String warningLocation(int index) { return " at " + loc.fileName() + " line " + loc.lineNumber(); } - private String buildNearString(int index, String message) { + private String buildNearString(int index, String message, int maxContextTokens, + boolean includeDelimiters) { if ("syntax error".equals(message)) { String previousContext = buildPreviousNotContext(index); if (previousContext != null) { @@ -396,16 +420,25 @@ private String buildNearString(int index, String message) { // non-whitespace tokens. Keep the complete repeated escape in the // diagnostic rather than truncating it after the historical generic // three-token excerpt limit. - int maxNonWhitespaceTokens = 3; + int maxNonWhitespaceTokens = maxContextTokens; if (start + 2 < tokens.size() && "\\".equals(tokens.get(start).text) && "\\".equals(tokens.get(start + 2).text)) { - maxNonWhitespaceTokens = 4; + maxNonWhitespaceTokens = Math.max(maxNonWhitespaceTokens, 4); + } + // A named signature parameter starts with three significant tokens + // (':', '$', and its name). Keep its terminating ')' in a slurpy + // ordering diagnostic, matching Perl's `near ":$name) "` excerpt. + if (("Slurpy parameter not last".equals(message) + || "Duplicated subroutine parameter name".equals(message) + || "Mandatory parameter follows optional parameter".equals(message)) + && start < tokens.size() && ":".equals(tokens.get(start).text)) { + maxNonWhitespaceTokens = Math.max(maxNonWhitespaceTokens, 4); } for (int i = start; i <= end; i++) { LexerToken tok = tokens.get(i); if (tok.type == LexerTokenType.EOF || tok.type == LexerTokenType.NEWLINE) break; - if (tok.text.equals("{") || tok.text.equals("}")) break; + if (!includeDelimiters && (tok.text.equals("{") || tok.text.equals("}"))) break; if (tok.type != LexerTokenType.WHITESPACE) { nonWsCount++; if (nonWsCount > maxNonWhitespaceTokens) break; @@ -414,6 +447,18 @@ private String buildNearString(int index, String message) { } String near = sb.toString(); near = near.replaceAll("^\\s+", ""); + // Signature validation stops an excerpt at a parameter separator. + // Do not retain the space after that comma: Perl says `near "$c,"`. + if ("Mandatory parameter follows optional parameter".equals(message) + && near.matches(".*,[\\s]+$")) { + near = near.replaceFirst("\\s+$", ""); + } + // A leading comma in a signature is reported by Perl as `near "(,"`; + // the whitespace that follows the comma is not part of that syntax + // excerpt. + if ("syntax error".equals(message) && near.matches("^\\(,[\\s]+$")) { + near = near.replaceFirst("\\s+$", ""); + } if (trimTrailingWhitespace) { near = near.replaceAll("\\s+$", ""); } diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/GlobalContext.java b/src/main/java/org/perlonjava/runtime/runtimetypes/GlobalContext.java index 3cc05aa6ac..4f89879bb4 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/GlobalContext.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/GlobalContext.java @@ -136,7 +136,10 @@ public static void initializeGlobals(CompilerOptions compilerOptions) { GlobalVariable.globalVariables.put("main::\\", ors); } GlobalVariable.getGlobalVariable("main::$").set(ForkOpenState.initialProcessId()); - GlobalVariable.getGlobalVariable("main::?"); + // Perl starts with a successful child status. Leaving this as undef + // makes numeric loop conditions see a nonzero value and changes + // control flow before the first child process is run. + GlobalVariable.getGlobalVariable("main::?").set(0); // Only set $0 if it hasn't been set yet - prevents overwriting during re-entrant calls // (e.g., when require() is called during module initialization) if (!GlobalVariable.globalVariables.containsKey("main::0")) { @@ -176,6 +179,7 @@ public static void initializeGlobals(CompilerOptions compilerOptions) { GlobalVariable.globalVariables.put(encodeSpecialVar("LAST_SUCCESSFUL_PATTERN"), new ScalarSpecialVariable(ScalarSpecialVariable.Id.LAST_SUCCESSFUL_PATTERN)); GlobalVariable.globalVariables.put(encodeSpecialVar("LAST_FH"), new ScalarSpecialVariable(ScalarSpecialVariable.Id.LAST_FH)); // $^LAST_FH GlobalVariable.globalVariables.put(encodeSpecialVar("H"), new ScalarSpecialVariable(ScalarSpecialVariable.Id.HINTS)); // $^H - compile-time hints + GlobalVariable.globalVariables.put(encodeSpecialVar("ENCODING"), new ScalarSpecialVariable(ScalarSpecialVariable.Id.REMOVED_ENCODING)); // $^R is writable, not read-only - initialize as regular variable instead of ScalarSpecialVariable // GlobalVariable.globalVariables.put(encodeSpecialVar("R"), new ScalarSpecialVariable(ScalarSpecialVariable.Id.LAST_REGEXP_CODE_RESULT)); // $^R GlobalVariable.getGlobalVariable(encodeSpecialVar("R")); // initialize $^R to "undef" - writable variable diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/GlobalRuntimeState.java b/src/main/java/org/perlonjava/runtime/runtimetypes/GlobalRuntimeState.java index 1895f83a5a..ed3835d904 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/GlobalRuntimeState.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/GlobalRuntimeState.java @@ -50,6 +50,7 @@ public final class GlobalRuntimeState { private final Set declaredGlobalHashes = new HashSet<>(); private final Set classNames = new HashSet<>(); private final Map> classFields = new HashMap<>(); + private final Map> classParameters = new HashMap<>(); private final Map classParents = new HashMap<>(); private final Map packageVersions = new HashMap<>(); private CustomClassLoader generatedClassLoader = @@ -168,11 +169,18 @@ public Set classNames() { return classNames; } + + /** Field declarations keyed by their owning Perl class. */ public Map> classFields() { return classFields; } + /** Constructor parameter names keyed by their declaring Perl class. */ + public Map> classParameters() { + return classParameters; + } + /** Parent declarations used by the class-field parser. */ public Map classParents() { return classParents; diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/PerlThreadRegistry.java b/src/main/java/org/perlonjava/runtime/runtimetypes/PerlThreadRegistry.java index affe9b83fe..24a7bc103c 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/PerlThreadRegistry.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/PerlThreadRegistry.java @@ -37,9 +37,12 @@ void remove(PerlThreadControlBlock thread) { if (threads.get(thread.id()) != thread) return; // Publish the retained terminal record before withdrawing the active // record. Readers of getKnown() must never observe a gap between the - // two maps while a child completes, joins, or detaches. + // two maps while a child completes, joins, or detaches. A completed + // detached child can race its detach caller here; both paths may + // publish the same terminal record, but the losing active-map removal + // must never remove that retained record. terminalThreads.put(thread.id(), thread); - if (!threads.remove(thread.id(), thread)) terminalThreads.remove(thread.id(), thread); + threads.remove(thread.id(), thread); } public PerlThreadControlBlock get(long id) { diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeCode.java b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeCode.java index 691abeb474..b55c886f8a 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeCode.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeCode.java @@ -29,6 +29,7 @@ import org.perlonjava.runtime.operators.WarnDie; import org.perlonjava.runtime.perlmodule.BHooksEndOfScope; import org.perlonjava.runtime.perlmodule.Strict; +import org.perlonjava.runtime.perlmodule.Warnings; import org.perlonjava.runtime.CoreSubroutineGenerator; import java.lang.invoke.MethodHandle; @@ -39,6 +40,7 @@ import java.math.BigInteger; import java.nio.charset.StandardCharsets; import java.util.*; +import org.perlonjava.runtime.perlmodule.Universal; import java.util.function.Supplier; import static org.perlonjava.frontend.parser.ParserTables.CORE_PROTOTYPES; @@ -54,6 +56,12 @@ * It provides functionality to compile, store, and execute Perl subroutines and eval strings. */ public class RuntimeCode extends RuntimeBase implements RuntimeScalarReference { + private static final String INDIRECT_BLOCK_METHOD_PREFIX = "\uFDD0indirect-block:"; + + /** Marks the parser's {@code method { BLOCK }} indirect-object form. */ + public static String indirectBlockMethodName(String methodName) { + return INDIRECT_BLOCK_METHOD_PREFIX + methodName; + } private static final ThreadLocal SIGNATURE_CALL_DEPTH = ThreadLocal.withInitial(() -> 0); @@ -172,20 +180,37 @@ protected void validateNamedSignatureArguments(RuntimeArray args) { values.put(args.elements.get(i).toString(), args.elements.get(i + 1)); } if (signatureSlurpySigil == null) { + List unrecognized = new ArrayList<>(); for (String name : values.keySet()) { if (!signatureNamedParams.contains(name)) { - WarnDie.die(new RuntimeScalar("Unrecognized named parameter '" + name - + "' to subroutine '" + signatureSubName + "'"), new RuntimeScalar("")); + unrecognized.add(name); } } + if (!unrecognized.isEmpty()) { + boolean truncated = unrecognized.size() > 5; + String listed = truncated + ? String.join("', '", unrecognized.subList(0, 5)) + "', ..." + : String.join("', '", unrecognized); + String label = unrecognized.size() == 1 ? "parameter" : "parameters"; + String message = "Unrecognized named " + label + " '" + listed + + (truncated ? " to subroutine '" : "' to subroutine '") + + signatureSubName + "'"; + WarnDie.die(new RuntimeScalar(message), new RuntimeScalar("")); + } } if (!"@".equals(signatureSlurpySigil)) { + List missing = new ArrayList<>(); for (String required : signatureRequiredNamedParams) { if (!values.containsKey(required)) { - WarnDie.die(new RuntimeScalar("Missing required named parameter '" + required - + "' to subroutine '" + signatureSubName + "'"), new RuntimeScalar("")); + missing.add(required); } } + if (!missing.isEmpty()) { + String label = missing.size() == 1 ? "parameter" : "parameters"; + WarnDie.die(new RuntimeScalar("Missing required named " + label + " '" + + String.join("', '", missing) + "' to subroutine '" + signatureSubName + "'"), + new RuntimeScalar("")); + } } } @@ -1295,6 +1320,14 @@ public static void registerDisabledWarnings(String className, Set catego // Functional interface for direct subroutine invocation (preferred for generated classes) public PerlSubroutine subroutine; public boolean isStatic; + /** True for a `method` declared inside a Perl class. */ + public boolean isClassMethod; + /** Synthetic constructor emitted for a Perl class declaration. */ + public boolean generatedClassConstructor; + /** Anonymous CV implementing a Perl class ADJUST block. */ + public boolean classAdjustBlock; + /** Declaring class for {@link #isClassMethod}. */ + public String declaringClass; public String autoloadVariableName = null; // Code object instance used during execution (legacy - used with methodHandle) public Object codeObject; @@ -1908,6 +1941,10 @@ public RuntimeCode cloneForClosure() { clone.isConstantCv = this.isConstantCv; clone.isLexicalConstantCv = this.isLexicalConstantCv; clone.isStatic = this.isStatic; + clone.isClassMethod = this.isClassMethod; + clone.generatedClassConstructor = this.generatedClassConstructor; + clone.classAdjustBlock = this.classAdjustBlock; + clone.declaringClass = this.declaringClass; clone.isDeclared = this.isDeclared; clone.constantValue = this.constantValue; clone.lexicalVariableNames = this.lexicalVariableNames == null @@ -2081,6 +2118,16 @@ private static RuntimeScalar resolveLateDefinedForwardCodeRef(RuntimeScalar curr * call-site line. */ public static void throwIfDirectCallUndefined(RuntimeScalar runtimeScalar, String subroutineName) { + throwIfDirectCallUndefined(runtimeScalar, subroutineName, null); + } + + /** + * Direct-call preflight with the optional bare statement label that Perl + * includes in an undefined-subroutine diagnostic. + */ + public static void throwIfDirectCallUndefined(RuntimeScalar runtimeScalar, + String subroutineName, + String precedingLabel) { RuntimeScalar curScalar = resolveDirectCallTarget(runtimeScalar, subroutineName); RuntimeScalar evalFilledLexicalForward = resolveEvalFilledLexicalForward(curScalar); if (evalFilledLexicalForward != null) { @@ -2099,8 +2146,8 @@ public static void throwIfDirectCallUndefined(RuntimeScalar runtimeScalar, Strin if (curScalar.type == RuntimeScalarType.UNDEF) { String fullSubName = knownUndefinedSubroutineName(curScalar, subroutineName); if (fullSubName != null) { - throw new PerlCompilerException(gotoErrorPrefix(subroutineName) - + "ndefined subroutine &" + fullSubName + " called"); + throw new PerlCompilerException(undefinedDirectCallMessage( + subroutineName, fullSubName, precedingLabel)); } return; } @@ -2112,16 +2159,26 @@ public static void throwIfDirectCallUndefined(RuntimeScalar runtimeScalar, Strin return; } - if (code.compilerSupplier != null) { - RuntimeList savedConstantValue = code.constantValue; - java.util.List savedAttributes = code.attributes; - code.compilerSupplier.get(); + if (code.compilerSupplier != null) { + RuntimeList savedConstantValue = code.constantValue; + java.util.List savedAttributes = code.attributes; + boolean savedIsClassMethod = code.isClassMethod; + String savedDeclaringClass = code.declaringClass; + String savedReferenceOriginFqn = code.referenceOriginFqn; + code.compilerSupplier.get(); code = (RuntimeCode) curScalar.value; if (savedConstantValue != null && code.constantValue == null) { code.constantValue = savedConstantValue; - } - restoreLazyAttributes(code, savedAttributes); } + restoreLazyAttributes(code, savedAttributes); + if (savedIsClassMethod) { + code.isClassMethod = true; + code.declaringClass = savedDeclaringClass; + } + if (code.referenceOriginFqn == null) { + code.referenceOriginFqn = savedReferenceOriginFqn; + } + } if (!code.defined() && "CORE".equals(code.packageName) && code.subName != null) { if (CoreSubroutineGenerator.generateWrapper(code.subName)) { @@ -2170,8 +2227,8 @@ public static void throwIfDirectCallUndefined(RuntimeScalar runtimeScalar, Strin } } - throw new PerlCompilerException(gotoErrorPrefix(subroutineName) - + "ndefined subroutine &" + fullSubName + " called"); + throw new PerlCompilerException(undefinedDirectCallMessage( + subroutineName, fullSubName, precedingLabel)); } return; } @@ -2228,6 +2285,16 @@ public static void throwIfDirectCallUndefined(RuntimeScalar runtimeScalar, Strin } } + private static String undefinedDirectCallMessage(String subroutineName, + String fullSubName, + String precedingLabel) { + String message = gotoErrorPrefix(subroutineName) + + "ndefined subroutine &" + fullSubName + " called"; + return precedingLabel == null || precedingLabel.isEmpty() + ? message + : message + ", close to label '" + precedingLabel + "'"; + } + private static RuntimeScalar findImportedStubAutoload(RuntimeCode code, String fullSubName) { if (code.packageName == null || code.packageName.isEmpty() || fullSubName == null || fullSubName.isEmpty()) { @@ -2448,6 +2515,10 @@ public static String getNextEvalFilename() { return PerlRuntime.current().runtimeCodeState().nextEvalFilename(); } + public static String getNextEvalFilename(String sourceName) { + return PerlRuntime.current().runtimeCodeState().nextEvalFilename(sourceName); + } + private static void warnSignatureArgsInEval(String source, String fileName) { if (source == null || !source.contains("@_")) return; // JVM-generated subroutine bodies do not always enter through a @@ -2475,6 +2546,10 @@ public static void copy(RuntimeCode code, RuntimeCode codeFrom) { code.methodHandle = codeFrom.methodHandle; code.subroutine = codeFrom.subroutine; code.isStatic = codeFrom.isStatic; + code.isClassMethod = codeFrom.isClassMethod; + code.generatedClassConstructor = codeFrom.generatedClassConstructor; + code.classAdjustBlock = codeFrom.classAdjustBlock; + code.declaringClass = codeFrom.declaringClass; code.codeObject = codeFrom.codeObject; code.cvStartFile = codeFrom.cvStartFile; code.cvStartLine = codeFrom.cvStartLine; @@ -2496,6 +2571,10 @@ public void adoptDefinitionFrom(RuntimeCode codeFrom) { this.methodHandle = codeFrom.methodHandle; this.subroutine = codeFrom.subroutine; this.isStatic = codeFrom.isStatic; + this.isClassMethod = codeFrom.isClassMethod; + this.generatedClassConstructor = codeFrom.generatedClassConstructor; + this.classAdjustBlock = codeFrom.classAdjustBlock; + this.declaringClass = codeFrom.declaringClass; this.autoloadVariableName = codeFrom.autoloadVariableName; this.codeObject = codeFrom.codeObject; this.prototype = codeFrom.prototype; @@ -2786,7 +2865,7 @@ public static Class evalStringHelper(RuntimeScalar code, String evalTag, Obje boolean isDebugging = debugFlags != 0; // Always generate a unique filename for each eval to prevent source location collisions - String actualFileName = getNextEvalFilename(); + String actualFileName = getNextEvalFilename(ctx.compilerOptions.fileName); evalCompilerOptions.fileName = actualFileName; warnSignatureArgsInEval(evalString, actualFileName); @@ -3380,7 +3459,7 @@ public static RuntimeList evalStringWithInterpreter( evalCompilerOptions.isByteStringSource = true; } // Always generate a unique filename for each eval to prevent source location collisions - evalCompilerOptions.fileName = getNextEvalFilename(); + evalCompilerOptions.fileName = getNextEvalFilename(ctx.compilerOptions.fileName); warnSignatureArgsInEval(evalString, evalCompilerOptions.fileName); // Setup for BEGIN block support - create aliases for captured variables. @@ -4291,6 +4370,11 @@ private static RuntimeList dispatchPerlMethodAfterSelfInjected( } String methodName = method.toString(); + boolean indirectBlockMethod = methodName.startsWith(INDIRECT_BLOCK_METHOD_PREFIX); + if (indirectBlockMethod) { + methodName = methodName.substring(INDIRECT_BLOCK_METHOD_PREFIX.length()); + method = new RuntimeScalar(methodName); + } RuntimeScalar requestedMethod = method; // Unwrap READONLY_SCALAR for method dispatch. @@ -4333,6 +4417,10 @@ private static RuntimeList dispatchPerlMethodAfterSelfInjected( perlClassName = "IO::File"; ModuleOperators.require(new RuntimeScalar("IO/File.pm")); } else if (!invocant.getDefinedBoolean()) { + if (indirectBlockMethod) { + throw new PerlCompilerException("Can't call method \"" + methodName + + "\" without a package or object reference"); + } throw new PerlCompilerException("Can't call method \"" + methodName + "\" on an undefined value"); } else { perlClassName = invocant.toString(); @@ -4477,7 +4565,13 @@ private static RuntimeList dispatchPerlMethodAfterSelfInjected( qualifiedSuperIndex + "::SUPER::".length()); } } - throw new PerlCompilerException("Can't locate object method \"" + errorMethodName + "\" via package \"" + perlClassName + "\" (perhaps you forgot to load \"" + perlClassName + "\"?)"); + if (ClassRegistry.isClass(perlClassName)) { + throw new PerlCompilerException("Can't locate object method \"" + errorMethodName + + "\" via package \"" + perlClassName + "\""); + } + throw new PerlCompilerException("Can't locate object method \"" + errorMethodName + + "\" via package \"" + perlClassName + "\" (perhaps you forgot to load \"" + + perlClassName + "\"?)"); } } @@ -5528,6 +5622,9 @@ public static RuntimeList apply(RuntimeScalar runtimeScalar, RuntimeArray a, int if (code.compilerSupplier != null) { RuntimeList savedConstantValue = code.constantValue; java.util.List savedAttributes = code.attributes; + boolean savedIsClassMethod = code.isClassMethod; + String savedDeclaringClass = code.declaringClass; + String savedReferenceOriginFqn = code.referenceOriginFqn; code.compilerSupplier.get(); // Reload code from curScalar.value in case it was replaced code = (RuntimeCode) curScalar.value; @@ -5536,6 +5633,13 @@ public static RuntimeList apply(RuntimeScalar runtimeScalar, RuntimeArray a, int code.constantValue = savedConstantValue; } restoreLazyAttributes(code, savedAttributes); + if (savedIsClassMethod) { + code.isClassMethod = true; + code.declaringClass = savedDeclaringClass; + } + if (code.referenceOriginFqn == null) { + code.referenceOriginFqn = savedReferenceOriginFqn; + } } // Check if it's an unfilled forward declaration (not defined) @@ -5572,8 +5676,8 @@ public static RuntimeList apply(RuntimeScalar runtimeScalar, RuntimeArray a, int autoloadPackage = code.stashInstallPackage; autoloadSubName = code.stashInstallSub; } - String subroutineName = autoloadPackage + "::" + autoloadSubName; - if (autoloadPackage != null && autoloadSubName != null && !subroutineName.isEmpty()) { + String autoloadTargetName = autoloadPackage + "::" + autoloadSubName; + if (autoloadPackage != null && autoloadSubName != null && !autoloadTargetName.isEmpty()) { // If this is an imported forward declaration, check AUTOLOAD in the source package FIRST // This matches Perl semantics where imported subs resolve via the exporting package's AUTOLOAD if (code.sourcePackage != null && !code.sourcePackage.equals(code.packageName)) { @@ -5596,7 +5700,7 @@ public static RuntimeList apply(RuntimeScalar runtimeScalar, RuntimeArray a, int // Set $AUTOLOAD — in the package where the AUTOLOAD sub // was compiled, not in the package we looked it up from // (see autoloadVarFor() for details). - getGlobalVariable(autoloadVarFor(autoload, autoloadPackage)).set(subroutineName); + getGlobalVariable(autoloadVarFor(autoload, autoloadPackage)).set(autoloadTargetName); // Call AUTOLOAD (iterative — continue the outer dispatch // loop rather than recursing into apply(), to avoid // Java-stack growth on long AUTOLOAD chains). @@ -5604,17 +5708,18 @@ public static RuntimeList apply(RuntimeScalar runtimeScalar, RuntimeArray a, int continue; } } - if ("tailcall".equals(subroutineName)) { + if (PerlRuntime.current().executionState().tailCallTrampolineDepth > 0) { throw new PerlCompilerException("Goto undefined subroutine &" + code.packageName + "::" + code.subName); } String displayName = code.lexicalForwardGlobPlaceholder && code.subName != null - ? code.subName : subroutineName; + ? code.subName : autoloadTargetName; throw new PerlCompilerException("Undefined subroutine &" + displayName + " called"); } String resolvedSubroutineName = code.packageName != null && code.subName != null ? code.packageName + "::" + code.subName : null; + requireClassMethodInstance(code, curArgs); requireLvalueCallable(code, callContext, resolvedSubroutineName); int effectiveContext = effectiveCallContext(code, callContext); // Look up warning bits for the code's class and push to context stack @@ -5689,7 +5794,12 @@ public static RuntimeList apply(RuntimeScalar runtimeScalar, RuntimeArray a, int // invocation, so enterCall/exitCall depth tracking is // not re-entered (no inTailCallTrampoline bump needed). } else { - if (result instanceof RuntimeControlFlowList) { + if (result instanceof RuntimeControlFlowList flow) { + if (code.classAdjustBlock) { + flow.markClassAdjustOrigin(); + } + handleEscapingLoopControl(result, code.generatedClassConstructor, + code.classAdjustBlock); MyVarCleanupStack.unwindTo(cleanupMark); MortalList.flush(); } @@ -5851,7 +5961,7 @@ public static RuntimeList apply(RuntimeScalar runtimeScalar, RuntimeArray a, int } // If the type is not CODE, throw an exception indicating an invalid state - throw new PerlCompilerException("Not a CODE reference"); + throw invalidCodeReference(curScalar); } // end while(true) } @@ -5865,6 +5975,66 @@ public static RuntimeBase markDirectArrayCallArgument(RuntimeBase argument) { } return argument; } + /** Warn when loop control crosses a subroutine boundary, as Perl does. */ + private static void warnOnEscapingLoopControl(RuntimeControlFlowList flow) { + if (flow.suppressEscapingLoopControlWarning()) { + return; + } + if (!Warnings.warningManager.isWarningEnabled("exiting")) { + return; + } + String operation = flow.getControlFlowType().name().toLowerCase(); + WarnDie.warn(new RuntimeScalar("Exiting subroutine via " + operation), + new RuntimeScalar(" at " + flow.marker.fileName + " line " + + flow.marker.lineNumber)); + } + + public static RuntimeScalar markGeneratedClassConstructor(RuntimeScalar codeRef) { + if (codeRef != null && codeRef.value instanceof RuntimeCode code) { + code.generatedClassConstructor = true; + } + return codeRef; + } + + public static RuntimeScalar markClassAdjustBlock(RuntimeScalar codeRef) { + if (codeRef != null && codeRef.value instanceof RuntimeCode code) { + code.classAdjustBlock = true; + } + return codeRef; + } + + /** + * Apply the subroutine-boundary semantics for loop control that escaped a + * called subroutine. A generated class constructor is a hard boundary: + * its field initializers and ADJUST blocks must not target the caller's + * loop. ADJUST already emitted the exiting-subroutine warning, so carry + * that provenance to avoid issuing it a second time at the constructor. + */ + public static RuntimeList handleEscapingLoopControl( + RuntimeList result, boolean generatedConstructor, boolean classAdjust) { + if (!(result instanceof RuntimeControlFlowList flow)) { + return result; + } + ControlFlowType type = flow.getControlFlowType(); + if (type != ControlFlowType.LAST && type != ControlFlowType.NEXT + && type != ControlFlowType.REDO) { + return result; + } + if (classAdjust) { + flow.markClassAdjustOrigin(); + } + if (!generatedConstructor || !flow.hasClassAdjustOrigin()) { + warnOnEscapingLoopControl(flow); + } + if (generatedConstructor) { + String message = flow.marker.buildErrorMessage(); + if (!message.endsWith(".")) { + message += "."; + } + throw new PerlCompilerException(message + "\n"); + } + return result; + } // Method to apply (execute) a subroutine reference for eval/evalbytes. // Eval STRING must allow next/last/redo to propagate to the enclosing scope. @@ -6017,6 +6187,40 @@ public static RuntimeScalar tryDirectLeafIntegerAddition(RuntimeScalar runtimeSc } // Method to apply (execute) a subroutine reference using native array for parameters + /** + * Invoke a generated direct call while retaining its source location for + * signature validation. Named-signature validation happens before the + * callee body has entered a normal Perl frame, so {@code caller()} alone + * cannot otherwise identify the Perl call site for its diagnostic. + * + *

The synthetic frame is deliberately limited to signature-bearing + * callees. Installing one for every call changes observable {@code caller} + * results in ordinary subroutines.

+ */ + public static RuntimeList applyAtLocation(RuntimeScalar runtimeScalar, String subroutineName, + RuntimeBase[] args, int callContext, + String callerPackage, String callerFile, + int callerLine) { + RuntimeScalar resolved = resolveDirectCallTarget(runtimeScalar, subroutineName); + RuntimeScalar target = resolved; + while (target != null && target.type == RuntimeScalarType.READONLY_SCALAR) { + target = (RuntimeScalar) target.value; + } + if (target == null || target.type != RuntimeScalarType.CODE + || !(target.value instanceof RuntimeCode code) + || (code.signatureNamedParams.isEmpty() + && !"%".equals(code.signatureSlurpySigil))) { + return apply(resolved, subroutineName, args, callContext); + } + + pushSyntheticCallerFrame(callerPackage, callerFile, callerLine, "(signature)"); + try { + return apply(resolved, subroutineName, args, callContext); + } finally { + popSyntheticCallerFrame(); + } + } + public static RuntimeList apply(RuntimeScalar runtimeScalar, String subroutineName, RuntimeBase[] args, int callContext) { runtimeScalar = resolveDirectCallTarget(runtimeScalar, subroutineName); @@ -6076,6 +6280,8 @@ public static RuntimeList apply(RuntimeScalar runtimeScalar, String subroutineNa if (code.compilerSupplier != null) { RuntimeList savedConstantValue = code.constantValue; java.util.List savedAttributes = code.attributes; + boolean savedIsClassMethod = code.isClassMethod; + String savedDeclaringClass = code.declaringClass; code.compilerSupplier.get(); // Reload code from runtimeScalar.value in case it was replaced code = (RuntimeCode) runtimeScalar.value; @@ -6084,6 +6290,10 @@ public static RuntimeList apply(RuntimeScalar runtimeScalar, String subroutineNa code.constantValue = savedConstantValue; } restoreLazyAttributes(code, savedAttributes); + if (savedIsClassMethod) { + code.isClassMethod = true; + code.declaringClass = savedDeclaringClass; + } } // Lazily generate CORE:: subroutine wrappers on first call @@ -6100,6 +6310,7 @@ public static RuntimeList apply(RuntimeScalar runtimeScalar, String subroutineNa } if (code.defined()) { + requireClassMethodInstance(code, a); requireLvalueCallable(code, callContext, subroutineName); int effectiveContext = effectiveCallContext(code, callContext); // Look up warning bits for the code's class and push to context stack @@ -6279,7 +6490,7 @@ public static RuntimeList apply(RuntimeScalar runtimeScalar, String subroutineNa return apply(overloadedCode, subroutineName, args, callContext); } - throw new PerlCompilerException("Not a CODE reference"); + throw invalidCodeReference(runtimeScalar); } /** @@ -6305,8 +6516,14 @@ public static RuntimeList resolveTailCalls(RuntimeList result, int callContext) String namedTarget = cfList.marker.namedTarget; if (namedTarget != null) { codeRef = GlobalVariable.getGlobalCodeRefForFreshLookup(namedTarget); - if (codeRef.type == RuntimeScalarType.CODE && codeRef.value instanceof RuntimeCode code - && !code.defined() && !hasAutoload(code)) { + // A fresh missing stash entry can be represented either by an + // undefined CV or by a plain UNDEF scalar. Both are an + // undefined named goto target; only an undefined CV with an + // available AUTOLOAD is allowed to continue to apply(). + boolean hasTargetAutoload = codeRef.type == RuntimeScalarType.CODE + && codeRef.value instanceof RuntimeCode code + && hasAutoload(code); + if (!isCodeDefined(codeRef) && !hasTargetAutoload) { cleanupTailCallArgs(cfList.marker.ownedArgs); cleanupTailCallCodeRef(cfList.getTailCallCodeRef()); throw new PerlCompilerException("Goto undefined subroutine &" + namedTarget @@ -6410,6 +6627,9 @@ private static RuntimeList applyImpl(RuntimeScalar runtimeScalar, String subrout if (code.compilerSupplier != null) { RuntimeList savedConstantValue = code.constantValue; java.util.List savedAttributes = code.attributes; + boolean savedIsClassMethod = code.isClassMethod; + String savedDeclaringClass = code.declaringClass; + String savedReferenceOriginFqn = code.referenceOriginFqn; code.compilerSupplier.get(); // Reload code from runtimeScalar.value in case it was replaced code = (RuntimeCode) runtimeScalar.value; @@ -6418,6 +6638,13 @@ private static RuntimeList applyImpl(RuntimeScalar runtimeScalar, String subrout code.constantValue = savedConstantValue; } restoreLazyAttributes(code, savedAttributes); + if (savedIsClassMethod) { + code.isClassMethod = true; + code.declaringClass = savedDeclaringClass; + } + if (code.referenceOriginFqn == null) { + code.referenceOriginFqn = savedReferenceOriginFqn; + } } // Lazily generate CORE:: subroutine wrappers on first call @@ -6434,6 +6661,7 @@ private static RuntimeList applyImpl(RuntimeScalar runtimeScalar, String subrout } if (code.defined()) { + requireClassMethodInstance(code, a); requireLvalueCallable(code, callContext, subroutineName); int effectiveContext = effectiveCallContext(code, callContext); // Look up warning bits for the code's class and push to context stack @@ -6601,7 +6829,14 @@ private static RuntimeList applyImpl(RuntimeScalar runtimeScalar, String subrout return apply(overloadedCode, subroutineName, list, callContext); } - throw new PerlCompilerException("Not a CODE reference"); + throw invalidCodeReference(runtimeScalar); + } + + private static PerlCompilerException invalidCodeReference(RuntimeScalar scalar) { + if (scalar.type == RuntimeScalarType.UNDEF) { + return new PerlCompilerException("Can't use an undefined value as a subroutine reference"); + } + return new PerlCompilerException("Not a CODE reference"); } // Handle \$var where $var might be a CODE reference (for lexical subs) @@ -7001,12 +7236,43 @@ protected static void restoreCallerWarningScope(int savedScope) { getGlobalVariable(GlobalContext.WARNING_SCOPE).set(savedScope); } + private static void requireClassMethodInstance(RuntimeCode code, RuntimeArray args) { + if (!code.isClassMethod) { + return; + } + RuntimeScalar self = args.elements.isEmpty() ? null : args.elements.getFirst(); + if (self == null || !RuntimeScalarType.isReference(self) + || !(((RuntimeBase) self.value).blessId != 0)) { + String methodName = code.subName; + if (methodName == null && code.referenceOriginFqn != null) { + int separator = code.referenceOriginFqn.lastIndexOf("::"); + methodName = separator >= 0 + ? code.referenceOriginFqn.substring(separator + 2) + : code.referenceOriginFqn; + } + throw new PerlCompilerException("Cannot invoke method \"" + methodName + + "\" on a non-instance"); + } + String actualClass = NameNormalizer.getBlessStr(((RuntimeBase) self.value).blessId); + if (actualClass.equals(code.declaringClass)) { + return; + } + RuntimeArray isaArgs = new RuntimeArray(); + isaArgs.elements.add(self); + isaArgs.elements.add(new RuntimeScalar(code.declaringClass)); + if (!Universal.isa(isaArgs, RuntimeContextType.SCALAR).scalar().getBoolean()) { + throw new PerlCompilerException("Cannot invoke a method of \"" + code.declaringClass + + "\" on an instance of \"" + actualClass + "\""); + } + } + public RuntimeList apply(RuntimeArray a, int callContext) { if (boundRuntime != null && PerlRuntime.currentOrNull() != boundRuntime) { try (PerlRuntime.Binding ignored = boundRuntime.bind()) { return apply(a, callContext); } } + requireClassMethodInstance(this, a); if (constantValue != null) { requireLvalueCallable(this, callContext, null); return new RuntimeList(constantValue); diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeCodeRuntimeState.java b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeCodeRuntimeState.java index b92832592c..c4a4ba022c 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeCodeRuntimeState.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeCodeRuntimeState.java @@ -35,6 +35,7 @@ public final class RuntimeCodeRuntimeState { private int nextMethodCallsiteId; private int nextRuntimeEvalId = 1; + private final Map nextRuntimeEvalIdsBySource = new HashMap<>(); boolean disassemble = System.getenv("JPERL_DISASSEMBLE") != null; boolean useInterpreter = System.getenv("JPERL_INTERPRETER") != null; boolean lexicalAliasSupportEnabled; @@ -56,6 +57,19 @@ synchronized String nextEvalFilename() { return "(eval " + nextRuntimeEvalId++ + ")"; } + /** + * Allocate an eval filename in the calling source's namespace. Perl's + * {@code (eval N)} labels are local to the file that executes eval STRING: + * evals run while loading another module must not advance the caller's + * visible sequence. + */ + synchronized String nextEvalFilename(String sourceName) { + String source = sourceName == null || sourceName.isEmpty() ? "-" : sourceName; + int nextId = nextRuntimeEvalIdsBySource.getOrDefault(source, 1); + nextRuntimeEvalIdsBySource.put(source, nextId + 1); + return "(eval " + nextId + ")"; + } + /** * Copy immutable compile-time descriptors referenced by cloned CODE objects. * Runtime eval results, generated-class caches, inline caches, and allocation diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeControlFlowList.java b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeControlFlowList.java index 2849537267..e2f053145e 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeControlFlowList.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeControlFlowList.java @@ -1,5 +1,7 @@ package org.perlonjava.runtime.runtimetypes; +import org.perlonjava.runtime.perlmodule.Warnings; + /** * A specialized RuntimeList that carries control flow information. * This is returned by control flow statements (last/next/redo/goto/goto &NAME) @@ -19,6 +21,15 @@ public class RuntimeControlFlowList extends RuntimeList { * Null for all other control flow types. */ public final RuntimeBase returnValue; + /** True when this loop-control marker escaped a class ADJUST block. */ + private boolean classAdjustOrigin; + /** + * A localized false {@code $^W} suppresses the warning that Perl would + * otherwise issue when this marker crosses a subroutine boundary. Capture + * it while the marker is created: the {@code local} scope is unwound before + * the caller dispatches the marker. + */ + private final boolean suppressEscapingLoopControlWarning; /** * Constructor for control flow (last/next/redo/goto). @@ -38,6 +49,8 @@ public RuntimeControlFlowList(ControlFlowType type, String label, String fileNam super(); this.marker = new ControlFlowMarker(type, label, fileName, lineNumber, evalScope); this.returnValue = null; + this.suppressEscapingLoopControlWarning = Warnings.isWarnFlagLocalized() + && !Warnings.isWarnFlagSet(); if (DEBUG_TAILCALL) { System.err.println("[DEBUG-0a] RuntimeControlFlowList constructor (type,label): type=" + type + ", label=" + label + " @ " + fileName + ":" + lineNumber); @@ -76,6 +89,7 @@ public RuntimeControlFlowList(RuntimeScalar codeRef, RuntimeArray args, String f this.marker = new ControlFlowMarker(retainTailCallCodeRef(codeRef), args, fileName, lineNumber, namedTarget, evalScope); this.returnValue = null; + this.suppressEscapingLoopControlWarning = false; if (DEBUG_TAILCALL) { System.err.println("[DEBUG-0b] RuntimeControlFlowList constructor (codeRef,args): codeRef=" + codeRef + ", args.size=" + (args != null ? args.size() : "null") + @@ -102,6 +116,7 @@ public RuntimeControlFlowList(RuntimeBase returnValue, String fileName, int line super(); this.marker = new ControlFlowMarker(ControlFlowType.RETURN, null, fileName, lineNumber); this.returnValue = returnValue; + this.suppressEscapingLoopControlWarning = false; } /** @@ -113,6 +128,18 @@ public RuntimeBase getReturnValue() { return returnValue; } + public void markClassAdjustOrigin() { + classAdjustOrigin = true; + } + + public boolean hasClassAdjustOrigin() { + return classAdjustOrigin; + } + + public boolean suppressEscapingLoopControlWarning() { + return suppressEscapingLoopControlWarning; + } + /** * Create a RuntimeControlFlowList from a registry action code. * Used by emitControlFlowCheck to convert registry action to marked list. diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeGlob.java b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeGlob.java index 78de42cfb6..ee4c371774 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeGlob.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeGlob.java @@ -1,5 +1,6 @@ package org.perlonjava.runtime.runtimetypes; +import org.perlonjava.runtime.HintHashRegistry; import org.perlonjava.runtime.io.ClosedIOHandle; import org.perlonjava.runtime.mro.InheritanceResolver; import org.perlonjava.runtime.operators.WarnDie; @@ -128,6 +129,11 @@ private static boolean isStashGlobName(String name) { return name != null && name.endsWith("::"); } + /** `*^H` may reach the runtime with or without its implicit main:: prefix. */ + private static boolean isHintsGlobName(String name) { + return name != null && (name.endsWith("\b") || name.endsWith("^H")); + } + /** * Creates a detached copy of this glob that has its own independent IO slot. * @@ -693,6 +699,11 @@ public RuntimeScalar set(RuntimeScalar value) { case HASHREFERENCE: // `*foo = \%bar` creates an alias - both names refer to the same hash // Also update all glob aliases + int hashBlessId = RuntimeScalarType.blessedId(value); + if (hashBlessId != 0 + && ClassRegistry.isClass(NameNormalizer.getBlessStr(hashBlessId))) { + throw new PerlCompilerException("Can't assign reference to OBJECT into a GLOB"); + } if (value.value instanceof RuntimeHash hash) { // `*Clone:: = \%Outer::` is the stash-reference spelling // of a package alias. Sharing the HASH slot alone is not @@ -721,6 +732,11 @@ public RuntimeScalar set(RuntimeScalar value) { // the existing scalar, otherwise tied scalars would invoke STORE. // Note: \@array and \%hash come in as ARRAYREFERENCE/HASHREFERENCE types, // not REFERENCE, so they are handled above in their respective cases. + int blessId = RuntimeScalarType.blessedId(value); + if (blessId != 0 + && ClassRegistry.isClass(NameNormalizer.getBlessStr(blessId))) { + throw new PerlCompilerException("Can't assign reference to OBJECT into a GLOB"); + } if (value.value instanceof RuntimeScalar) { // Update all glob aliases so that earlier `*A = *B` // (which makes A and B share their SCALAR slot) keeps both @@ -1589,6 +1605,9 @@ public RuntimeArray setArrayOfAlias(RuntimeArray arr) { * @return The current RuntimeGlob instance after undefining its elements. */ public RuntimeGlob undefine() { + if (isHintsGlobName(this.globName)) { + HintHashRegistry.clearCurrentHintHash(); + } if (isStashGlobName(this.globName)) { // `undef *Pkg::` removes the stash slot from the parent package but // does not anonymize previously-blessed objects (Perl semantics: old @@ -1627,7 +1646,12 @@ public RuntimeGlob undefine() { // the referent outlives the typeglob, so re-installing the saved // reference restores the original value (Symbol::Util::delete_glob). RuntimeScalar oldScalar = GlobalVariable.globalVariables.get(this.globName); + if (oldScalar instanceof ScalarSpecialVariable special + && special.variableId == ScalarSpecialVariable.Id.HINTS) { + HintHashRegistry.clearCurrentHintHash(); + } if (oldScalar != null && !(oldScalar instanceof RuntimeScalarReadOnly) + && !(oldScalar instanceof ScalarSpecialVariable) && !oldScalar.referencedByScalarReference) { oldScalar.undefine(); } diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeGraphCloner.java b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeGraphCloner.java index 53446cf17b..aa05fb7701 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeGraphCloner.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeGraphCloner.java @@ -813,6 +813,7 @@ private void copyScalarMetadata(RuntimeScalar source, RuntimeScalar target) { target.tainted = source.tainted; target.globalCodeRefFqn = source.globalCodeRefFqn; target.lexicalSubName = source.lexicalSubName; + target.lexicalDisplayName = source.lexicalDisplayName; target.lexicalSubPackageName = source.lexicalSubPackageName; target.lexicalSubPackageCodeDefinedAtDeclaration = source.lexicalSubPackageCodeDefinedAtDeclaration; diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeHash.java b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeHash.java index 251476c947..51ad718e7b 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeHash.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeHash.java @@ -1374,6 +1374,9 @@ public RuntimeBase keys(int ctx) { RuntimeArray keyList = keys(); return new RuntimeScalar(keyList.scalarContextSize); } + if (this.elements.isEmpty()) { + return RuntimeScalarCache.scalarZero; + } return new RuntimeScalar(this.size()); } return keys(); diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeIO.java b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeIO.java index 6c1669799a..f950bb275a 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeIO.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeIO.java @@ -112,6 +112,9 @@ public class RuntimeIO extends RuntimeScalar { public static RuntimeIO getLastReadlineHandle() { return lastReadlineHandle.get(); } public static void setLastReadlineHandle(RuntimeIO io) { lastReadlineHandle.set(io); } + /** Clear the per-thread readline fallback before an embedded script starts. */ + public static void resetLastReadlineHandle() { lastReadlineHandle.remove(); } + private boolean ioError; // An anonymous lexical handle has no glob name. Preserve the source // expression used for its most recent readline so later warn/die context diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeScalar.java b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeScalar.java index c5840f9e7a..f440c8bc88 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeScalar.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeScalar.java @@ -44,6 +44,15 @@ public static void rejectLocalizeThroughReference(RuntimeScalar source) { } } + public static void rejectLocalizeThroughReference() { + throw new PerlCompilerException("Can't localize through a reference"); + } + + /** Reject localization with a source location captured by the JVM emitter. */ + public static void rejectLocalizeThroughReference(String message) { + throw new PerlCompilerException(message); + } + /** * Deferred storage for a plain string being grown with repeated {@code .=}. @@ -281,6 +290,9 @@ void clearForArraySlotRemoval() { */ public String lexicalSubName; + /** Source spelling retained for diagnostics that operate on a lexical scalar. */ + public String lexicalDisplayName; + /** Package containing {@link #lexicalSubName} for an eval-filled forward declaration. */ public String lexicalSubPackageName; @@ -617,6 +629,12 @@ public RuntimeScalar(boolean value) { this.value = value; } + /** Attach the source-level lexical name used by handle diagnostics. */ + public RuntimeScalar setLexicalDisplayName(String name) { + this.lexicalDisplayName = name; + return this; + } + public RuntimeScalar(Boolean value) { this.type = RuntimeScalarType.BOOLEAN; this.value = value; @@ -647,6 +665,7 @@ public RuntimeScalar(RuntimeScalar scalar) { this.firstClassRegexScalar = scalar.firstClassRegexScalar; this.formatPictureTainted = scalar.formatPictureTainted; this.lexicalSubName = scalar.lexicalSubName; + this.lexicalDisplayName = scalar.lexicalDisplayName; this.lexicalSubPackageName = scalar.lexicalSubPackageName; this.lexicalSubPackageCodeDefinedAtDeclaration = scalar.lexicalSubPackageCodeDefinedAtDeclaration; Object argumentFrame = RuntimeCode.currentArgumentAliasFrame(scalar); @@ -739,6 +758,7 @@ public RuntimeScalar(Object value) { this.firstClassRegexScalar = scalar.firstClassRegexScalar; this.formatPictureTainted = scalar.formatPictureTainted; this.lexicalSubName = scalar.lexicalSubName; + this.lexicalDisplayName = scalar.lexicalDisplayName; this.lexicalSubPackageName = scalar.lexicalSubPackageName; this.lexicalSubPackageCodeDefinedAtDeclaration = scalar.lexicalSubPackageCodeDefinedAtDeclaration; } @@ -3247,6 +3267,36 @@ public RuntimeScalar scalarDeref() { }; } + /** + * Dereference a foreach declared-reference iterator value without the + * ordinary dereference operators' autovivification semantics. + */ + public RuntimeScalar foreachScalarReference() { + requireForeachReference(REFERENCE, "SCALAR"); + return (RuntimeScalar) value; + } + + public RuntimeArray foreachArrayReference() { + requireForeachReference(ARRAYREFERENCE, "ARRAY"); + return (RuntimeArray) value; + } + + public RuntimeHash foreachHashReference() { + requireForeachReference(HASHREFERENCE, "HASH"); + return (RuntimeHash) value; + } + + private void requireForeachReference(int expectedType, String expectedName) { + if (!RuntimeScalarType.isReference(this)) { + throw new PerlCompilerException("Assigned value is not a reference"); + } + if (type != expectedType) { + String article = expectedName.equals("ARRAY") ? "an" : "a"; + throw new PerlCompilerException("Assigned value is not " + article + " " + + expectedName + " reference"); + } + } + // Method to implement `$$v`, when "no strict refs" is in effect public RuntimeScalar scalarDerefNonStrict(String packageName) { // Check if object is eligible for overloading diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeScalarReadOnly.java b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeScalarReadOnly.java index b1097d1eaa..ca516d80e9 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeScalarReadOnly.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeScalarReadOnly.java @@ -248,7 +248,7 @@ public RuntimeHash hashDeref() { || this.type == STRING || this.type == BYTE_STRING) { throw new PerlCompilerException("Can't use string (\"" + this + "\") as a HASH ref while \"strict refs\" in use"); } - throw new PerlCompilerException("Can't use value as a HASH reference"); + throw new PerlCompilerException("Can't use an undefined value as a HASH reference"); } /** @@ -315,6 +315,6 @@ public RuntimeHash hashDerefNonStrict(String packageName) { if (this.type == UNDEF) { throw new PerlCompilerException("Can't use an undefined value as a HASH reference"); } - throw new PerlCompilerException("Can't use value as a HASH reference"); + throw new PerlCompilerException("Can't use an undefined value as a HASH reference"); } } diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeSigHash.java b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeSigHash.java index 4d79384a80..299519c6a0 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeSigHash.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeSigHash.java @@ -3,6 +3,9 @@ import java.util.List; import java.util.Set; +import org.perlonjava.runtime.operators.WarnDie; +import org.perlonjava.runtime.perlmodule.Warnings; + import static org.perlonjava.runtime.runtimetypes.RuntimeScalarType.*; /** @@ -89,6 +92,30 @@ public RuntimeSigHash() { } } + /** + * Warn for unknown OS signal names but retain their slots, as Perl does. + * Underscore-prefixed entries are Perl hooks and remain an error when + * unrecognized. + */ + @Override + public void put(String key, RuntimeScalar value) { + if (!KNOWN_SIGNALS.contains(key)) { + String visibleKey = key.replace("\0", "\\0"); + int nulIndex = key.indexOf('\0'); + String baseSignal = nulIndex >= 0 ? key.substring(0, nulIndex) : key; + if (baseSignal.startsWith("_")) { + throw new PerlCompilerException("No such hook: " + visibleKey); + } + // A malformed OS signal name is a Perl warning, routed through + // __WARN__, but its hash entry remains usable. Signal extensions + // rely on this behavior when warnings are locally disabled. + if (Warnings.warningManager.isWarningEnabled("signal")) { + WarnDie.warn(new RuntimeScalar("No such signal: SIG" + visibleKey), new RuntimeScalar()); + } + } + super.put(key, value); + } + /** * Get an element by key, auto-qualifying string handler values for known signals. */ diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/ScalarSpecialVariable.java b/src/main/java/org/perlonjava/runtime/runtimetypes/ScalarSpecialVariable.java index 002c404c4d..13aa12893c 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/ScalarSpecialVariable.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/ScalarSpecialVariable.java @@ -1,5 +1,6 @@ package org.perlonjava.runtime.runtimetypes; +import org.perlonjava.runtime.HintHashRegistry; import org.perlonjava.frontend.parser.SpecialBlockParser; import org.perlonjava.frontend.semantic.ScopedSymbolTable; import org.perlonjava.runtime.nativ.NativeUtils; @@ -130,9 +131,33 @@ public RuntimeScalar set(RuntimeScalar value) { } return value; } + if (variableId == Id.REMOVED_ENCODING) { + if (value != null && value.getDefinedBoolean()) { + throw new PerlCompilerException("${^ENCODING} is no longer supported"); + } + return scalarUndef; + } return super.set(value); } + /** + * {@code undef *^H} reaches the magic hints scalar through the generic + * undef-list path. Unlike {@code undef $^H}, it removes the lexical hint + * hash as well as resetting the public numeric hints value. + */ + @Override + public RuntimeScalar undefine() { + if (variableId == Id.HINTS) { + HintHashRegistry.clearCurrentHintHash(); + ScopedSymbolTable symbolTable = SpecialBlockParser.getCurrentScope(); + if (symbolTable != null) { + symbolTable.setStrictOptions(0); + } + return scalarUndef; + } + return super.undefine(); + } + // Add itself to a RuntimeArray. public void addToArray(RuntimeArray array) { array.elements.add(new RuntimeScalar(this.getValueAsScalar())); @@ -292,6 +317,7 @@ public RuntimeScalar getValueAsScalar() { } yield scalarUndef; } + case REMOVED_ENCODING -> scalarUndef; case EVAL_STATE -> { // $^S - Current state of the interpreter // undef = parsing/compiling (BEGIN blocks) @@ -558,6 +584,7 @@ public enum Id { 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 + REMOVED_ENCODING, // ${^ENCODING} - accepts undef but rejects defined values EVAL_STATE, // $^S - Current state of the interpreter (undef=compiling, 0=not in eval, 1=in eval) } diff --git a/src/test/java/org/perlonjava/PerlScriptExecutionTest.java b/src/test/java/org/perlonjava/PerlScriptExecutionTest.java index bb007fb1bf..c09321dc52 100644 --- a/src/test/java/org/perlonjava/PerlScriptExecutionTest.java +++ b/src/test/java/org/perlonjava/PerlScriptExecutionTest.java @@ -313,6 +313,7 @@ void testAllTests(String filename) { */ private void executeTest(String filename) { // Load the Perl script as an InputStream + URL resourceUrl = getClass().getClassLoader().getResource(filename); InputStream inputStream = getClass().getClassLoader().getResourceAsStream(filename); assertNotNull(inputStream, "Resource file not found: " + filename); @@ -329,7 +330,9 @@ private void executeTest(String filename) { } CompilerOptions options = new CompilerOptions(); options.code = content; // Set the code to be executed - options.fileName = filename; // Set the filename for reference + options.fileName = resourceUrl != null && resourceUrl.getProtocol().equals("file") + ? Paths.get(resourceUrl.toURI()).toString() + : filename; // Add the path to the Perl modules RuntimeArray.push(options.inc, new RuntimeScalar("src/main/perl/lib")); diff --git a/src/test/resources/unit/adjacent_incomplete_base_literal_diagnostic.t b/src/test/resources/unit/adjacent_incomplete_base_literal_diagnostic.t new file mode 100644 index 0000000000..c7fee48d52 --- /dev/null +++ b/src/test/resources/unit/adjacent_incomplete_base_literal_diagnostic.t @@ -0,0 +1,28 @@ +use strict; +use warnings; +use Test::More; +use IPC::Open3 qw(open3); +use Symbol qw(gensym); + +for my $case ( + [ '0 0x@', '0x', 'hexadecimal' ], + [ '1 0b@', '0b', 'binary' ], +) { + my ($source, $literal, $kind) = @$case; + my $launcher = $^X eq 'jperl' ? './jperl' : $^X; + my $stderr = gensym; + my $pid = open3(undef, my $stdout, $stderr, $launcher, '-e', $source); + my $output = do { local $/; <$stdout> } . do { local $/; <$stderr> }; + waitpid $pid, 0; + + my ($left) = $source =~ /\A(\d+)/; + my $near = "$left $literal"; + is($output, + "Number found where operator expected (Missing operator before \"$literal\"?) at -e line 1, near \"$near\"\n" + . "No digits found for $kind literal at -e line 1, near \"$near\@\"\n" + . "syntax error at -e line 1, near \"$near\"\n" + . "Execution of -e aborted due to compilation errors.\n", + 'adjacent number and incomplete base literal retain all diagnostics'); +} + +done_testing; diff --git a/src/test/resources/unit/aggregate_bareword_argument.t b/src/test/resources/unit/aggregate_bareword_argument.t new file mode 100644 index 0000000000..2bde199011 --- /dev/null +++ b/src/test/resources/unit/aggregate_bareword_argument.t @@ -0,0 +1,10 @@ +use Test::More; + +for my $operator (qw(keys values each)) { + my $ok = eval "$operator FRED"; + ok(!$ok, "$operator rejects a bareword argument"); + like($@, qr/Type of arg 1 to $operator must be hash or array \(not constant item\)/, + "$operator reports the argument type"); +} + +done_testing; diff --git a/src/test/resources/unit/aggregate_bitwise_assignment_error.t b/src/test/resources/unit/aggregate_bitwise_assignment_error.t new file mode 100644 index 0000000000..0cdb6d7a03 --- /dev/null +++ b/src/test/resources/unit/aggregate_bitwise_assignment_error.t @@ -0,0 +1,17 @@ +use Test::More; + +for my $case ( + ['@a &= 1', 'numeric bitwise and (&)'], + ['@a |= 1', 'numeric bitwise or (|)'], + ['@a ^= 1', 'numeric bitwise xor (^)'], + ['@a &.= 1', 'string bitwise and (&.)'], + ['@a |.= 1', 'string bitwise or (|.)'], + ['@a ^.= 1', 'string bitwise xor (^.)'], +) { + my $ok = eval "use feature 'bitwise'; $case->[0];"; + ok(!$ok, "$case->[0] is rejected"); + like($@, qr/Can't modify array dereference in \Q$case->[1]\E/, + 'reports the aggregate bitwise diagnostic'); +} + +done_testing; diff --git a/src/test/resources/unit/aggregate_substr_vec_assignment_error.t b/src/test/resources/unit/aggregate_substr_vec_assignment_error.t new file mode 100644 index 0000000000..3d510d6ba8 --- /dev/null +++ b/src/test/resources/unit/aggregate_substr_vec_assignment_error.t @@ -0,0 +1,15 @@ +use Test::More; + +for my $case ( + ['substr(%h, 0) = 3', 'substr'], + ['(substr %h, 0) = 3', 'substr'], + ['vec(%h, 1, 1) = 3', 'vec'], + ['(vec %h, 1, 1) = 3', 'vec'], +) { + my $ok = eval $case->[0]; + ok(!$ok, "$case->[0] is rejected"); + like($@, qr/Can't modify hash dereference in \Q$case->[1]\E/, + 'reports the aggregate lvalue diagnostic'); +} + +done_testing; diff --git a/src/test/resources/unit/all_any_require_block.t b/src/test/resources/unit/all_any_require_block.t new file mode 100644 index 0000000000..e53cd650f7 --- /dev/null +++ b/src/test/resources/unit/all_any_require_block.t @@ -0,0 +1,10 @@ +use Test::More; + +for my $operator (qw(all any)) { + my $ok = eval "use feature 'keyword_$operator'; $operator length, qw(a b c)"; + ok(!$ok, "$operator requires a block"); + like($@, qr/syntax error/, "$operator reports a syntax error"); + like($@, qr/near \"$operator length\"/, "$operator anchors the error at the keyword"); +} + +done_testing; diff --git a/src/test/resources/unit/apostrophe_package_separator_feature.t b/src/test/resources/unit/apostrophe_package_separator_feature.t new file mode 100644 index 0000000000..520f47d001 --- /dev/null +++ b/src/test/resources/unit/apostrophe_package_separator_feature.t @@ -0,0 +1,26 @@ +use strict; +use warnings; +use Test::More; +use IPC::Open3 qw(open3); +use Symbol qw(gensym); + +for my $case ( + ["no feature 'apostrophe_as_package_separator';\nsub 'Hello'_he_said (_);", + qr/(?:Bareword found where operator expected \(Missing operator before "_he_said"\?\) at - line 2, near "'Hello'_he_said"\n)?Illegal declaration of anonymous subroutine at - line 2(?:, near "sub 'Hello'")?/, + 'subroutine name'], + ["no feature 'apostrophe_as_package_separator';\nformat 'one =\nok \@<< - format 'foo still works\n\$test\n.", + qr/syntax error at - line 3, near "ok \@<< - format '"\n \(Might be a runaway multi-line '' string starting on line 2\)/, + 'format name'], +) { + my ($source, $expected, $name) = @$case; + my $launcher = $^X eq 'jperl' ? './jperl' : $^X; + my $stderr = gensym; + my $pid = open3(my $stdin, my $stdout, $stderr, $launcher, '-'); + print {$stdin} $source; + close $stdin; + my $output = do { local $/; <$stdout> } . do { local $/; <$stderr> }; + waitpid $pid, 0; + like($output, $expected, "disabled apostrophe package separator rejects $name"); +} + +done_testing; diff --git a/src/test/resources/unit/array_operation_argument_error.t b/src/test/resources/unit/array_operation_argument_error.t new file mode 100644 index 0000000000..383b435890 --- /dev/null +++ b/src/test/resources/unit/array_operation_argument_error.t @@ -0,0 +1,46 @@ +use Test::More; + +for my $case ( + ['push %a, 1', 'push', 'hash dereference'], + ['pop %a', 'pop', 'hash dereference'], + ['shift %a', 'shift', 'hash dereference'], + ['unshift %a, 1', 'unshift', 'hash dereference'], + ['push *a, 1', 'push', 'ref-to-glob cast'], + ['pop *a', 'pop', 'ref-to-glob cast'], + ['shift *a', 'shift', 'ref-to-glob cast'], + ['unshift *a, 1', 'unshift', 'ref-to-glob cast'], +) { + my $ok = eval "$case->[0]; 1"; + ok(!$ok, "$case->[0] is rejected"); + like($@, qr/Type of arg 1 to \Q$case->[1]\E must be array \(not \Q$case->[2]\E\)/, + 'reports the operand category'); +} + +for my $case ( + ['push %a, 1', 'push'], + ['pop %a', 'pop'], + ['shift %a', 'shift'], + ['unshift %a, 1', 'unshift'], +) { + my $ok = eval "my %a; $case->[0]; 1"; + ok(!$ok, "lexical $case->[0] is rejected"); + like($@, qr/Type of arg 1 to \Q$case->[1]\E must be array \(not private hash\)/, + 'reports the private hash category'); +} + +my $multiple = eval q{ + push %a, 1; + pop %a; + shift %a; + unshift %a, 1; + push *a, 1; + pop *a; + shift *a; + unshift *a, 1; + 1; +}; +ok(!$multiple, 'multiple invalid array operations are rejected together'); +is(scalar(() = $@ =~ /Type of arg 1 to (?:push|pop|shift|unshift) must be array/g), 8, + 'reports every invalid array operation in one compilation'); + +done_testing; diff --git a/src/test/resources/unit/array_unary_bareword.t b/src/test/resources/unit/array_unary_bareword.t new file mode 100644 index 0000000000..e50c50c3ab --- /dev/null +++ b/src/test/resources/unit/array_unary_bareword.t @@ -0,0 +1,10 @@ +use Test::More; + +for my $operator (qw(pop shift)) { + my $ok = eval "$operator FRED; 1"; + ok(!$ok, "$operator rejects a bareword argument"); + like($@, qr/Type of arg 1 to \Q$operator\E must be array \(not constant item\)/, + "$operator reports the array-argument diagnostic"); +} + +done_testing; diff --git a/src/test/resources/unit/bare_heredoc_diagnostic.t b/src/test/resources/unit/bare_heredoc_diagnostic.t new file mode 100644 index 0000000000..e1a8ae1450 --- /dev/null +++ b/src/test/resources/unit/bare_heredoc_diagnostic.t @@ -0,0 +1,17 @@ +use strict; +use warnings; +use Test::More; + +for my $source ( + q{$a = <<;}, + q{$a = <<~;}, + q{$a = <<~ ;}, +) { + my $result = eval $source; + ok(!defined $result, 'bare heredoc marker fails'); + like($@, + qr{\AUse of bare << to mean <<"" is forbidden at \(eval \d+\) line 1\.\n?\z}, + 'bare heredoc diagnostic has no parser excerpt'); +} + +done_testing; diff --git a/src/test/resources/unit/bless_reference_class_error.t b/src/test/resources/unit/bless_reference_class_error.t new file mode 100644 index 0000000000..1e7f736764 --- /dev/null +++ b/src/test/resources/unit/bless_reference_class_error.t @@ -0,0 +1,14 @@ +use Test::More; + +for my $source ( + q{bless {}, []}, + q{my $class = []; bless {}, $class}, + q{sub f {} bless [], bless []}, + q{sub TIESCALAR { bless [] } sub FETCH { [] } tie my $class, ''; bless {}, $class}, +) { + my $ok = eval $source; + ok(!$ok, 'bless rejects a reference class name'); + like($@, qr/Attempt to bless into a reference/, 'reports Perl-compatible diagnostic'); +} + +done_testing; diff --git a/src/test/resources/unit/class_bless_constraints.t b/src/test/resources/unit/class_bless_constraints.t new file mode 100644 index 0000000000..7394de7a37 --- /dev/null +++ b/src/test/resources/unit/class_bless_constraints.t @@ -0,0 +1,59 @@ +use strict; +use warnings; +use Test::More; +use feature 'class'; +no warnings 'experimental::class'; + +class BlessConstraints {} + +my $ok = eval { bless [], 'BlessConstraints'; 1 }; +ok(!$ok, 'bless into a class is rejected'); +like($@, qr/Attempt to bless into a class/, 'class blessing has Perl diagnostic'); + +my $instance = BlessConstraints->new; +isa_ok($instance, 'BlessConstraints', 'generated constructor can create a class instance'); + +my $rebless_ok = eval { bless $instance, 'main'; 1 }; +ok(!$rebless_ok, 'reblessing a class instance is rejected'); +like($@, qr/Can't bless an object reference/, 'class instance reblessing has Perl diagnostic'); + +my $reopen_ok = eval q{ + class BlessConstraints {} + 1; +}; +ok(!$reopen_ok, 'a class cannot be reopened'); +like($@, qr/Cannot reopen existing class "BlessConstraints"/, 'class reopening has Perl diagnostic'); + +my $bad_reader_ok = eval q{ + class BadReaderAccessor { field $value :reader(not-valid) } + 1; +}; +ok(!$bad_reader_ok, 'invalid reader method name is rejected'); +like($@, qr/"not-valid" is not a valid name for a generated method/, + 'reader diagnostic identifies invalid method name'); + +my $bad_writer_ok = eval q{ + class BadWriterAccessor { field $value :writer(not-valid) } + 1; +}; +ok(!$bad_writer_ok, 'invalid writer method name is rejected'); +like($@, qr/"not-valid" is not a valid name for a generated method/, + 'writer diagnostic identifies invalid method name'); + +my $array_writer_ok = eval q{ + class ArrayWriterAccessor { field @value :writer } + 1; +}; +ok(!$array_writer_ok, 'writer on an array field is rejected'); +like($@, qr/Cannot apply a :writer attribute to a non-scalar field/, + 'array writer has Perl diagnostic'); + +my $hash_writer_ok = eval q{ + class HashWriterAccessor { field %value :writer } + 1; +}; +ok(!$hash_writer_ok, 'writer on a hash field is rejected'); +like($@, qr/Cannot apply a :writer attribute to a non-scalar field/, + 'hash writer has Perl diagnostic'); + +done_testing; diff --git a/src/test/resources/unit/class_class_constant_context.t b/src/test/resources/unit/class_class_constant_context.t new file mode 100644 index 0000000000..004b4de69a --- /dev/null +++ b/src/test/resources/unit/class_class_constant_context.t @@ -0,0 +1,25 @@ +use strict; +use warnings; +use Test::More; +use feature 'class'; +no warnings 'experimental::class'; + +my $outside = eval q{ + class ClassConstantContext { + my $name = __CLASS__; + } + 1; +}; +ok(!$outside, '__CLASS__ is rejected in ordinary class-body code'); +like($@, qr/Cannot use __CLASS__ outside of a method or field initializer expression/, + 'ordinary class-body __CLASS__ has the Perl diagnostic'); + +my $method = eval q{ + class ClassConstantMethod { + method name { __CLASS__ } + } + ClassConstantMethod->new->name eq 'ClassConstantMethod'; +}; +ok($method, '__CLASS__ remains available in a method'); + +done_testing; diff --git a/src/test/resources/unit/class_direct_method_invocant.t b/src/test/resources/unit/class_direct_method_invocant.t new file mode 100644 index 0000000000..3a531bf04f --- /dev/null +++ b/src/test/resources/unit/class_direct_method_invocant.t @@ -0,0 +1,21 @@ +use strict; +use warnings; +use Test::More; + +use feature 'class'; +no warnings 'experimental::class'; + +class DirectMethodInvocant { + method instance_only { 'unreachable' } + sub class_helper { 'class helper' } +} + +my $ok = eval { DirectMethodInvocant::instance_only(); 1 }; +ok(!$ok, 'a class method rejects a direct call without an instance'); +like($@, qr/Cannot invoke method "instance_only" on a non-instance/, + 'direct class-method call reports the Perl-compatible diagnostic'); + +is(DirectMethodInvocant->class_helper, 'class helper', + 'an ordinary sub declared in a class remains callable as a class helper'); + +done_testing; diff --git a/src/test/resources/unit/class_field_initializer_goto.t b/src/test/resources/unit/class_field_initializer_goto.t new file mode 100644 index 0000000000..d2a43149c7 --- /dev/null +++ b/src/test/resources/unit/class_field_initializer_goto.t @@ -0,0 +1,17 @@ +use strict; +use warnings; +use feature 'class'; +no warnings 'experimental::class'; +use Test::More; + +class FieldInitializerGoto { + field $forward = do { goto FORWARD; FORWARD: 1 }; + field $backward = do { my $seen; BACKWARD: goto BACKWARD if !$seen++; 2 }; + + method values { return ($forward, $backward) } +} + +is_deeply [FieldInitializerGoto->new->values], [1, 2], + 'field initializer do blocks permit local forward and backward goto'; + +done_testing; diff --git a/src/test/resources/unit/class_field_initializer_strict_self.t b/src/test/resources/unit/class_field_initializer_strict_self.t new file mode 100644 index 0000000000..572cb24746 --- /dev/null +++ b/src/test/resources/unit/class_field_initializer_strict_self.t @@ -0,0 +1,18 @@ +use strict; +use warnings; +use Test::More; +use feature 'class'; +no warnings 'experimental::class'; + +my $ok = eval q{ + class FieldInitializerStrictSelf { + field $value = $self + 1; + } + 1; +}; + +ok(!$ok, 'field initializers do not expose a user lexical $self'); +like($@, qr/Global symbol "\$self" requires explicit package name/, + 'strict-vars diagnostic is retained for $self in a field initializer'); + +done_testing; diff --git a/src/test/resources/unit/class_field_scope_errors.t b/src/test/resources/unit/class_field_scope_errors.t new file mode 100644 index 0000000000..44dd9a1036 --- /dev/null +++ b/src/test/resources/unit/class_field_scope_errors.t @@ -0,0 +1,42 @@ +use strict; +use warnings; +use Test::More; +use feature 'class'; +no warnings 'experimental::class'; + +my $outside_method = eval q{ + class FieldScopeOutsideMethod { + field $value; + $value = 1; + } + 1; +}; +ok(!$outside_method, 'a field cannot be used in class-body code'); +like($@, qr/Field \$value is not accessible outside a method/, + 'class-body field use has the Perl diagnostic'); + +my $regular_sub = eval q{ + class FieldScopeRegularSub { + field $value; + sub use_value { $value } + } + 1; +}; +ok(!$regular_sub, 'a field cannot be used in a regular subroutine'); +like($@, qr/Field \$value is not accessible outside a method/, + 'regular-sub field use has the Perl diagnostic'); + +my $nested_class = eval q{ + class FieldScopeOuter { + field $value; + class FieldScopeInner { + method use_value { $value } + } + } + 1; +}; +ok(!$nested_class, 'a nested class does not inherit its enclosing class fields'); +like($@, qr/Field \$value of "FieldScopeOuter" is not accessible in a method of "FieldScopeInner"/, + 'nested-class field use identifies both classes'); + +done_testing; diff --git a/src/test/resources/unit/class_global_field_error.t b/src/test/resources/unit/class_global_field_error.t new file mode 100644 index 0000000000..29ae1559e8 --- /dev/null +++ b/src/test/resources/unit/class_global_field_error.t @@ -0,0 +1,21 @@ +use Test::More; + +BEGIN { + plan skip_all => 'requires Perl 5.44 class syntax' if $] < 5.044; +} + +use v5.44; +use experimental 'class'; + +my $ok = eval q{ + class GlobalFieldError { + field $_; + } + 1; +}; + +ok(!$ok, 'global $_ cannot be declared as a class field'); +like($@, qr/Can't use global \$_ in "field"/, 'reports the class-field diagnostic'); +like($@, qr/near "field \$_"/, 'diagnostic includes the complete field declaration'); + +done_testing; diff --git a/src/test/resources/unit/class_hierarchical_parent_loading.t b/src/test/resources/unit/class_hierarchical_parent_loading.t new file mode 100644 index 0000000000..2150eda6e2 --- /dev/null +++ b/src/test/resources/unit/class_hierarchical_parent_loading.t @@ -0,0 +1,12 @@ +use strict; +use warnings; +use feature 'class'; +no warnings 'experimental::class'; +use Test::More; + +use lib 'perl5_t/t/lib/class'; +use A::B; + +ok(A::B->new->isa('A'), 'loading a nested class loads its enclosing :isa class'); + +done_testing; diff --git a/src/test/resources/unit/class_incomplete_constructor_errors.t b/src/test/resources/unit/class_incomplete_constructor_errors.t new file mode 100644 index 0000000000..0f5cb71f7e --- /dev/null +++ b/src/test/resources/unit/class_incomplete_constructor_errors.t @@ -0,0 +1,26 @@ +use strict; +use warnings; +use Test::More; +use feature 'class'; +no warnings 'experimental::class'; + +my $parsed = eval q{class IncompleteConstructorEval { } ; 1}; +ok($parsed, 'control class compiles'); + +my $incomplete = eval 'class IncompleteConstructorEvalBroken {'; +ok(!defined $incomplete, 'truncated class declaration fails'); + +my $new_ok = eval { IncompleteConstructorEvalBroken->new; 1 }; +ok(!$new_ok, 'an incomplete eval class has no constructor'); +like($@, qr/Can't locate object method "new" via package "IncompleteConstructorEvalBroken"/, + 'incomplete eval class uses missing-method diagnostic'); + +my $begin_ok = eval q{ + class IncompleteConstructorBegin { BEGIN { IncompleteConstructorBegin->new; } } + 1; +}; +ok(!$begin_ok, 'BEGIN cannot construct an incomplete class'); +like($@, qr/Cannot create an object of incomplete class "IncompleteConstructorBegin"/, + 'BEGIN construction identifies the incomplete class'); + +done_testing; diff --git a/src/test/resources/unit/class_inheritance_constraints.t b/src/test/resources/unit/class_inheritance_constraints.t new file mode 100644 index 0000000000..2f406096dc --- /dev/null +++ b/src/test/resources/unit/class_inheritance_constraints.t @@ -0,0 +1,27 @@ +use strict; +use warnings; +use Test::More; +use feature 'class'; +no warnings 'experimental::class'; + +my $preexisting_isa = eval q{ + BEGIN { push @ClassInheritancePreexisting::ISA, 'Parent'; } + class ClassInheritancePreexisting {} + 1; +}; +ok(!$preexisting_isa, 'a class cannot replace a non-empty existing @ISA'); +like($@, qr/Cannot create class ClassInheritancePreexisting as it already has a non-empty \@ISA/, + 'preexisting @ISA has the Perl diagnostic'); + +my $not_a_class = eval q{ + BEGIN { $INC{'ClassInheritancePlainPackage.pm'} = __FILE__; } + package ClassInheritancePlainPackage; + package main; + class ClassInheritanceChild :isa(ClassInheritancePlainPackage) {} + 1; +}; +ok(!$not_a_class, ':isa requires a Perl class rather than an ordinary package'); +like($@, qr/Class :isa attribute requires a class but "ClassInheritancePlainPackage" is not one/, + ':isa diagnostic identifies the ordinary package'); + +done_testing; diff --git a/src/test/resources/unit/class_object_glob_assignment_error.t b/src/test/resources/unit/class_object_glob_assignment_error.t new file mode 100644 index 0000000000..a2a86074f5 --- /dev/null +++ b/src/test/resources/unit/class_object_glob_assignment_error.t @@ -0,0 +1,16 @@ +use Test::More; + +BEGIN { + plan skip_all => 'requires Perl 5.44 class syntax' if $] < 5.044; +} + +use v5.44; +use experimental 'class'; + +class GlobAssignmentObject {} + +my $ok = eval q{*glob_assignment_object = GlobAssignmentObject->new;}; +ok(!$ok, 'a class object cannot be assigned to a typeglob'); +like($@, qr/Can't assign reference to OBJECT into a GLOB/, 'reports the Perl-compatible diagnostic'); + +done_testing; diff --git a/src/test/resources/unit/class_param_conditional_defaults.t b/src/test/resources/unit/class_param_conditional_defaults.t new file mode 100644 index 0000000000..9b77e1da93 --- /dev/null +++ b/src/test/resources/unit/class_param_conditional_defaults.t @@ -0,0 +1,22 @@ +use strict; +use warnings; +use feature 'class'; +no warnings 'experimental::class'; +use Test::More; + +class ConditionalDefaults { + field $exists :param(e) = 'exists-default'; + field $defined :param(d) //= 'defined-default'; + field $truthy :param(t) ||= 'truthy-default'; + + method values { return ($exists, $defined, $truthy) } +} + +is_deeply [ConditionalDefaults->new(d => 'yes', t => 'yes')->values], + ['exists-default', 'yes', 'yes'], 'truthy arguments are preserved'; +is_deeply [ConditionalDefaults->new(e => 0, d => 0, t => 0)->values], + [0, 0, 'truthy-default'], 'defined and truthy defaults preserve their distinct conditions'; +is_deeply [ConditionalDefaults->new(e => undef, d => undef, t => undef)->values], + [undef, 'defined-default', 'truthy-default'], 'undefined arguments receive both defaults'; + +done_testing; diff --git a/src/test/resources/unit/class_param_name_constraints.t b/src/test/resources/unit/class_param_name_constraints.t new file mode 100644 index 0000000000..df6b7cffbd --- /dev/null +++ b/src/test/resources/unit/class_param_name_constraints.t @@ -0,0 +1,29 @@ +use strict; +use warnings; +use Test::More; +use feature 'class'; +no warnings 'experimental::class'; + +my $local_duplicate = eval q{ + class ParamNameDuplicateLocal { + field $first :param(shared); + field $second :param(shared); + } + 1; +}; +ok(!$local_duplicate, 'two fields in one class cannot share a parameter name'); +like($@, qr/Cannot assign :param\(shared\) to field \$second because that name is already in use/, + 'local duplicate identifies the parameter and field'); + +my $inherited_duplicate = eval q{ + class ParamNameDuplicateParent { field $first :param(shared); } + class ParamNameDuplicateChild :isa(ParamNameDuplicateParent) { + field $second :param(shared); + } + 1; +}; +ok(!$inherited_duplicate, 'a child field cannot reuse an inherited parameter name'); +like($@, qr/Cannot assign :param\(shared\) to field \$second because that name is already in use/, + 'inherited duplicate identifies the parameter and field'); + +done_testing; diff --git a/src/test/resources/unit/class_required_param_validation.t b/src/test/resources/unit/class_required_param_validation.t new file mode 100644 index 0000000000..0445cea26a --- /dev/null +++ b/src/test/resources/unit/class_required_param_validation.t @@ -0,0 +1,24 @@ +use strict; +use warnings; +use feature 'class'; +no warnings 'experimental::class'; +use Test::More; + +class RequiredConstructorParam { + field $required :param; + field $optional :param = 'optional-default'; + + method values { return ($required, $optional) } +} + +ok !eval { RequiredConstructorParam->new() }, + 'constructor rejects a missing required parameter'; +like $@, + qr/^Required parameter 'required' is missing for "RequiredConstructorParam" constructor at /, + 'missing required parameter reports the constructor and parameter name'; + +my $object = RequiredConstructorParam->new(required => undef); +is_deeply [$object->values], [undef, 'optional-default'], + 'an explicitly supplied undef satisfies a required parameter'; + +done_testing; diff --git a/src/test/resources/unit/class_unit_constructor_redefinition.t b/src/test/resources/unit/class_unit_constructor_redefinition.t new file mode 100644 index 0000000000..c20d81f0ee --- /dev/null +++ b/src/test/resources/unit/class_unit_constructor_redefinition.t @@ -0,0 +1,19 @@ +use strict; +use warnings; +use Test::More; +use feature 'class'; +no warnings 'experimental::class'; + +my @warnings; +{ + local $SIG{__WARN__} = sub { push @warnings, @_ }; + eval q{ + class UnitConstructorRedefinition; + field $value :reader = 42; + 1; + }; +} + +is($@, '', 'unit class with a later field compiles'); +is_deeply(\@warnings, [], 'replacing the synthetic constructor emits no redefinition warning'); +done_testing; diff --git a/src/test/resources/unit/cleared_constant_handler_diagnostic.t b/src/test/resources/unit/cleared_constant_handler_diagnostic.t new file mode 100644 index 0000000000..adbf4befe5 --- /dev/null +++ b/src/test/resources/unit/cleared_constant_handler_diagnostic.t @@ -0,0 +1,31 @@ +use strict; +use warnings; +use Test::More; +use IPC::Open3 qw(open3); +use Symbol qw(gensym); + +my $source = <<'PERL'; +use overload; +BEGIN { overload::constant q => sub {}; undef *^H } +undef(1,2); +undef(1,2); +undef(1,2); +undef(1,2); +undef(1,2); +undef(1,2); +undef(1,2); +undef(1,2); +undef(1,2); +"a" +PERL +my $launcher = $^X eq 'jperl' ? './jperl' : $^X; +my $stderr = gensym; +my $pid = open3(undef, my $stdout, $stderr, $launcher, '-e', $source); +my $output = do { local $/; <$stdout> } . do { local $/; <$stderr> }; +waitpid $pid, 0; + +like($output, + qr/Constant\(q\) unknown at -e line 12, near ""a""\n/, + 'the capped q constant diagnostic retains its reduced q label for double quotes'); + +done_testing; diff --git a/src/test/resources/unit/cleared_constant_handler_diagnostics.t b/src/test/resources/unit/cleared_constant_handler_diagnostics.t new file mode 100644 index 0000000000..cf62916ee5 --- /dev/null +++ b/src/test/resources/unit/cleared_constant_handler_diagnostics.t @@ -0,0 +1,14 @@ +use Test::More; + +for my $case ( + ['integer', '1', 'use overload; BEGIN { overload::constant integer => sub {}; undef *^H } 1'], +) { + my ($kind, $literal, $source) = @$case; + eval $source; + my $prefix = "Constant($literal) unknown at (eval "; + my $suffix = ") line 1, at end of line\n"; + ok(index($@, $prefix) == 0 && substr($@, -length($suffix)) eq $suffix, + "clearing the $kind constant handler rejects $literal at its literal location"); +} + +done_testing; diff --git a/src/test/resources/unit/conflict_marker_diagnostics.t b/src/test/resources/unit/conflict_marker_diagnostics.t index 9e33b3cbf1..2782e81f51 100644 --- a/src/test/resources/unit/conflict_marker_diagnostics.t +++ b/src/test/resources/unit/conflict_marker_diagnostics.t @@ -17,4 +17,8 @@ for my $marker (map { $_ x 7 } qw(< = >)) { } } +eval "<<<<<<< ours\nmy \$x;\n=======\nmy \$y;\n>>>>>>> theirs\n"; +like $@, qr{\AVersion control conflict marker at \(eval \d+\) line 1, near "<<<<<<<"\nVersion control conflict marker at \(eval \d+\) line 3, near "======="\nVersion control conflict marker at \(eval \d+\) line 5, near ">>>>>>>"\n\z}, + 'all conflict markers are diagnosed in source order'; + done_testing; diff --git a/src/test/resources/unit/control_flow_escaping_last.t b/src/test/resources/unit/control_flow_escaping_last.t new file mode 100644 index 0000000000..27a3d42dea --- /dev/null +++ b/src/test/resources/unit/control_flow_escaping_last.t @@ -0,0 +1,17 @@ +use strict; +use warnings; +use Test::More; + +sub escaping_last { last } + +my @warnings; +my $ok; +{ + local $SIG{__WARN__} = sub { push @warnings, @_ }; + $ok = eval { escaping_last(); 1 }; +} + +ok !defined $ok, 'last escapes the surrounding eval'; +like join('', @warnings), qr/Exiting subroutine via last/, 'escaped last warns while leaving subroutine'; + +done_testing; diff --git a/src/test/resources/unit/core_given_keyword.t b/src/test/resources/unit/core_given_keyword.t new file mode 100644 index 0000000000..b1ef45e02a --- /dev/null +++ b/src/test/resources/unit/core_given_keyword.t @@ -0,0 +1,9 @@ +use strict; +use warnings; +use Test::More; + +my $value; +CORE::given(1) { $value = 'entered' } +is($value, 'entered', 'CORE::given is parsed as a core keyword'); + +done_testing; diff --git a/src/test/resources/unit/defer_control_flow_error.t b/src/test/resources/unit/defer_control_flow_error.t new file mode 100644 index 0000000000..b711222200 --- /dev/null +++ b/src/test/resources/unit/defer_control_flow_error.t @@ -0,0 +1,10 @@ +use Test::More; +use feature 'defer'; +no warnings 'experimental::defer'; + +my $ok = eval 'defer { return 1 }'; +ok(!$ok, 'return from defer is rejected'); +like($@, qr/Can't "return" out of a "defer" block/, 'reports the defer control-flow error'); +unlike($@, qr/, near /, 'does not add source excerpt to the clean error'); + +done_testing; diff --git a/src/test/resources/unit/deferred_diagnostic_error_cap.t b/src/test/resources/unit/deferred_diagnostic_error_cap.t new file mode 100644 index 0000000000..ea3015fbdc --- /dev/null +++ b/src/test/resources/unit/deferred_diagnostic_error_cap.t @@ -0,0 +1,33 @@ +use strict; +use warnings; +use Test::More; +use IPC::Open3 qw(open3); +use Symbol qw(gensym); + +my $source = <<'PERL'; +use overload; +BEGIN { overload::constant q => sub {}; undef *^H } +undef(1,2); +undef(1,2); +undef(1,2); +undef(1,2); +undef(1,2); +undef(1,2); +undef(1,2); +undef(1,2); +undef(1,2); +"a" +PERL + +my $launcher = $^X eq 'jperl' ? './jperl' : $^X; +my $stderr = gensym; +my $pid = open3(undef, my $stdout, $stderr, $launcher, '-e', $source); +my $output = do { local $/; <$stdout> } . do { local $/; <$stderr> }; +waitpid $pid, 0; + +is(scalar(() = $output =~ /Too many arguments for undef operator/g), 9, + 'all recoverable undef diagnostics are retained before the cap'); +like($output, qr/Constant\(q\) unknown at -e line 12, near ""a""\n-e has too many errors\.\n\z/s, + 'the tenth deferred compile diagnostic receives Perl\'s error-cap marker'); + +done_testing; diff --git a/src/test/resources/unit/delete_exists_invalid_argument.t b/src/test/resources/unit/delete_exists_invalid_argument.t new file mode 100644 index 0000000000..2c3873f5b7 --- /dev/null +++ b/src/test/resources/unit/delete_exists_invalid_argument.t @@ -0,0 +1,16 @@ +use Test::More; + +for my $case ( + ['delete $x', 'delete argument is not a HASH or ARRAY element or slice'], + ['delete sort 1', 'delete argument is not a HASH or ARRAY element or slice'], + ['exists $x', 'exists argument is not a HASH or ARRAY element or a subroutine'], + ['exists &foo()', 'exists argument is not a subroutine name'], +) { + my ($code, $message) = @$case; + my $ok = eval $code; + ok(!$ok, "$code is rejected"); + like($@, qr/\Q$message\E/, "$code reports its invalid argument"); + like($@, qr/line 1/, "$code reports the source line"); +} + +done_testing; diff --git a/src/test/resources/unit/dump_computed_label_error.t b/src/test/resources/unit/dump_computed_label_error.t new file mode 100644 index 0000000000..cf2a29e0d1 --- /dev/null +++ b/src/test/resources/unit/dump_computed_label_error.t @@ -0,0 +1,11 @@ +use strict; +use warnings; +use Test::More; + +my $label = 'missing_label'; +eval { CORE::dump $label; 1 }; + +like($@, qr/Can't find label missing_label at .* line \d+\./, + 'dump reports the evaluated missing label'); + +done_testing; diff --git a/src/test/resources/unit/dump_core_qualification_diagnostic.t b/src/test/resources/unit/dump_core_qualification_diagnostic.t new file mode 100644 index 0000000000..07a51be6bc --- /dev/null +++ b/src/test/resources/unit/dump_core_qualification_diagnostic.t @@ -0,0 +1,19 @@ +use strict; +use warnings; +use Test::More; +use IPC::Open3 qw(open3); +use Symbol qw(gensym); + +my $launcher = $^X eq 'jperl' ? './jperl' : $^X; +my $stderr = gensym; +my $pid = open3(undef, my $stdout, $stderr, $launcher, '-e', + qq{BEGIN { \$^C = 1; }\ndump;\nCORE::dump;}); +my $output = do { local $/; <$stdout> } . do { local $/; <$stderr> }; +waitpid $pid, 0; + +ok($? != 0, 'unqualified dump fails to compile'); +is($output, + "dump() must be written as CORE::dump() as of Perl 5.30 at -e line 2.\n", + 'unqualified dump has the CORE qualification diagnostic'); + +done_testing; diff --git a/src/test/resources/unit/empty_named_regex_diagnostic.t b/src/test/resources/unit/empty_named_regex_diagnostic.t new file mode 100644 index 0000000000..852a5a97c4 --- /dev/null +++ b/src/test/resources/unit/empty_named_regex_diagnostic.t @@ -0,0 +1,17 @@ +use strict; +use warnings; +use Test::More; + +if ($^X !~ m{/jperl-exec$}) { + plan skip_all => 'system Perl 5.42 crashes on the upstream GH #16930 reproducer'; +} + +eval q{qr/(?{})\N{}/;while(my($0)=0){}}; + +like($@, + qr/^Unknown charname '' at \(eval 1\) line 1, near "\{\}\)"\n$/, + 'empty named character in a regex keeps the token excerpt'); +unlike($@, qr/within pattern|Empty \\N\{\}/, + 'empty named character reports one Perl diagnostic'); + +done_testing; diff --git a/src/test/resources/unit/encoding_special_variable_error.t b/src/test/resources/unit/encoding_special_variable_error.t new file mode 100644 index 0000000000..c51fb1e095 --- /dev/null +++ b/src/test/resources/unit/encoding_special_variable_error.t @@ -0,0 +1,10 @@ +use Test::More; + +my $ok = eval q{${^ENCODING} = undef; +{ local ${^ENCODING}; } +${^ENCODING} = 42;}; +ok(!$ok, '${^ENCODING} is rejected'); +like($@, qr/\$\{\^ENCODING\} is no longer supported/, 'reports Perl-compatible diagnostic'); +like($@, qr/line 3\./, 'reports the special variable source line'); + +done_testing; diff --git a/src/test/resources/unit/exists_unary_plus_target.t b/src/test/resources/unit/exists_unary_plus_target.t new file mode 100644 index 0000000000..278488753f --- /dev/null +++ b/src/test/resources/unit/exists_unary_plus_target.t @@ -0,0 +1,9 @@ +use strict; +use warnings; +use Test::More; + +my $ref = { nested => { value => 1 } }; +ok(exists +($ref // {})->{nested}{value}, + 'exists accepts a unary-plus-disambiguated hash element target'); + +done_testing; diff --git a/src/test/resources/unit/extra_paired_delimiter_deprecation.t b/src/test/resources/unit/extra_paired_delimiter_deprecation.t new file mode 100644 index 0000000000..73b582ed3b --- /dev/null +++ b/src/test/resources/unit/extra_paired_delimiter_deprecation.t @@ -0,0 +1,26 @@ +use strict; +use warnings; +use utf8; +use Test::More; + +my @warnings; +{ + local $SIG{__WARN__} = sub { push @warnings, @_ }; + my $ok = eval "use utf8;\nmy \$bad = q《unterminated》;\n"; + ok(!$ok, 'a mirrored non-Latin-1 delimiter is not paired without the feature'); +} + +like($warnings[0], qr{\AUse of '《' is deprecated as a string delimiter}, + 'the future paired delimiter emits the deprecation warning'); +like($warnings[0], qr{ at \(eval \d+\) line 2\.\n\z}, + 'the compatibility warning belongs to the delimiter source line'); + +@warnings = (); +{ + local $SIG{__WARN__} = sub { push @warnings, @_ }; + my $ok = eval "use utf8; no warnings 'deprecated';\nmy \$bad = q《unterminated》;\n"; + ok(!$ok, 'the legacy delimiter remains unterminated when warnings are disabled'); +} +is_deeply(\@warnings, [], 'no warnings deprecated suppresses the compatibility notice'); + +done_testing; diff --git a/src/test/resources/unit/filehandle_directory_conflict_error.t b/src/test/resources/unit/filehandle_directory_conflict_error.t new file mode 100644 index 0000000000..3e8244ad24 --- /dev/null +++ b/src/test/resources/unit/filehandle_directory_conflict_error.t @@ -0,0 +1,17 @@ +use strict; +use warnings; +use Test::More; + +opendir FOO, '.' or die "opendir FOO: $!"; +eval { open FOO, '<', __FILE__; 1 }; +like($@, qr/^Cannot open FOO as a filehandle: it is already open as a dirhandle/, + 'open rejects an active directory handle'); +closedir FOO; + +open FOO, '<', __FILE__ or die "open FOO: $!"; +eval { opendir FOO, '.'; 1 }; +like($@, qr/^Cannot open FOO as a dirhandle: it is already open as a filehandle/, + 'opendir rejects an active file handle'); +close FOO; + +done_testing; diff --git a/src/test/resources/unit/foreach_declared_reference_error.t b/src/test/resources/unit/foreach_declared_reference_error.t new file mode 100644 index 0000000000..87210fd85e --- /dev/null +++ b/src/test/resources/unit/foreach_declared_reference_error.t @@ -0,0 +1,17 @@ +use strict; +use warnings; +use Test::More; + +use feature qw(refaliasing declared_refs); +no warnings qw(experimental::refaliasing experimental::declared_refs); + +eval q{ foreach my \$item ('not a reference') { } 1 }; +like($@, qr/^Assigned value is not a reference/, 'scalar declared-reference foreach rejects non-reference'); + +eval q{ foreach my \@item (\undef) { } 1 }; +like($@, qr/^Assigned value is not an ARRAY reference/, 'array declared-reference foreach rejects scalar reference'); + +eval q{ foreach my \%item ([]) { } 1 }; +like($@, qr/^Assigned value is not a HASH reference/, 'hash declared-reference foreach rejects array reference'); + +done_testing; diff --git a/src/test/resources/unit/format_syntax_error_diagnostic.t b/src/test/resources/unit/format_syntax_error_diagnostic.t new file mode 100644 index 0000000000..bd4f314556 --- /dev/null +++ b/src/test/resources/unit/format_syntax_error_diagnostic.t @@ -0,0 +1,17 @@ +use strict; +use warnings; +use Test::More; +use IPC::Open3 qw(open3); +use Symbol qw(gensym); + +my $source = "format=\n@\n=h\n=cut\n"; +my $launcher = $^X eq 'jperl' ? './jperl' : $^X; +my $stderr = gensym; +my $pid = open3(undef, my $stdout, $stderr, $launcher, '-e', $source); +my $output = do { local $/; <$stdout> } . do { local $/; <$stderr> }; +waitpid $pid, 0; + +like($output, qr/syntax error at -e line 4, next token \?\?\?/, + 'malformed format body keeps Perl\'s syntax-error diagnostic'); + +done_testing; diff --git a/src/test/resources/unit/glob_scalar_reference_alias.t b/src/test/resources/unit/glob_scalar_reference_alias.t new file mode 100644 index 0000000000..a7fe41952a --- /dev/null +++ b/src/test/resources/unit/glob_scalar_reference_alias.t @@ -0,0 +1,22 @@ +use strict; +use warnings; +use Test::More; + +our $target = 'initial'; +our $alias; +*alias = \$target; + +is($alias, 'initial', 'typeglob scalar-reference assignment aliases its SCALAR slot'); +$alias = 'changed through alias'; +is($target, 'changed through alias', 'the aliased scalar slot remains shared'); + +{ + no strict 'subs'; + my $bareword_ref = \_; + is($$bareword_ref, '_', 'refgen keeps a bare underscore as a bareword, not @_'); + + is(${*inline_alias = \_}, '_', + 'immediate scalar dereference of a typeglob assignment preserves its scalar slot'); +} + +done_testing; diff --git a/src/test/resources/unit/global_only_lexical_declaration.t b/src/test/resources/unit/global_only_lexical_declaration.t new file mode 100644 index 0000000000..f9a410e725 --- /dev/null +++ b/src/test/resources/unit/global_only_lexical_declaration.t @@ -0,0 +1,15 @@ +use Test::More; + +my $ok = eval 'my $!'; +ok(!$ok, 'global-only punctuation variable cannot be lexical'); +like($@, qr/Can't use global \$! in "my"/, 'reports the global-only variable'); +like($@, qr/near "my \$!/, 'reports the declaration location'); + +{ + use open ':std', ':utf8'; + $ok = eval qq|my \$\xb6;|; +} +ok(!$ok, 'global-only Unicode punctuation variable cannot be lexical'); +like($@, qr/Can't use global \$\x{b6} in "my"/, 'reports the Unicode punctuation variable'); + +done_testing; diff --git a/src/test/resources/unit/goto_foreach_entry_error.t b/src/test/resources/unit/goto_foreach_entry_error.t new file mode 100644 index 0000000000..20b1e0c373 --- /dev/null +++ b/src/test/resources/unit/goto_foreach_entry_error.t @@ -0,0 +1,33 @@ +use strict; +use warnings; +use IPC::Open3 qw(open3); +use Symbol qw(gensym); +use Test::More; + +my $launcher = $^X eq 'jperl' ? './jperl' : $^X; +if ($^X eq 'jperl' && !-f 'target/perlonjava-5.44.1.jar') { + plan skip_all => 'nested jperl launcher requires the development jar'; +} + +my $stderr = gensym; +my $pid = open3(undef, my $stdout, $stderr, $launcher, '-e', + "goto target;\nforeach (1) { target: }"); +my $output = do { local $/; <$stdout> } . do { local $/; <$stderr> }; +waitpid($pid, 0); + +ok($? != 0, 'top-level goto cannot enter a foreach body'); +like($output, qr/Can't "goto" into the middle of a foreach loop/, + 'top-level goto reports a foreach-entry diagnostic'); +like($output, qr/at .* line 2\./, + 'top-level goto reports the destination label line'); + +my $ok = eval q{ + goto target; + foreach (1) { target: } + 1; +}; +ok(!$ok, 'goto cannot enter a foreach body'); +like($@, qr/Can't "goto" into the middle of a foreach loop/, + 'goto reports a foreach-entry diagnostic'); + +done_testing; diff --git a/src/test/resources/unit/goto_foreach_shadowed_label.t b/src/test/resources/unit/goto_foreach_shadowed_label.t new file mode 100644 index 0000000000..32847487b2 --- /dev/null +++ b/src/test/resources/unit/goto_foreach_shadowed_label.t @@ -0,0 +1,31 @@ +use strict; +use warnings; +use Test::More; + +my ($error, $outer_label_was_entered) = ('', 0); +eval { + my $value = 0; + for (0 .. 1) { + TARGET: + $value += 10; + last; + } + goto TARGET if $value == 10; +}; +$error = $@; + +goto AFTER_OUTER_TARGET; +TARGET: +{ + $outer_label_was_entered = 1; +} +AFTER_OUTER_TARGET: + +like( + $error, + qr/Can't "goto" into the middle of a foreach loop/, + 'goto selects the shadowing foreach label and rejects an illegal entry', +); +is($outer_label_was_entered, 0, 'goto does not resolve to a later outer label'); + +done_testing; diff --git a/src/test/resources/unit/goto_given_entry_error.t b/src/test/resources/unit/goto_given_entry_error.t new file mode 100644 index 0000000000..20ee902327 --- /dev/null +++ b/src/test/resources/unit/goto_given_entry_error.t @@ -0,0 +1,10 @@ +use strict; +use warnings; +use Test::More; + +my $ok = eval q{ goto target; CORE::given(1) { target: } 1 }; +ok(!$ok, 'goto cannot enter a given block'); +like($@, qr/Can't "goto" into a "given" block/, + 'goto reports the given-entry diagnostic'); + +done_testing; diff --git a/src/test/resources/unit/goto_nearest_lexical_label.t b/src/test/resources/unit/goto_nearest_lexical_label.t new file mode 100644 index 0000000000..3ddc5392d9 --- /dev/null +++ b/src/test/resources/unit/goto_nearest_lexical_label.t @@ -0,0 +1,32 @@ +use strict; +use warnings; +use Test::More; + +my $value = 0; +{ + while (1) { + OUTER: + $value += 10; + last; + } + is $value, 10, 'the inner loop label does not shadow the enclosing goto target'; + goto OUTER if $value == 10; + $value += 10; + OUTER: + is $value, 10, 'goto chooses the nearest label in the enclosing block'; +} + +my ($sum, $reentered) = (0, 0); +for my $item (0 .. 1) { + AGAIN: + $sum = 0; + AGAIN: + $sum += 10; + if (!$reentered++) { + goto AGAIN; + } +} +is $sum, 10, 'a repeated label in a folded foreach body targets its first occurrence'; +is $reentered, 3, 'the goto does not restart the enclosing program'; + +done_testing; diff --git a/src/test/resources/unit/goto_within_foreach.t b/src/test/resources/unit/goto_within_foreach.t new file mode 100644 index 0000000000..7471a29b39 --- /dev/null +++ b/src/test/resources/unit/goto_within_foreach.t @@ -0,0 +1,23 @@ +use strict; +use warnings; +use Test::More; + +my @values = qw(red blue); +my @seen; + +foreach my $value (@values) { + goto $value . ''; + +red: + push @seen, $value; + next; + +blue: + push @seen, $value; + next; +} + +is_deeply(\@seen, [qw(red blue)], + 'a computed goto within an entered foreach body is permitted'); + +done_testing; diff --git a/src/test/resources/unit/hex_float_without_integer_part.t b/src/test/resources/unit/hex_float_without_integer_part.t new file mode 100644 index 0000000000..d53ad8df61 --- /dev/null +++ b/src/test/resources/unit/hex_float_without_integer_part.t @@ -0,0 +1,8 @@ +use strict; +use warnings; +use Test::More; + +is(0x.0p0, 0, 'hexadecimal float may omit an integer part'); +is(0x.8p0, 0.5, 'hexadecimal fractional literal has the expected value'); + +done_testing; diff --git a/src/test/resources/unit/illegal_code_point_escape_diagnostics.t b/src/test/resources/unit/illegal_code_point_escape_diagnostics.t new file mode 100644 index 0000000000..f31b85c9ac --- /dev/null +++ b/src/test/resources/unit/illegal_code_point_escape_diagnostics.t @@ -0,0 +1,23 @@ +use strict; +use warnings; +use Config; +use Test::More; + +my $hex = $Config{uvsize} < 8 ? '8000_0000' : '8000_0000_0000_0000'; +my $octal = $Config{uvsize} < 8 ? '20_000_000_000' : '1_000_000_000_000_000_000_000'; +my $value = $hex =~ s/_//gr; + +for my $case ( + [ 'hexadecimal', 'my $x = "\\x{' . $hex . '}"' ], + [ 'octal', 'my $x = "\\o{' . $octal . '}"' ], +) { + my ($name, $source) = @$case; + my $result = eval $source; + + ok(!defined $result, "$name escape above the signed-IV limit fails"); + like($@, + qr{\AUse of code point 0x\Q$value\E is not allowed; the permissible max is 0x7FFFFFFFFFFFFFFF at \(eval \d+\) line 1\.\n?\z}, + "$name escape reports the signed-IV bound"); +} + +done_testing; diff --git a/src/test/resources/unit/illegal_special_block_declaration.t b/src/test/resources/unit/illegal_special_block_declaration.t new file mode 100644 index 0000000000..4e5ab0abbf --- /dev/null +++ b/src/test/resources/unit/illegal_special_block_declaration.t @@ -0,0 +1,12 @@ +use strict; +use warnings; +use Test::More; + +for my $block (qw(BEGIN CHECK INIT UNITCHECK END)) { + my $ok = eval "$block <>"; + ok(!$ok, "$block diamond declaration fails"); + like($@, qr{\AIllegal declaration of subroutine \Q$block\E at \(eval \d+\) line 1\.}, + "$block reports the special-block declaration error"); +} + +done_testing; diff --git a/src/test/resources/unit/incomplete_base_literal_diagnostic.t b/src/test/resources/unit/incomplete_base_literal_diagnostic.t new file mode 100644 index 0000000000..509a12a616 --- /dev/null +++ b/src/test/resources/unit/incomplete_base_literal_diagnostic.t @@ -0,0 +1,25 @@ +use strict; +use warnings; +use Test::More; +use IPC::Open3 qw(open3); +use Symbol qw(gensym); + +for my $case ( + [ '0x x 2;', 'hexadecimal', '0x ' ], + [ '0xx 2;', 'hexadecimal', '0xx' ], + [ '0x_;', 'hexadecimal', '0x_;' ], + [ '0b;', 'binary', '0b;' ], +) { + my ($source, $kind, $near) = @$case; + my $launcher = $^X eq 'jperl' ? './jperl' : $^X; + my $stderr = gensym; + my $pid = open3(undef, my $stdout, $stderr, $launcher, '-e', $source); + my $output = do { local $/; <$stdout> } . do { local $/; <$stderr> }; + waitpid $pid, 0; + + ok($? != 0, "$source fails to compile"); + like($output, qr{\ANo digits found for \Q$kind\E literal at -e line 1, near "\Q$near\E"\n}, + "$source reports the missing base-literal digits"); +} + +done_testing; diff --git a/src/test/resources/unit/incomplete_decimal_exponent_diagnostic.t b/src/test/resources/unit/incomplete_decimal_exponent_diagnostic.t new file mode 100644 index 0000000000..8ecb7bc223 --- /dev/null +++ b/src/test/resources/unit/incomplete_decimal_exponent_diagnostic.t @@ -0,0 +1,18 @@ +use strict; +use warnings; +use Test::More; +use IPC::Open3 qw(open3); +use Symbol qw(gensym); + +my $launcher = $^X eq 'jperl' ? './jperl' : $^X; +my $stderr = gensym; +my $pid = open3(undef, my $stdout, $stderr, $launcher, '-e', '1e--5'); +my $output = do { local $/; <$stdout> } . do { local $/; <$stderr> }; +waitpid $pid, 0; + +ok($? != 0, 'malformed decimal exponent fails to compile'); +like($output, + qr{\ABareword found where operator expected \(Missing operator before "e"\?\) at -e line 1, near "1e"\nsyntax error at -e line 1, near "1e"\nExecution of -e aborted due to compilation errors\.\n\z}, + 'malformed decimal exponent reports the bare marker diagnostics'); + +done_testing; diff --git a/src/test/resources/unit/indirect_block_method_undef_diagnostic.t b/src/test/resources/unit/indirect_block_method_undef_diagnostic.t new file mode 100644 index 0000000000..2c4bfaa668 --- /dev/null +++ b/src/test/resources/unit/indirect_block_method_undef_diagnostic.t @@ -0,0 +1,11 @@ +use strict; +use warnings; +use Test::More; + +no warnings 'unopened'; +eval 'E{0;readline @0}'; +like($@, + qr{\ACan't call method "E" without a package or object reference at \(eval \d+\) line 1\.\n\z}, + 'an indirect block method call distinguishes an absent object from undef'); + +done_testing; diff --git a/src/test/resources/unit/initial_child_exit_status.t b/src/test/resources/unit/initial_child_exit_status.t new file mode 100644 index 0000000000..10d11ac9ba --- /dev/null +++ b/src/test/resources/unit/initial_child_exit_status.t @@ -0,0 +1,7 @@ +use strict; +use warnings; +use Test::More; + +is $?, 0, 'the initial child exit status is zero'; + +done_testing; diff --git a/src/test/resources/unit/interpolated_heredoc_terminator_diagnostic.t b/src/test/resources/unit/interpolated_heredoc_terminator_diagnostic.t new file mode 100644 index 0000000000..c486db6887 --- /dev/null +++ b/src/test/resources/unit/interpolated_heredoc_terminator_diagnostic.t @@ -0,0 +1,20 @@ +use strict; +use warnings; +use Test::More; + +my $ok = eval q!"${< } . do { local $/; <$stderr> }; + waitpid $pid, 0; + + my $near = "isa => ${opening}" . ($value =~ /\$/ ? 'Foo' : 'Int'); + like($output, + qr/Bareword found where operator expected \(Do you need to predeclare "isa"\?\) at -e line 9, near "\Q$near\E"\n \(Might be a runaway multi-line \Q$opening$closing\E string starting on line 4\)\n\Q$bad_name\E at -e line 9\./, + "malformed $opening attribute quote retains the later isa diagnostic"); +} + +done_testing; diff --git a/src/test/resources/unit/malformed_format_dot_argument_diagnostic.t b/src/test/resources/unit/malformed_format_dot_argument_diagnostic.t new file mode 100644 index 0000000000..a8d8ae4f58 --- /dev/null +++ b/src/test/resources/unit/malformed_format_dot_argument_diagnostic.t @@ -0,0 +1,18 @@ +use strict; +use warnings; +use Test::More; + +eval q{format= +@ +.// +. +}; + +like($@, + qr/^syntax error at \(eval \d+\) line 3,/, + 'invalid dot format argument is rejected while compiling the format'); + +my $still_parses = eval q{my $value = 1; $value}; +is($still_parses, 1, 'format diagnostic does not corrupt the following parser state'); + +done_testing; diff --git a/src/test/resources/unit/malformed_format_eof_diagnostic.t b/src/test/resources/unit/malformed_format_eof_diagnostic.t new file mode 100644 index 0000000000..56b74e0b28 --- /dev/null +++ b/src/test/resources/unit/malformed_format_eof_diagnostic.t @@ -0,0 +1,14 @@ +use strict; +use warnings; +use Test::More; + +eval q!format= +@​ +for(0000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000 +!; + +like($@, + qr/^syntax error at \(eval \d+\) line 4, (?:near "")?\nExecution of \(eval \d+\) aborted due to compilation errors\.\n$/, + 'malformed format at EOF reports the eval compilation diagnostic'); + +done_testing; diff --git a/src/test/resources/unit/malformed_interpolated_regex_diagnostic.t b/src/test/resources/unit/malformed_interpolated_regex_diagnostic.t new file mode 100644 index 0000000000..c051372d85 --- /dev/null +++ b/src/test/resources/unit/malformed_interpolated_regex_diagnostic.t @@ -0,0 +1,11 @@ +use strict; +use warnings; +use Test::More; + +eval q!eval"${sub{sub{//]]]"}}!; + +like($@, + qr/syntax error at \(eval 1\) line 1, near "\/\/\]"/, + 'malformed regex inside interpolation reports the quote-like construct'); + +done_testing; diff --git a/src/test/resources/unit/malformed_nested_interpolation_diagnostic.t b/src/test/resources/unit/malformed_nested_interpolation_diagnostic.t new file mode 100644 index 0000000000..547fa4a3a9 --- /dev/null +++ b/src/test/resources/unit/malformed_nested_interpolation_diagnostic.t @@ -0,0 +1,26 @@ +use strict; +use warnings; +use Test::More; +use IPC::Open3 qw(open3); +use Symbol qw(gensym); + +for my $case ( + [ 'qr!@{s{0})(?{!;', '"})"', 1 ], + [ "my (\$x, %y, \@z);\nqq!\$x\\U \$z[0] \$y{a}\\E \$z[1]!;\nqq!\$x\\U\@{s{0})(?{!;", + '")("', 3 ], +) { + my ($source, $near, $line) = @$case; + my $launcher = $^X eq 'jperl' ? './jperl' : $^X; + my $stderr = gensym; + my $pid = open3(undef, my $stdout, $stderr, $launcher, '-e', $source); + my $output = do { local $/; <$stdout> } . do { local $/; <$stderr> }; + waitpid $pid, 0; + + ok($? != 0, 'malformed nested interpolation fails to compile'); + is($output, + "syntax error at -e line $line, near $near\n" + . "Execution of -e aborted due to compilation errors.\n", + 'nested interpolation retains Perl diagnostic context'); +} + +done_testing; diff --git a/src/test/resources/unit/malformed_sub_regex_eval_diagnostic.t b/src/test/resources/unit/malformed_sub_regex_eval_diagnostic.t new file mode 100644 index 0000000000..399e06297f --- /dev/null +++ b/src/test/resources/unit/malformed_sub_regex_eval_diagnostic.t @@ -0,0 +1,11 @@ +use strict; +use warnings; +use Test::More; + +eval q!s,,$0[sub{m[]]],;s,,$0[sub{m[]]],}}!; + +like($@, + qr/syntax error at \(eval 1\) line 1, near "m\[\]\]"\nExecution of \(eval 1\) aborted due to compilation errors\./, + 'malformed regex in a sub preserves its original eval diagnostic'); + +done_testing; diff --git a/src/test/resources/unit/map_unclosed_array_syntax_error.t b/src/test/resources/unit/map_unclosed_array_syntax_error.t new file mode 100644 index 0000000000..e013151e11 --- /dev/null +++ b/src/test/resources/unit/map_unclosed_array_syntax_error.t @@ -0,0 +1,22 @@ +use strict; +use warnings; +use IPC::Open3 qw(open3); +use Symbol qw(gensym); +use Test::More; + +my $launcher = $^X eq 'jperl' ? './jperl' : $^X; +if ($^X eq 'jperl' && !-f 'target/perlonjava-5.44.1.jar') { + plan skip_all => 'nested jperl launcher requires the development jar'; +} + +my $stderr = gensym; +my $pid = open3(undef, my $stdout, $stderr, $launcher, '-e', + 'sub all (&@); all { $_->[0] } map { [ }'); +my $output = do { local $/; <$stdout> } . do { local $/; <$stderr> }; +waitpid($pid, 0); + +ok($? != 0, 'an array literal closed by a curly bracket does not compile'); +like($output, qr/syntax error.*near "\[ \}"/s, + 'mismatched array delimiter appears in the syntax context'); + +done_testing; diff --git a/src/test/resources/unit/missing_loop_variable_diagnostic.t b/src/test/resources/unit/missing_loop_variable_diagnostic.t new file mode 100644 index 0000000000..3ef84397a1 --- /dev/null +++ b/src/test/resources/unit/missing_loop_variable_diagnostic.t @@ -0,0 +1,11 @@ +use strict; +use warnings; +use Test::More; + +my $ok = eval q{map { for our *a (1..10) { $_ .= $x } }}; + +ok(!$ok, 'a typeglob cannot be a foreach iterator'); +like($@, qr{\AMissing \$ on loop variable at \(eval \d+\) line 1\.\n?\z}, + 'typeglob iterator reports the Perl loop-variable diagnostic'); + +done_testing; diff --git a/src/test/resources/unit/missing_operator_diagnostics.t b/src/test/resources/unit/missing_operator_diagnostics.t new file mode 100644 index 0000000000..43df69139c --- /dev/null +++ b/src/test/resources/unit/missing_operator_diagnostics.t @@ -0,0 +1,27 @@ +use Test::More; + +sub compile_diagnostics { + my ($source) = @_; + my $warning = ''; + local $SIG{__WARN__} = sub { $warning .= shift }; + eval $source; + return $warning . $@; +} + +like(compile_diagnostics(q{myfunc 1,2,3}), + qr/\ANumber found where operator expected \(Do you need to predeclare "myfunc"\?\) at \(eval \d+\) line 1, near "myfunc 1"\nsyntax error at \(eval \d+\) line 1, near "myfunc 1"\n(?:Execution of \(eval \d+\) aborted due to compilation errors\.\n)?\z/, + 'an adjacent number after a bareword reports a missing operator'); + +like(compile_diagnostics(q!0${!), + qr/\AScalar found where operator expected \(Missing operator before "\$\{"\?\) at \(eval \d+\) line 1, near "0\$\{"\nsyntax error at \(eval \d+\) line 1, near "0\$"\n(?:Execution of \(eval \d+\) aborted due to compilation errors\.\n)?\z/, + 'an adjacent scalar dereference reports a missing operator'); + +like(compile_diagnostics(q!0$#{!), + qr/\AArray length found where operator expected \(Missing operator before "\$#\{"\?\) at \(eval \d+\) line 1, near "0\$#\{"\nsyntax error at \(eval \d+\) line 1, near "0\$#"\n(?:Execution of \(eval \d+\) aborted due to compilation errors\.\n)?\z/, + 'an adjacent array length dereference reports a missing operator'); + +like(compile_diagnostics(q{0@foo}), + qr/\AArray found where operator expected \(Missing operator before "\@foo"\?\) at \(eval \d+\) line 1, near "0\@foo"\nsyntax error at \(eval \d+\) line 1, near "0\@foo\n"\n(?:Execution of \(eval \d+\) aborted due to compilation errors\.\n)?\z/, + 'an adjacent array reports a missing operator'); + +done_testing; diff --git a/src/test/resources/unit/named_signature_slurpy_remainder.t b/src/test/resources/unit/named_signature_slurpy_remainder.t new file mode 100644 index 0000000000..dc4d334cbb --- /dev/null +++ b/src/test/resources/unit/named_signature_slurpy_remainder.t @@ -0,0 +1,37 @@ +use Test::More; + +my $compiled = eval q{ + use feature 'signatures'; + no warnings 'experimental::signature_named_parameters'; + + sub positional_remainder (:$required, @rest) { + return join q{,}, $required, @rest; + } + + sub named_remainder (:$required, %rest) { + return join q{,}, $required, map { "$_=$rest{$_}" } sort keys %rest; + } + 1; +}; + +SKIP: { + skip 'named signature parameters are unavailable in this system Perl', 2 + unless $compiled; + is(positional_remainder(required => 'x', 'tail'), 'x,tail', + 'named parameters may precede a slurpy positional remainder'); + is(named_remainder(required => 'x', extra => 'tail'), 'x,extra=tail', + 'named parameters may precede a slurpy named remainder'); +} + +my $any_compiled = eval q{ + use feature 'keyword_any'; + no warnings 'experimental::keyword_any'; + sub parenthesized_any { any( { $_ > 2 } @_ ) } + 1; +}; +SKIP: { + skip 'keyword_any is unavailable in this system Perl', 1 unless $any_compiled; + ok(parenthesized_any(1, 3), 'parenthesized any invocation accepts a literal block'); +} + +done_testing; diff --git a/src/test/resources/unit/nested_variable_declaration_diagnostic.t b/src/test/resources/unit/nested_variable_declaration_diagnostic.t new file mode 100644 index 0000000000..a22d390756 --- /dev/null +++ b/src/test/resources/unit/nested_variable_declaration_diagnostic.t @@ -0,0 +1,18 @@ +use strict; +use warnings; +use Test::More; + +for my $case ( + [q{my (our $x);}, 'our', 'my', '(our'], + [q{our (my $x);}, 'my', 'our', '(my'], + [q{my (my $x);}, 'my', 'my', '(my'], + [q{our ($x, our($y), $z);}, 'our', 'our', ', our'], +) { + my ($source, $nested, $outer, $near) = @$case; + my $ok = eval $source; + ok(!$ok, "$source fails"); + like($@, qr{\ACan't redeclare "\Q$nested\E" in "\Q$outer\E" at \(eval \d+\) line 1, near "\Q$near\E"}, + "$source identifies both declarations and context"); +} + +done_testing; diff --git a/src/test/resources/unit/nondecimal_fractional_digit_diagnostic.t b/src/test/resources/unit/nondecimal_fractional_digit_diagnostic.t new file mode 100644 index 0000000000..8aecb9b910 --- /dev/null +++ b/src/test/resources/unit/nondecimal_fractional_digit_diagnostic.t @@ -0,0 +1,20 @@ +use strict; +use warnings; +use Test::More; +use IPC::Open3 qw(open3); +use Symbol qw(gensym); + +for my $source ('07.8p0;', '0b1.2p0;') { + my $launcher = $^X eq 'jperl' ? './jperl' : $^X; + my $stderr = gensym; + my $pid = open3(undef, my $stdout, $stderr, $launcher, '-e', $source); + my $output = do { local $/; <$stdout> } . do { local $/; <$stderr> }; + waitpid $pid, 0; + + ok($? != 0, "invalid fractional digit in $source fails to compile"); + like($output, + qr{\ABareword found where operator expected \(Missing operator before "p0"\?\) at -e line 1, near "[82]p0"\nsyntax error at -e line 1, near "[82]p0"\n}, + "invalid fractional digit in $source falls back to the bareword diagnostic"); +} + +done_testing; diff --git a/src/test/resources/unit/our_array_hash_deref_error.t b/src/test/resources/unit/our_array_hash_deref_error.t new file mode 100644 index 0000000000..1087dfc35f --- /dev/null +++ b/src/test/resources/unit/our_array_hash_deref_error.t @@ -0,0 +1,13 @@ +use Test::More; + +my $ok = eval q{ + our @a; + @a->{0}; + 1; +}; + +ok(!$ok, 'an array used as a hash reference is rejected'); +like($@, qr/Can't use an undefined value as a HASH reference/, + 'reports an undefined hash-reference value'); + +done_testing; diff --git a/src/test/resources/unit/overload/constant.t b/src/test/resources/unit/overload/constant.t index 2a32f1ce08..ee33bfafe9 100644 --- a/src/test/resources/unit/overload/constant.t +++ b/src/test/resources/unit/overload/constant.t @@ -67,6 +67,20 @@ is($after, 99, 'handler unwound on scope exit'); 'oversize hex literal goes through binary handler'); } +# Undefining the ^H typeglob clears its associated lexical hint hash. In +# particular, a constant handler installed before `undef *^H` must no longer +# be callable for the following literal. +{ + my $error = eval q{ + use overload; + BEGIN { overload::constant integer => sub {}; undef *^H } + 1; + 1; + }; + ::ok(index($@, 'Constant(1) unknown') >= 0, + 'undef *^H clears a constant-overload handler'); +} + # End-to-end smoke test: `use bigint` must now promote literals. SKIP: { my $ok = eval { require bigint; 1 }; diff --git a/src/test/resources/unit/readline_unopened_warning.t b/src/test/resources/unit/readline_unopened_warning.t new file mode 100644 index 0000000000..d200bcb94e --- /dev/null +++ b/src/test/resources/unit/readline_unopened_warning.t @@ -0,0 +1,14 @@ +use strict; +use Test::More; + +my $stderr = ''; +our @empty; +{ + local *STDERR; + open STDERR, '>', \$stderr or die "open STDERR: $!"; + readline @empty; +} + +is($stderr, '', 'unopened readline is silent when warnings are disabled'); + +done_testing; diff --git a/src/test/resources/unit/regex/runaway_multiline_delimiter_diagnostic.t b/src/test/resources/unit/regex/runaway_multiline_delimiter_diagnostic.t new file mode 100644 index 0000000000..9e87977523 --- /dev/null +++ b/src/test/resources/unit/regex/runaway_multiline_delimiter_diagnostic.t @@ -0,0 +1,18 @@ +use strict; +use warnings; +use Test::More; +use IPC::Open3 qw(open3); +use Symbol qw(gensym); + +my $source = "m/\$0[\n==0/"; +my $launcher = $^X eq 'jperl' ? './jperl' : $^X; +my $stderr = gensym; +my $pid = open3(undef, my $stdout, $stderr, $launcher, '-e', $source); +my $output = do { local $/; <$stdout> } . do { local $/; <$stderr> }; +waitpid $pid, 0; + +like($output, + qr/syntax error at -e line 2, near "\[\n=="\n \(Might be a runaway multi-line \/\/ string starting on line 1\)/, + 'unclosed class across a regex delimiter newline reports the runaway quote'); + +done_testing; diff --git a/src/test/resources/unit/regex/unicode_named_uplus_sequence_priority.t b/src/test/resources/unit/regex/unicode_named_uplus_sequence_priority.t index 14390f475c..3925021065 100644 --- a/src/test/resources/unit/regex/unicode_named_uplus_sequence_priority.t +++ b/src/test/resources/unit/regex/unicode_named_uplus_sequence_priority.t @@ -15,6 +15,20 @@ is($scalar_error, 'dotted U+ form remains invalid in a string'); is(scalar @warnings, 0, 'invalid string form has no preceding warning'); +eval "#line 1 unicode_named_uplus_sequence_priority.t\n" + . q!qr/\N{U+1_0000_0000_0000_0000}/!; +my ($overflow_error) = split /\n/, $@; +is($overflow_error, + 'Use of code point 0x1_0000_0000_0000_0000 is not allowed; the permissible max is 0x7FFFFFFFFFFFFFFF in regex; marked by <-- HERE in m/\\N{U+1_0000_0000_0000_0000 <-- HERE }/ at unicode_named_uplus_sequence_priority.t line 1.', + 'underscored U+ value above signed-UV max reports the range diagnostic'); + +eval "#line 1 unicode_named_uplus_sequence_priority.t\n" + . q!qr/\N{U+100.1_0000_0000_0000_0000}/!; +($overflow_error) = split /\n/, $@; +is($overflow_error, + 'Use of code point 0x1_0000_0000_0000_0000 is not allowed; the permissible max is 0x7FFFFFFFFFFFFFFF in regex; marked by <-- HERE in m/\N{U+100.1_0000_0000_0000_0000 <-- HERE }/ at unicode_named_uplus_sequence_priority.t line 1.', + 'a dotted U+ sequence reports overflow in its later component'); + my $regex = eval "#line 1 unicode_named_uplus_sequence_priority.t\n" . q!qr/\N{U+41.42}/!; is($@, '', 'dotted U+ sequence is legal in a regex'); diff --git a/src/test/resources/unit/regex_compile_recursion_limit.t b/src/test/resources/unit/regex_compile_recursion_limit.t new file mode 100644 index 0000000000..0e87b9c511 --- /dev/null +++ b/src/test/resources/unit/regex_compile_recursion_limit.t @@ -0,0 +1,11 @@ +use strict; +use warnings; +use Test::More; + +BEGIN { ${^RE_COMPILE_RECURSION_LIMIT} = 2 } +eval "#line 1 regex_compile_recursion_limit.t\nqr/((a))/"; +is($@, + "Too many nested open parens in regex; marked by <-- HERE in m/(( <-- HERE a))/ at regex_compile_recursion_limit.t line 1.\n", + 'regex compilation observes the nested-parenthesis limit'); + +done_testing; diff --git a/src/test/resources/unit/regex_keep_lookaround_diagnostic.t b/src/test/resources/unit/regex_keep_lookaround_diagnostic.t new file mode 100644 index 0000000000..e6805aa3f5 --- /dev/null +++ b/src/test/resources/unit/regex_keep_lookaround_diagnostic.t @@ -0,0 +1,13 @@ +use strict; +use warnings; +use Test::More; + +for my $pattern ('(?=a\\Ka)a', '(?<=a\\Kb)c') { + my $ok = eval { qr/$pattern/; 1 }; + ok(!$ok, 'KEEP within a lookaround is rejected'); + like($@, + qr/\\K not permitted in lookahead\/lookbehind in regex; marked by <-- HERE in m\/.*\\K <-- HERE /, + 'KEEP lookaround diagnostic marks immediately after KEEP'); +} + +done_testing; diff --git a/src/test/resources/unit/regex_missing_named_character_brace_location.t b/src/test/resources/unit/regex_missing_named_character_brace_location.t new file mode 100644 index 0000000000..42e52fcc53 --- /dev/null +++ b/src/test/resources/unit/regex_missing_named_character_brace_location.t @@ -0,0 +1,10 @@ +use strict; +use warnings; +use Test::More; + +my $ok = eval 'qr/\\N{/'; +ok(!$ok, 'unterminated named character escape fails'); +like($@, qr{\AMissing right brace on \\N\{\} or unescaped left brace after \\N at \(eval \d+\) line 1, within pattern}, + 'diagnostic belongs to the regex source line'); + +done_testing; diff --git a/src/test/resources/unit/regex_named_uplus_diagnostic_location.t b/src/test/resources/unit/regex_named_uplus_diagnostic_location.t new file mode 100644 index 0000000000..479fd33ebe --- /dev/null +++ b/src/test/resources/unit/regex_named_uplus_diagnostic_location.t @@ -0,0 +1,12 @@ +use strict; +use warnings; +use Test::More; + +for my $pattern ('\\N{U+.}', '\\N{U+_100}', '\\N{U+100_}') { + my $ok = eval { qr/$pattern/; 1 }; + ok(!$ok, 'malformed U+ named character is rejected'); + like($@, qr/Invalid hexadecimal number in \\N\{U\+\.\.\.\} in regex; marked by <-- HERE in m\//, + 'malformed U+ diagnostic includes regex source'); +} + +done_testing; diff --git a/src/test/resources/unit/removed_punctuation_variables.t b/src/test/resources/unit/removed_punctuation_variables.t new file mode 100644 index 0000000000..43be80117b --- /dev/null +++ b/src/test/resources/unit/removed_punctuation_variables.t @@ -0,0 +1,22 @@ +use warnings; +use Test::More; + +for my $source ('${#}', '${*}', '${"#"}', '${"*"}') { + my $ok = eval $source; + my $variable = index($source, '#') >= 0 ? '$#' : '$*'; + ok(!$ok, "$source is rejected"); + like($@, qr/\Q$variable\E is no longer supported as of Perl 5\.30/, + "$source reports the removed punctuation variable"); +} + +for my $case ( + ["my(\$a?\$b:\$c)\n", 'Can\'t declare conditional expression in "my"'], + ["my(do{})\n", 'Can\'t declare do block in "my"'], +) { + my ($source, $expected) = @$case; + my $ok = eval $source; + ok(!$ok, "$source is rejected"); + like($@, qr/\Q$expected\E/, "$source reports its invalid declaration form"); +} + +done_testing; diff --git a/src/test/resources/unit/return_indirect_map_error.t b/src/test/resources/unit/return_indirect_map_error.t new file mode 100644 index 0000000000..f7ec5590b2 --- /dev/null +++ b/src/test/resources/unit/return_indirect_map_error.t @@ -0,0 +1,13 @@ +use Test::More; + +my $ok = eval q{sub f { return name map { $_ + 1 } 1 .. 5; }}; +ok(!$ok, 'return rejects an indirect map argument'); +like($@, qr/Missing comma after first argument to return/, 'reports the specific diagnostic'); + +$ok = eval q{sub g { return if grep $_, @_; } 1;}; +ok($ok, 'return statement modifiers remain valid'); + +$ok = eval q{sub h { return sort grep { $_ } qw(b a); } 1;}; +ok($ok, 'return accepts a sort grep pipeline'); + +done_testing; diff --git a/src/test/resources/unit/runaway_multiline_quote_diagnostic.t b/src/test/resources/unit/runaway_multiline_quote_diagnostic.t new file mode 100644 index 0000000000..5dcf2ed6e4 --- /dev/null +++ b/src/test/resources/unit/runaway_multiline_quote_diagnostic.t @@ -0,0 +1,18 @@ +use strict; +use warnings; +use Test::More; +use IPC::Open3 qw(open3); +use Symbol qw(gensym); + +my $source = "q/\n/ time"; +my $launcher = $^X eq 'jperl' ? './jperl' : $^X; +my $stderr = gensym; +my $pid = open3(undef, my $stdout, $stderr, $launcher, '-e', $source); +my $output = do { local $/; <$stdout> } . do { local $/; <$stderr> }; +waitpid $pid, 0; + +like($output, + qr/syntax error at -e line 2, near "\/ time"\n \(Might be a runaway multi-line \/\/ string starting on line 1\)/, + 'a q delimiter repeated on the following line reports a runaway multiline quote'); + +done_testing; diff --git a/src/test/resources/unit/sig_unknown_hook_error.t b/src/test/resources/unit/sig_unknown_hook_error.t new file mode 100644 index 0000000000..a23beb972a --- /dev/null +++ b/src/test/resources/unit/sig_unknown_hook_error.t @@ -0,0 +1,14 @@ +use Test::More; + +my $ok = eval q{$SIG{_HUNGRY} = sub {};}; +ok(!$ok, 'unknown signal hook assignment is rejected'); +like($@, qr/No such hook: _HUNGRY/, 'reports Perl-compatible hook diagnostic'); + +$ok = eval q{$SIG{__WARN__} = sub {}; 1;}; +ok($ok, 'known Perl hook remains assignable'); + +$ok = eval { $SIG{"__WARN__\0"} = sub {}; 1; }; +ok(!$ok, 'unknown hook with trailing NUL is rejected'); +like($@, qr/No such hook: __WARN__\\0/, 'renders trailing NUL visibly in hook diagnostic'); + +done_testing; diff --git a/src/test/resources/unit/sig_unknown_signal_slot.t b/src/test/resources/unit/sig_unknown_signal_slot.t new file mode 100644 index 0000000000..24d98ee138 --- /dev/null +++ b/src/test/resources/unit/sig_unknown_signal_slot.t @@ -0,0 +1,18 @@ +use strict; +use warnings; +use Test::More; + +my @warnings; +{ + local $SIG{__WARN__} = sub { push @warnings, @_ }; + $SIG{HUNGRY} = 'mmm_pie'; +} + +is $SIG{HUNGRY}, 'mmm_pie', + 'an unknown signal name retains its assigned handler'; +like join('', @warnings), qr/^No such signal: SIGHUNGRY/, + 'an unknown signal name emits the signal warning'; +is delete $SIG{HUNGRY}, 'mmm_pie', + 'an unknown signal entry can be deleted after its warning'; + +done_testing; diff --git a/src/test/resources/unit/signature_illegal_operator_diagnostic.t b/src/test/resources/unit/signature_illegal_operator_diagnostic.t new file mode 100644 index 0000000000..4c496c7cd3 --- /dev/null +++ b/src/test/resources/unit/signature_illegal_operator_diagnostic.t @@ -0,0 +1,19 @@ +use strict; +use warnings; +use Test::More; +use IPC::Open3 qw(open3); +use Symbol qw(gensym); + +my $launcher = $^X eq 'jperl' ? './jperl' : $^X; +my $stderr = gensym; +my $pid = open3(undef, my $stdout, $stderr, $launcher, '-e', + q{use feature 'signatures'; sub foo ($a += 1) {}}); +my $output = do { local $/; <$stdout> } . do { local $/; <$stderr> }; +waitpid $pid, 0; + +ok($? != 0, 'compound assignment in a signature fails to compile'); +like($output, + qr{\AIllegal operator following parameter in a subroutine signature at -e line 1, near "\(\$a \+= 1"\nsyntax error at -e line 1, near "\(\$a \+= 1"\n}, + 'signature diagnostic includes the attempted default expression'); + +done_testing; diff --git a/src/test/resources/unit/signature_malformed_diagnostics.t b/src/test/resources/unit/signature_malformed_diagnostics.t new file mode 100644 index 0000000000..3893ec4873 --- /dev/null +++ b/src/test/resources/unit/signature_malformed_diagnostics.t @@ -0,0 +1,14 @@ +use feature 'signatures'; +use Test::More; + +eval "#line 1 signature_malformed_diagnostics.t\nsub bad_numeric (123) { }"; +like($@, + qr/\AA signature parameter must start with '\$', '\@' or '%' at signature_malformed_diagnostics\.t line 1, near "\(1"\nsyntax error at signature_malformed_diagnostics\.t line 1, near "\(123"\n(?:Execution of signature_malformed_diagnostics\.t aborted due to compilation errors\.\n)?\z/, + 'an invalid signature parameter reports both recovered diagnostics'); + +eval "#line 1 signature_malformed_diagnostics.t\nsub bad_separator (\$a 123) { }"; +like($@, + qr/\AIllegal operator following parameter in a subroutine signature at signature_malformed_diagnostics\.t line 1, near "\(\$a 123"\nsyntax error at signature_malformed_diagnostics\.t line 1, near "\(\$a 123"\n(?:Execution of signature_malformed_diagnostics\.t aborted due to compilation errors\.\n)?\z/, + 'a missing signature comma reports both recovered diagnostics'); + +done_testing; diff --git a/src/test/resources/unit/signature_slurpy_diagnostic_span.t b/src/test/resources/unit/signature_slurpy_diagnostic_span.t new file mode 100644 index 0000000000..ff4bff3d74 --- /dev/null +++ b/src/test/resources/unit/signature_slurpy_diagnostic_span.t @@ -0,0 +1,117 @@ +use feature 'signatures'; +use Test::More; + +eval "#line 1 signature_slurpy_diagnostic_span.t\nsub bad (\@a, \$ = 222) { }"; +is($@, + "Slurpy parameter not last at signature_slurpy_diagnostic_span.t line 1, near \"222) \"\n", + 'slurpy ordering diagnostic points at the final default token'); + +eval "#line 1 signature_slurpy_diagnostic_span.t\nsub bad2 (\@, \@b) { }"; +is($@, + "Multiple slurpy parameters not allowed at signature_slurpy_diagnostic_span.t line 1, near \"\@b) \"\n", + 'multiple slurpy diagnostic points at the second slurpy sigil'); + +eval "#line 1 signature_slurpy_diagnostic_span.t\nsub bad2b (\$a, \@b, \$c, \$d) { }"; +is($@, + "Slurpy parameter not last at signature_slurpy_diagnostic_span.t line 1, near \"\$c,\"\n" + . "Slurpy parameter not last at signature_slurpy_diagnostic_span.t line 1, near \"\$d) \"\n", + 'each parameter after a slurpy parameter is diagnosed'); + +eval "#line 1 signature_slurpy_diagnostic_span.t\nsub bad3 (\@a = 222) { }"; +is($@, + "A slurpy parameter may not have a default value at signature_slurpy_diagnostic_span.t line 1, near \"222) \"\n", + 'slurpy default diagnostic points at the default expression'); + +eval "#line 1 signature_slurpy_diagnostic_span.t\nsub bad4 (\@a =) { }"; +is($@, + "A slurpy parameter may not have a default value at signature_slurpy_diagnostic_span.t line 1, near \"=) \"\n", + 'empty slurpy default diagnostic remains anchored at its operator'); + +eval "#line 1 signature_slurpy_diagnostic_span.t\nsub bad5 (\$a =) { }"; +is($@, + "Optional parameter lacks default expression at signature_slurpy_diagnostic_span.t line 1, near \"=) \"\n", + 'empty scalar default diagnostic is anchored at its operator'); + +eval "#line 1 signature_slurpy_diagnostic_span.t\nsub bad6 (\$a = 1, \$b, \$c) { }"; +is($@, + "Mandatory parameter follows optional parameter at signature_slurpy_diagnostic_span.t line 1, near \"\$b,\"\n" + . "Mandatory parameter follows optional parameter at signature_slurpy_diagnostic_span.t line 1, near \"\$c) \"\n", + 'every mandatory parameter after an optional one is diagnosed'); + +eval "#line 1 signature_slurpy_diagnostic_span.t\nsub bad_comma (, \$a) { }"; +is($@, + "syntax error at signature_slurpy_diagnostic_span.t line 1, near \"(,\"\n", + 'leading comma in a signature is a syntax error'); + +SKIP: { + skip 'Perl 5.40 changed this signature recovery diagnostic', 3 if $] < 5.040; + eval "#line 1 signature_slurpy_diagnostic_span.t\nsub bad_hash (\$#foo\na) { }"; + is($@, + "'#' not allowed immediately following a sigil in a subroutine signature at signature_slurpy_diagnostic_span.t line 1, near \"(\$\"\n" + . "syntax error at signature_slurpy_diagnostic_span.t line 2, near \"a\"\n", + 'a hash marker immediately after a signature sigil is recovered with both diagnostics'); + + for my $sigil ('@', '%') { + eval "#line 1 signature_slurpy_diagnostic_span.t\nsub bad_hash (${sigil}#foo\na) { }"; + is($@, + "'#' not allowed immediately following a sigil in a subroutine signature at signature_slurpy_diagnostic_span.t line 1, near \"(${sigil}\"\n" + . "syntax error at signature_slurpy_diagnostic_span.t line 2, near \"a\"\n", + "a hash marker immediately after ${sigil} in a signature is recovered with both diagnostics"); + } +} + +SKIP: { + skip 'named parameters require Perl 5.40', 9 if $] < 5.040; + + eval "#line 1 signature_slurpy_diagnostic_span.t\n" + . "no warnings; sub bad7 (:\$) { }"; + is($@, + "Named parameters must actually have a name at signature_slurpy_diagnostic_span.t line 1, near \"(:\$\"\n", + 'nameless named-parameter diagnostic includes its parameter prefix'); + + eval "#line 1 signature_slurpy_diagnostic_span.t\n" + . "no warnings; sub bad8 (:\$x, \$y) { }"; + is($@, + "Positional parameter follows named parameter at signature_slurpy_diagnostic_span.t line 1, near \"\$y) \"\n", + 'positional parameters cannot follow named parameters'); + + eval "#line 1 signature_slurpy_diagnostic_span.t\n" + . "no warnings; sub bad9 (\@a, :\$b) { }"; + is($@, + "Slurpy parameter not last at signature_slurpy_diagnostic_span.t line 1, near \":\$b) \"\n", + 'slurpy-order diagnostic includes a following named parameter'); + + eval "#line 1 signature_slurpy_diagnostic_span.t\n" + . "no warnings; sub bad10 (:\$x, :\$x) { }"; + is($@, + "Duplicated subroutine parameter name at signature_slurpy_diagnostic_span.t line 1, near \":\$x) \"\n", + 'duplicate named parameters are rejected at the repeated parameter'); + + eval "#line 1 signature_slurpy_diagnostic_span.t\n" + . "no warnings; sub bad11 (\$x = 1, :\$y) { }"; + is($@, + "Mandatory parameter follows optional parameter at signature_slurpy_diagnostic_span.t line 1, near \":\$y) \"\n", + 'mandatory named parameters cannot follow optional positional ones'); + + eval 'sub named_missing (:$alpha, :$beta) { }'; + die $@ if $@; + eval { named_missing() }; + like($@, qr/Missing required named parameters 'alpha', 'beta'/, + 'named signatures report all missing required parameters'); + + eval 'sub named_extra (:$alpha) { }'; + die $@ if $@; + eval { named_extra(alpha => 1, gamma => 2, delta => 3) }; + like($@, qr/Unrecognized named parameters 'gamma', 'delta'/, + 'named signatures report all unrecognized parameters'); + + eval { named_extra(alpha => 1, 'a' .. 'z') }; + like($@, qr/Unrecognized named parameters 'a', 'c', 'e', 'g', 'i', \.\.\./, + 'unrecognized named parameters are capped in diagnostics'); + + eval { named_missing(alpha => 1) }; + like($@, qr/Missing required named parameter 'beta'/, + 'a single missing named parameter retains singular wording'); +} + +done_testing; diff --git a/src/test/resources/unit/smartmatch_predicate_loop_control_error.t b/src/test/resources/unit/smartmatch_predicate_loop_control_error.t new file mode 100644 index 0000000000..646e2f889f --- /dev/null +++ b/src/test/resources/unit/smartmatch_predicate_loop_control_error.t @@ -0,0 +1,16 @@ +use strict; +use warnings; +use Test::More; + +for my $operator (qw(last next redo)) { + my $result = eval "0 ~~ sub { $operator } for 0; 1"; + ok(!defined($result), "$operator cannot escape a smartmatch predicate CV"); + like($@, qr/Can't "$operator" outside a loop block/, + "$operator reports the loop-boundary error"); +} + +my $goto_result = eval q{FOO: 0 ~~ sub { goto FOO } for 0; 1}; +ok(!defined($goto_result), 'goto cannot escape a smartmatch predicate CV'); +like($@, qr/Can't find label FOO/, 'goto reports the missing local label'); + +done_testing; diff --git a/src/test/resources/unit/state_goto_redo_initialization.t b/src/test/resources/unit/state_goto_redo_initialization.t new file mode 100644 index 0000000000..236562204c --- /dev/null +++ b/src/test/resources/unit/state_goto_redo_initialization.t @@ -0,0 +1,18 @@ +use strict; +use warnings; +use feature 'state'; +use Test::More; + +my $vi; +{ + goto Elvis unless $vi; + state $calvin = ++$vi; + Elvis: state $vile = ++$vi; + redo unless defined $calvin; + + is $calvin, 2, 'redo initializes state declaration skipped by goto'; + is $vile, 1, 'previously initialized state remains unchanged'; + is $vi, 2, 'redo re-enters the block before the label'; +} + +done_testing; diff --git a/src/test/resources/unit/state_list_assignment_error.t b/src/test/resources/unit/state_list_assignment_error.t new file mode 100644 index 0000000000..928f0e41cc --- /dev/null +++ b/src/test/resources/unit/state_list_assignment_error.t @@ -0,0 +1,8 @@ +use Test::More; +use feature 'state'; + +my $ok = eval '($_, state $x) = (); 1'; +ok(!$ok, 'state declaration in list assignment is rejected'); +like($@, qr/Initialization of state variables in list currently forbidden/, + 'reports the state list assignment error'); +done_testing; diff --git a/src/test/resources/unit/state_parenthesized_default.t b/src/test/resources/unit/state_parenthesized_default.t new file mode 100644 index 0000000000..06815a79f5 --- /dev/null +++ b/src/test/resources/unit/state_parenthesized_default.t @@ -0,0 +1,15 @@ +use strict; +use warnings; +use feature 'state'; +use Test::More; + +sub next_value { + state ($value) //= 3; + return $value++; +} + +is(next_value(), 3, 'parenthesized state default initializes once'); +is(next_value(), 4, 'parenthesized state default persists across calls'); +is(next_value(), 5, 'parenthesized state default continues incrementing'); + +done_testing; diff --git a/src/test/resources/unit/strict_vars_before_syntax_error.t b/src/test/resources/unit/strict_vars_before_syntax_error.t new file mode 100644 index 0000000000..9ba33a1d6f --- /dev/null +++ b/src/test/resources/unit/strict_vars_before_syntax_error.t @@ -0,0 +1,17 @@ +use strict; +use warnings; +use Test::More; + +my $ok = eval q{ + use warnings FATAL => 'all'; + use strict; + $foo; + myfunc 1, 2, 3; +}; + +ok(!$ok, 'strict and syntax diagnostics reject the source'); +like($@, qr/Global symbol "\$foo" requires explicit package name/, 'reports strict-vars error first'); +like($@, qr/Number found where operator expected/, 'retains later parser warning'); +like($@, qr/syntax error/, 'retains later syntax error'); + +done_testing; diff --git a/src/test/resources/unit/sysread_syswrite_utf8_error.t b/src/test/resources/unit/sysread_syswrite_utf8_error.t new file mode 100644 index 0000000000..b7b0b58077 --- /dev/null +++ b/src/test/resources/unit/sysread_syswrite_utf8_error.t @@ -0,0 +1,23 @@ +use strict; +use warnings; +use File::Temp qw(tempfile); +use Test::More; + +my ($seed, $path) = tempfile(); +print {$seed} 'abc'; +close $seed; + +open my $reader, '<:utf8', $path or die "open reader: $!"; +my $buffer; +eval { sysread $reader, $buffer, 1; 1 }; +is($@, "sysread() isn't allowed on :utf8 handles at $0 line 12.\n", + 'sysread uses Perl-compatible utf8-layer diagnostic'); +close $reader; + +open my $writer, '>:utf8', $path or die "open writer: $!"; +eval { syswrite $writer, 'x'; 1 }; +is($@, "syswrite() isn't allowed on :utf8 handles at $0 line 18.\n", + 'syswrite uses Perl-compatible utf8-layer diagnostic'); +close $writer; + +done_testing; diff --git a/src/test/resources/unit/transliteration_octal_escape_diagnostic.t b/src/test/resources/unit/transliteration_octal_escape_diagnostic.t new file mode 100644 index 0000000000..2dd58517d9 --- /dev/null +++ b/src/test/resources/unit/transliteration_octal_escape_diagnostic.t @@ -0,0 +1,11 @@ +use strict; +use warnings; +use Test::More; + +my $result = eval q{tr/\o-0//}; +ok(!defined $result, 'malformed braced octal escape in transliteration fails'); +like($@, + qr{\AMissing braces on \\o\{\} at \(eval \d+\) line 1, within string\n?\z}, + 'transliteration reports the braced-octal diagnostic before range parsing'); + +done_testing; diff --git a/src/test/resources/unit/transliteration_unicode_regressions.t b/src/test/resources/unit/transliteration_unicode_regressions.t new file mode 100644 index 0000000000..ec551a2b22 --- /dev/null +++ b/src/test/resources/unit/transliteration_unicode_regressions.t @@ -0,0 +1,14 @@ +use strict; +use warnings; +use Test::More; + +my $named_sequence = eval q{tr/a/\N{KATAKANA LETTER AINU P}/; 1}; +ok(!defined($named_sequence), 'tr rejects a Unicode named sequence'); +like($@, qr/\N\{KATAKANA LETTER AINU P\} must not be a named sequence in transliteration operator/, + 'named sequence diagnostic identifies transliteration'); + +my $text = "A\x{ffff}B"; +$text =~ tr/\x{ffff}/\x{1ffff}/; +is($text, "A\x{1ffff}B", 'tr preserves a supplementary replacement code point'); + +done_testing(); diff --git a/src/test/resources/unit/try_catch_declaration_diagnostics.t b/src/test/resources/unit/try_catch_declaration_diagnostics.t new file mode 100644 index 0000000000..000aab05cf --- /dev/null +++ b/src/test/resources/unit/try_catch_declaration_diagnostics.t @@ -0,0 +1,17 @@ +use strict; +use warnings; +use feature 'try'; +use Test::More; + +plan skip_all => 'catch declaration diagnostic changed in Perl 5.44' + if $^V lt v5.44.0; + +for my $declaration (qw(my our state)) { + my $prefix = $declaration eq 'state' ? "use feature 'state';\n" : ''; + my $ok = eval $prefix . "try {} catch ($declaration \$error) {}"; + ok(!$ok, "catch ($declaration) fails"); + like($@, qr{\ACan't redeclare catch variable as "\Q$declaration\E" at \(eval \d+\) line \d+, near "\(\Q$declaration\E"\nsyntax error at \(eval \d+\) line \d+, near "\(\Q$declaration\E "}, + "catch ($declaration) reports both Perl diagnostics"); +} + +done_testing; diff --git a/src/test/resources/unit/typed_lexical_fields_stub.t b/src/test/resources/unit/typed_lexical_fields_stub.t new file mode 100644 index 0000000000..f388d718db --- /dev/null +++ b/src/test/resources/unit/typed_lexical_fields_stub.t @@ -0,0 +1,11 @@ +use strict; +use warnings; +use Test::More; + +my main $record; +sub FIELDS; + +ok eval { $$record{field}; 1 }, 'a FIELDS sub stub does not impose field validation on a hash element'; +ok eval { @$record{qw(first second)}; 1 }, 'a FIELDS sub stub does not impose field validation on a hash slice'; + +done_testing; diff --git a/src/test/resources/unit/undef_code_reference_error.t b/src/test/resources/unit/undef_code_reference_error.t new file mode 100644 index 0000000000..367ae8d262 --- /dev/null +++ b/src/test/resources/unit/undef_code_reference_error.t @@ -0,0 +1,9 @@ +use strict; +use warnings; +use Test::More; + +eval q{ &{+undef}; 1 }; +like($@, qr/Can't use an undefined value as a subroutine reference/, + 'calling an undefined code reference reports Perl\'s undef diagnostic'); + +done_testing; diff --git a/src/test/resources/unit/undef_multiple_argument_diagnostics.t b/src/test/resources/unit/undef_multiple_argument_diagnostics.t new file mode 100644 index 0000000000..a557e36569 --- /dev/null +++ b/src/test/resources/unit/undef_multiple_argument_diagnostics.t @@ -0,0 +1,11 @@ +use strict; +use warnings; +use Test::More; + +my $result = eval "undef(1,2);\nundef(1,2);\n"; +ok(!defined $result, 'multiple-argument undef expressions fail to compile'); +like($@, + qr{\AToo many arguments for undef operator at \(eval \d+\) line 1, near "2\)"\nToo many arguments for undef operator at \(eval \d+\) line 2, near "2\)"\n\z}, + 'all malformed undef expressions report their argument locations'); + +done_testing; diff --git a/src/test/resources/unit/undefined_sub_close_label.t b/src/test/resources/unit/undefined_sub_close_label.t new file mode 100644 index 0000000000..5de67c29c4 --- /dev/null +++ b/src/test/resources/unit/undefined_sub_close_label.t @@ -0,0 +1,18 @@ +use strict; +use warnings; +use Test::More; + +package BEEP; +sub boop; + +package main; +my $result = eval q{ + BEEP: boop(); + 1; +}; + +ok(!defined($result), 'an undefined direct call dies'); +like($@, qr/Undefined subroutine &main::boop called, close to label 'BEEP'/, + 'the undefined-call diagnostic identifies the preceding label'); + +done_testing; diff --git a/src/test/resources/unit/unicode_identifier_start_fallback.t b/src/test/resources/unit/unicode_identifier_start_fallback.t new file mode 100644 index 0000000000..bee0a83623 --- /dev/null +++ b/src/test/resources/unit/unicode_identifier_start_fallback.t @@ -0,0 +1,10 @@ +use strict; +use warnings; +use utf8; +use Test::More; + +my $Ⅻ = 'roman numeral'; + +is $Ⅻ, 'roman numeral', 'a Unicode Letter_Number can start a lexical variable'; + +done_testing; diff --git a/src/test/resources/unit/unterminated_heredoc_delimiter_diagnostic.t b/src/test/resources/unit/unterminated_heredoc_delimiter_diagnostic.t new file mode 100644 index 0000000000..636e00d1df --- /dev/null +++ b/src/test/resources/unit/unterminated_heredoc_delimiter_diagnostic.t @@ -0,0 +1,12 @@ +use strict; +use warnings; +use Test::More; + +my $ok = eval q{<<"foo}; + +ok(!$ok, 'unterminated quoted heredoc delimiter fails'); +like($@, + qr{\AUnterminated delimiter for here document at \(eval \d+\) line 1\.\n\z}, + 'unterminated quoted heredoc delimiter reports the dedicated diagnostic'); + +done_testing; diff --git a/src/test/resources/unit/unterminated_prototype_diagnostic.t b/src/test/resources/unit/unterminated_prototype_diagnostic.t new file mode 100644 index 0000000000..42891c82ef --- /dev/null +++ b/src/test/resources/unit/unterminated_prototype_diagnostic.t @@ -0,0 +1,17 @@ +use strict; +use warnings; +use Test::More; +use IPC::Open3 qw(open3); +use Symbol qw(gensym); + +my $launcher = $^X eq 'jperl' ? './jperl' : $^X; +my $stderr = gensym; +my $pid = open3(undef, my $stdout, $stderr, $launcher, '-e', "sub t1 {}\nsub t2 (}"); +my $output = do { local $/; <$stdout> } . do { local $/; <$stderr> }; +waitpid $pid, 0; + +ok($? != 0, 'unterminated prototype fails to compile'); +is($output, "Prototype not terminated at -e line 2.\n", + 'unterminated prototype has Perl-compatible diagnostic'); + +done_testing; diff --git a/src/test/resources/unit/unterminated_string_delimiter_diagnostics.t b/src/test/resources/unit/unterminated_string_delimiter_diagnostics.t new file mode 100644 index 0000000000..d9967dbad8 --- /dev/null +++ b/src/test/resources/unit/unterminated_string_delimiter_diagnostics.t @@ -0,0 +1,17 @@ +use strict; +use warnings; +use Test::More; + +for my $case ( + [q{q/}, qr{\ACan't find string terminator "/" anywhere before EOF at \(eval \d+\) line 1\.\n\z}], + [q{qw/}, qr{\ACan't find string terminator "/" anywhere before EOF at \(eval \d+\) line 1\.\n\z}], + [q{'}, qr{\ACan't find string terminator "'" anywhere before EOF at \(eval \d+\) line 1\.\n\z}], + [q{"}, qr{\ACan't find string terminator '"' anywhere before EOF at \(eval \d+\) line 1\.\n\z}], +) { + my ($source, $expected) = @$case; + my $ok = eval $source; + ok(!$ok, "unterminated $source fails"); + like($@, $expected, "unterminated $source reports its opening delimiter"); +} + +done_testing; diff --git a/src/test/resources/unit/use_version_scope.t b/src/test/resources/unit/use_version_scope.t new file mode 100644 index 0000000000..078036621b --- /dev/null +++ b/src/test/resources/unit/use_version_scope.t @@ -0,0 +1,7 @@ +use Test::More; + +my $ok = eval "use v5.20;\nuse v5.39;\n1"; +ok(!$ok, 'second use VERSION is rejected'); +like($@, qr/use VERSION of 5\.39 or above is not permitted/, 'reports the high-version conflict'); + +done_testing; diff --git a/src/test/resources/unit/when_default_topicalizer_error.t b/src/test/resources/unit/when_default_topicalizer_error.t new file mode 100644 index 0000000000..e76eb0e1b0 --- /dev/null +++ b/src/test/resources/unit/when_default_topicalizer_error.t @@ -0,0 +1,12 @@ +use Test::More; + +for my $keyword (qw(when default)) { + my $ok = eval "use v5.10; $keyword" . ($keyword eq 'when' ? '(undef)' : '') . '{}'; + ok(!$ok, "$keyword outside given is rejected"); + like($@, qr/Can't \"$keyword\" outside a topicalizer/, "$keyword has Perl-compatible diagnostic"); +} + +my $ok = eval q{use v5.10; no warnings 'experimental::smartmatch'; given (1) { when (1) {} default {} } 1;}; +ok($ok, 'when and default remain valid inside given'); + +done_testing;