diff --git a/src/main/java/org/perlonjava/app/cli/ArgumentParser.java b/src/main/java/org/perlonjava/app/cli/ArgumentParser.java index 608754117..baec4abbf 100644 --- a/src/main/java/org/perlonjava/app/cli/ArgumentParser.java +++ b/src/main/java/org/perlonjava/app/cli/ArgumentParser.java @@ -326,6 +326,25 @@ private static void processShebangLine(String[] args, CompilerOptions parsedArgs return; } + if (processPerlShebangSwitches(shebangLine, parsedArgs)) { + return; + } + + // Alternate interpreter (perlrun): if there is no word "perl"/"indir", exec the named program. + // Example: Inline's TestML tests start with "#!inc/bin/testml-cpan". + String[] tokens = shebangLine.split("\\s+"); + if (tokens.length == 0) { + return; + } + if (isPerlOnJavaExecutable(Paths.get(tokens[0]))) { + // Same binary as this runtime (e.g. "#!/path/to/jperl"): compile here; do not re-exec. + return; + } + List cmd = buildShebangCommand(tokens); + delegateToShebangInterpreter(args, cmd, index); + } + + private static boolean processPerlShebangSwitches(String shebangLine, CompilerOptions parsedArgs) { // perlrun: parsing of #! switches starts at a *word* "perl" or "indir". // Substrings like "jperl" must NOT match (matches stock perl behavior). Matcher perlWord = Pattern.compile("\\b(?:perl|indir)\\b", Pattern.CASE_INSENSITIVE).matcher(shebangLine); @@ -348,21 +367,10 @@ private static void processShebangLine(String[] args, CompilerOptions parsedArgs .filter(arg -> !arg.isEmpty()) .toArray(String[]::new); processArgs(nonEmptyArgs, parsedArgs); - return; + return true; } - // Alternate interpreter (perlrun): if there is no word "perl"/"indir", exec the named program. - // Example: Inline's TestML tests start with "#!inc/bin/testml-cpan". - String[] tokens = shebangLine.split("\\s+"); - if (tokens.length == 0) { - return; - } - if (isPerlOnJavaExecutable(Paths.get(tokens[0]))) { - // Same binary as this runtime (e.g. "#!/path/to/jperl"): compile here; do not re-exec. - return; - } - List cmd = buildShebangCommand(tokens); - delegateToShebangInterpreter(args, cmd, index); + return false; } /** @@ -1242,6 +1250,10 @@ private static void modifyCodeBasedOnFlags(CompilerOptions parsedArgs) { if (parsedArgs.discardLeadingGarbage) { // '-x' extract Perl code after discarding leading garbage + if ("-e".equals(parsedArgs.fileName)) { + System.err.println("No Perl script found in input"); + System.exit(1); + } String fileContent = parsedArgs.code; String[] lines = fileContent.split("\n"); boolean perlCodeStarted = false; @@ -1250,8 +1262,12 @@ private static void modifyCodeBasedOnFlags(CompilerOptions parsedArgs) { for (String line : lines) { if (perlCodeStarted) { perlCode.append(line).append("\n"); - } else if (line.trim().equals("#!perl")) { - perlCodeStarted = true; + } else { + String trimmedLine = line.trim(); + if (trimmedLine.startsWith("#!") + && processPerlShebangSwitches(trimmedLine.substring(2).trim(), parsedArgs)) { + perlCodeStarted = true; + } } } diff --git a/src/main/java/org/perlonjava/app/scriptengine/PerlLanguageProvider.java b/src/main/java/org/perlonjava/app/scriptengine/PerlLanguageProvider.java index 09d026902..9435629d5 100644 --- a/src/main/java/org/perlonjava/app/scriptengine/PerlLanguageProvider.java +++ b/src/main/java/org/perlonjava/app/scriptengine/PerlLanguageProvider.java @@ -283,6 +283,7 @@ public static RuntimeList executePerlAST(Node ast, // Save the current scope so we can restore it after execution. ScopedSymbolTable savedCurrentScope = SpecialBlockParser.getCurrentScope(); + int savedCurrentScopeIndex = savedCurrentScope != null ? savedCurrentScope.currentScopeIndex() : -1; // Save and clear the eval runtime context (same reason as executePerlCode) RuntimeCode.EvalRuntimeContext savedEvalRuntimeContext = @@ -293,24 +294,12 @@ public static RuntimeList executePerlAST(Node ast, globalSymbolTable.addVariable("this", "", null); globalSymbolTable.addVariable("@_", "our", null); globalSymbolTable.addVariable("wantarray", "", null); + int executionFlagScopeIndex = globalSymbolTable.currentScopeIndex(); - // Inherit $^H (strictOptions) from the caller's scope so BEGIN blocks - // can see and modify the enclosing scope's compile-time hints + // Inherit lexical pragma flags from the caller's scope so BEGIN blocks + // can see and modify the enclosing scope's compile-time hints. if (savedCurrentScope != null) { - globalSymbolTable.setStrictOptions(savedCurrentScope.getStrictOptions()); - // Inherit warning flags so ${^WARNING_BITS} returns correct values in BEGIN blocks - if (!savedCurrentScope.warningFlagsStack.isEmpty()) { - globalSymbolTable.warningFlagsStack.pop(); - globalSymbolTable.warningFlagsStack.push((java.util.BitSet) savedCurrentScope.warningFlagsStack.peek().clone()); - } - if (!savedCurrentScope.warningDisabledStack.isEmpty()) { - globalSymbolTable.warningDisabledStack.pop(); - globalSymbolTable.warningDisabledStack.push((java.util.BitSet) savedCurrentScope.warningDisabledStack.peek().clone()); - } - if (!savedCurrentScope.warningFatalStack.isEmpty()) { - globalSymbolTable.warningFatalStack.pop(); - globalSymbolTable.warningFatalStack.push((java.util.BitSet) savedCurrentScope.warningFatalStack.peek().clone()); - } + globalSymbolTable.copyFlagsFrom(savedCurrentScope, savedCurrentScopeIndex); } EmitterContext ctx = new EmitterContext( @@ -346,12 +335,12 @@ public static RuntimeList executePerlAST(Node ast, return executeCode(runtimeCode, ast, ctx, false, contextType); } finally { - // Propagate $^H changes back to the caller's scope so subsequent - // code in the same lexical block sees the updated hints + // Propagate pragma changes back to the caller's scope so subsequent + // code in the same lexical block sees BEGIN-time feature/warning hints. if (savedCurrentScope != null) { - savedCurrentScope.setStrictOptions(ctx.symbolTable.getStrictOptions()); + savedCurrentScope.copyFlagsFrom(ctx.symbolTable, executionFlagScopeIndex); // Also update per-call-site hints so caller()[8] and caller()[10] are correct - WarningBitsRegistry.setCallSiteHints(ctx.symbolTable.getStrictOptions()); + WarningBitsRegistry.setCallSiteHints(savedCurrentScope.getStrictOptions()); WarningBitsRegistry.snapshotCurrentHintHash(); SpecialBlockParser.setCurrentScope(savedCurrentScope); } diff --git a/src/main/java/org/perlonjava/backend/bytecode/CompileOperator.java b/src/main/java/org/perlonjava/backend/bytecode/CompileOperator.java index 10372777b..96e5e44bf 100644 --- a/src/main/java/org/perlonjava/backend/bytecode/CompileOperator.java +++ b/src/main/java/org/perlonjava/backend/bytecode/CompileOperator.java @@ -553,6 +553,19 @@ private static void visitDefined(BytecodeCompiler bc, OperatorNode node) { // defined(&name) - use stash lookup to match JVM backend/Perl 5 behavior if (operand instanceof OperatorNode opNode && opNode.operator.equals("&") && opNode.operand instanceof IdentifierNode idNode) { + if (opNode.getAnnotation("parseTimeCodeRef") instanceof RuntimeScalar) { + bc.compileNode(opNode, -1, RuntimeContextType.SCALAR); + int codeRefReg = bc.lastResultReg; + int pkgIdx = bc.addToStringPool(bc.getCurrentPackage()); + int rd = bc.allocateOutputRegister(); + bc.emit(Opcodes.DEFINED_CODE_DYNAMIC); + bc.emitReg(rd); + bc.emitReg(codeRefReg); + bc.emit(pkgIdx); + bc.lastResultReg = rd; + return; + } + String subName = NameNormalizer.normalizeVariableName( idNode.name, bc.getCurrentPackage()); int nameIdx = bc.addToStringPool(subName); diff --git a/src/main/java/org/perlonjava/backend/bytecode/InterpretedCode.java b/src/main/java/org/perlonjava/backend/bytecode/InterpretedCode.java index f6a1a3490..834fc2f37 100644 --- a/src/main/java/org/perlonjava/backend/bytecode/InterpretedCode.java +++ b/src/main/java/org/perlonjava/backend/bytecode/InterpretedCode.java @@ -331,6 +331,7 @@ public RuntimeList apply(RuntimeArray args, int callContext) { // Push args for getCallerArgs() support (used by List::Util::any/all/etc.) // This matches what RuntimeCode.apply() does for JVM-compiled subs RuntimeCode.pushArgs(args); + RuntimeCode.pushCallContext(callContext); RuntimeCode.pushActiveCode(this); // Push warning bits for FATAL warnings support // This allows runtime code to check current warning context @@ -368,6 +369,7 @@ public RuntimeList apply(String subroutineName, RuntimeArray args, int callConte int effectiveContext = RuntimeCode.effectiveCallContext(this, callContext); // Push args for getCallerArgs() support (used by List::Util::any/all/etc.) RuntimeCode.pushArgs(args); + RuntimeCode.pushCallContext(callContext); RuntimeCode.pushActiveCode(this); // Push warning bits for FATAL warnings support if (warningBitsString != null) { diff --git a/src/main/java/org/perlonjava/backend/jvm/EmitOperatorDeleteExists.java b/src/main/java/org/perlonjava/backend/jvm/EmitOperatorDeleteExists.java index ac0d512fc..594ea5e5a 100644 --- a/src/main/java/org/perlonjava/backend/jvm/EmitOperatorDeleteExists.java +++ b/src/main/java/org/perlonjava/backend/jvm/EmitOperatorDeleteExists.java @@ -7,9 +7,11 @@ import org.perlonjava.frontend.analysis.EmitterVisitor; import org.perlonjava.frontend.astnode.*; import org.perlonjava.runtime.operators.OperatorHandler; +import org.perlonjava.runtime.runtimetypes.GlobalVariable; import org.perlonjava.runtime.runtimetypes.NameNormalizer; import org.perlonjava.runtime.runtimetypes.PerlCompilerException; import org.perlonjava.runtime.runtimetypes.RuntimeContextType; +import org.perlonjava.runtime.runtimetypes.RuntimeScalar; public class EmitOperatorDeleteExists { // Handles the 'delete' and 'exists' operators for hash elements. @@ -197,7 +199,11 @@ static void handleDefined(OperatorNode node, String operator, if (operator.equals("defined") && operatorNode.operator.equals("&")) { if (CompilerOptions.DEBUG_ENABLED) emitterVisitor.ctx.logDebug("defined & " + operatorNode.operand); if (operatorNode.operand instanceof IdentifierNode identifierNode) { - // exists &sub + if (operatorNode.getAnnotation("parseTimeCodeRef") instanceof RuntimeScalar codeRef) { + handleDefinedSubroutineCodeRef(emitterVisitor, codeRef); + return; + } + // defined &sub handleExistsSubroutine(emitterVisitor, operator, identifierNode); return; } @@ -258,6 +264,25 @@ private static void handleExistsSubroutine(EmitterVisitor emitterVisitor, String EmitOperator.handleVoidContext(emitterVisitor); } + private static void handleDefinedSubroutineCodeRef(EmitterVisitor emitterVisitor, RuntimeScalar codeRef) { + MethodVisitor mv = emitterVisitor.ctx.mv; + int codeRefId = GlobalVariable.registerCompiledCodeRef(codeRef); + mv.visitLdcInsn(codeRefId); + mv.visitMethodInsn( + Opcodes.INVOKESTATIC, + "org/perlonjava/runtime/runtimetypes/GlobalVariable", + "getCompiledCodeRef", + "(I)Lorg/perlonjava/runtime/runtimetypes/RuntimeScalar;", + false); + mv.visitMethodInsn( + Opcodes.INVOKESTATIC, + "org/perlonjava/runtime/runtimetypes/GlobalVariable", + "definedGlobalCodeRefAsScalar", + "(Lorg/perlonjava/runtime/runtimetypes/RuntimeScalar;)Lorg/perlonjava/runtime/runtimetypes/RuntimeScalar;", + false); + EmitOperator.handleVoidContext(emitterVisitor); + } + private static void handleExistsSubroutine(EmitterVisitor emitterVisitor, String operator, OperatorNode operatorNode) { // exists &{"sub"} operatorNode.accept(emitterVisitor.with(RuntimeContextType.SCALAR)); diff --git a/src/main/java/org/perlonjava/frontend/semantic/ScopedSymbolTable.java b/src/main/java/org/perlonjava/frontend/semantic/ScopedSymbolTable.java index e4451b99c..fef877084 100644 --- a/src/main/java/org/perlonjava/frontend/semantic/ScopedSymbolTable.java +++ b/src/main/java/org/perlonjava/frontend/semantic/ScopedSymbolTable.java @@ -981,25 +981,45 @@ public void copyFlagsFrom(ScopedSymbolTable source) { throw new IllegalArgumentException("Source ScopedSymbolTable cannot be null."); } + copyFlagsFrom(source, source.currentScopeIndex()); + } + + /** + * Copies flags from a specific source scope depth into this table's current scope. + * + * BEGIN/eval execution can temporarily leave the execution symbol table inside a + * nested scope after a caught parse error. Copying from the caller's original + * scope depth preserves pragma changes made in that lexical block without + * importing flags from an abandoned inner scope. + * + * @param source The source ScopedSymbolTable from which to copy the flags. + * @param sourceScopeIndex The lexical scope index to copy from. + */ + public void copyFlagsFrom(ScopedSymbolTable source, int sourceScopeIndex) { + if (source == null) { + throw new IllegalArgumentException("Source ScopedSymbolTable cannot be null."); + } + int index = Math.max(0, Math.min(sourceScopeIndex, source.warningFlagsStack.size() - 1)); + // Copy warning flags this.warningFlagsStack.pop(); - this.warningFlagsStack.push((BitSet) source.warningFlagsStack.peek().clone()); + this.warningFlagsStack.push((BitSet) source.warningFlagsStack.get(index).clone()); // Copy disabled warnings flags this.warningDisabledStack.pop(); - this.warningDisabledStack.push((BitSet) source.warningDisabledStack.peek().clone()); + this.warningDisabledStack.push((BitSet) source.warningDisabledStack.get(index).clone()); // Copy fatal warnings flags this.warningFatalStack.pop(); - this.warningFatalStack.push((BitSet) source.warningFatalStack.peek().clone()); + this.warningFatalStack.push((BitSet) source.warningFatalStack.get(index).clone()); // Copy feature flags this.featureFlagsStack.pop(); - this.featureFlagsStack.push(source.featureFlagsStack.peek()); + this.featureFlagsStack.push(source.featureFlagsStack.get(index)); // Copy strict options this.strictOptionsStack.pop(); - this.strictOptionsStack.push(source.strictOptionsStack.peek()); + this.strictOptionsStack.push(source.strictOptionsStack.get(index)); } public record PackageInfo(String packageName, boolean isClass, String version) { diff --git a/src/main/java/org/perlonjava/runtime/perlmodule/Universal.java b/src/main/java/org/perlonjava/runtime/perlmodule/Universal.java index 87332388d..88e6762d5 100644 --- a/src/main/java/org/perlonjava/runtime/perlmodule/Universal.java +++ b/src/main/java/org/perlonjava/runtime/perlmodule/Universal.java @@ -331,7 +331,8 @@ public static RuntimeList isa(RuntimeArray args, int ctx) { || (argString.equals("ARRAY") && baseValue instanceof RuntimeArray) || (argString.equals("SCALAR") && baseValue instanceof RuntimeScalar) || (argString.equals("GLOB") && baseValue instanceof RuntimeGlob) - || (argString.equals("FORMAT") && baseValue instanceof RuntimeFormat)) { + || (argString.equals("FORMAT") && baseValue instanceof RuntimeFormat) + || (argString.equals("CODE") && baseValue instanceof RuntimeCode)) { return getScalarBoolean(true).getList(); } } diff --git a/src/main/java/org/perlonjava/runtime/regex/RuntimeRegex.java b/src/main/java/org/perlonjava/runtime/regex/RuntimeRegex.java index 27b67ac25..67184e84b 100644 --- a/src/main/java/org/perlonjava/runtime/regex/RuntimeRegex.java +++ b/src/main/java/org/perlonjava/runtime/regex/RuntimeRegex.java @@ -1916,6 +1916,77 @@ private static RuntimeBase matchRegexWithTimeout(RuntimeScalar quotedRegex, Runt * @param ctx The context LIST, SCALAR, VOID. * @return A RuntimeScalar or RuntimeList. */ + private static Pattern compileNonEmptySubstitutionPattern(Pattern pattern) { + try { + return Pattern.compile("(?:" + pattern.pattern() + ")(?<=[\\s\\S])", pattern.flags()); + } catch (RuntimeException e) { + return null; + } + } + + private static int bumpGlobalMatchPosition(String inputStr, int offset) { + if (offset >= inputStr.length()) { + return inputStr.length() + 1; + } + return offset + Character.charCount(inputStr.codePointAt(offset)); + } + + private static void setSubstitutionRegion(Matcher matcher, int start, int end, boolean transparentBounds) { + matcher.region(start, end); + // The substitution loop drives the matcher by changing regions. Keep + // ^/$ anchored to the real input, not to each artificial region start. + matcher.useAnchoringBounds(false); + // Lookbehind/lookahead assertions should still inspect the full input + // around the current search start, matching Perl's pos()-style scan. + matcher.useTransparentBounds(transparentBounds); + } + + private static void updateReplacementMatchState(RuntimeRegex regex, Matcher matcher, + String inputStr, RuntimeScalar string) { + lastMatchWasByteString = (string.type == RuntimeScalarType.BYTE_STRING); + + // Initialize $1, $2, @+, @- only when we have a match + globalMatcher = matcher; + globalMatchString = inputStr; + lastMatchUsedBackslashK = regex.hasBackslashK; + updateLastNamedCaptureGroups(matcher); + if (matcher.groupCount() > 0) { + if (regex.hasBackslashK) { + // Skip the internal perlK capture group when populating $1, $2, etc. + int perlKGroup = getPerlKGroup(matcher); + int userGroupCount = matcher.groupCount() - 1; + if (userGroupCount > 0) { + lastCaptureGroups = new String[userGroupCount]; + int destIdx = 0; + for (int i = 1; i <= matcher.groupCount(); i++) { + if (i == perlKGroup) continue; + lastCaptureGroups[destIdx++] = matcher.group(i); + } + } else { + lastCaptureGroups = null; + } + } else { + lastCaptureGroups = new String[matcher.groupCount()]; + for (int i = 0; i < matcher.groupCount(); i++) { + lastCaptureGroups[i] = matcher.group(i + 1); + } + } + } else { + lastCaptureGroups = null; + } + + // For \K, adjust match start so $& is only the post-\K portion + if (regex.hasBackslashK) { + int keepEnd = matcher.end("perlK"); + lastMatchStart = keepEnd; + lastMatchedString = inputStr.substring(keepEnd, matcher.end()); + } else { + lastMatchStart = matcher.start(); + lastMatchedString = matcher.group(0); + } + lastMatchEnd = matcher.end(); + } + public static RuntimeBase replaceRegex(RuntimeScalar quotedRegex, RuntimeScalar string, int ctx) { // Convert the input string to a Java string String inputStr = string.toString(); @@ -2007,6 +2078,10 @@ public static RuntimeBase replaceRegex(RuntimeScalar quotedRegex, RuntimeScalar CharSequence matchInput = new RegexTimeoutCharSequence(inputStr); Matcher matcher = pattern.matcher(matchInput); + Pattern nonEmptySubstitutionPattern = regex.regexFlags != null && regex.regexFlags.isGlobalMatch() + ? compileNonEmptySubstitutionPattern(pattern) + : null; + int searchStart = 0; // Honor pos() when \G is used. `s/\G.../.../` should anchor at // pos($string) so a substitution inserted right after a previous /g @@ -2019,10 +2094,7 @@ public static RuntimeBase replaceRegex(RuntimeScalar quotedRegex, RuntimeScalar if (posScalar.getDefinedBoolean()) { int startPos = posScalar.getInt(); if (startPos >= 0 && startPos <= inputStr.length()) { - matcher.region(startPos, inputStr.length()); - // Same rationale as matchRegex: keep ^/$ from anchoring - // at the artificial region boundary under /m. - matcher.useAnchoringBounds(false); + searchStart = startPos; } } } @@ -2043,52 +2115,19 @@ public static RuntimeBase replaceRegex(RuntimeScalar quotedRegex, RuntimeScalar // Track position for manual replacement when \K is used int lastAppendEnd = 0; - // Perform the substitution + // Perform the substitution. Java's Matcher.find() skips ahead after a + // zero-length match; Perl's global substitution first retries at the + // same offset with a non-empty match. Track append/search positions + // explicitly so nullable patterns like /(.*?)(x)?/g behave like Perl. try { - while (matcher.find()) { - found++; - lastMatchWasByteString = (string.type == RuntimeScalarType.BYTE_STRING); - - // Initialize $1, $2, @+, @- only when we have a match - globalMatcher = matcher; - globalMatchString = inputStr; - lastMatchUsedBackslashK = regex.hasBackslashK; - updateLastNamedCaptureGroups(matcher); - if (matcher.groupCount() > 0) { - if (regex.hasBackslashK) { - // Skip the internal perlK capture group when populating $1, $2, etc. - int perlKGroup = getPerlKGroup(matcher); - int userGroupCount = matcher.groupCount() - 1; - if (userGroupCount > 0) { - lastCaptureGroups = new String[userGroupCount]; - int destIdx = 0; - for (int i = 1; i <= matcher.groupCount(); i++) { - if (i == perlKGroup) continue; - lastCaptureGroups[destIdx++] = matcher.group(i); - } - } else { - lastCaptureGroups = null; - } - } else { - lastCaptureGroups = new String[matcher.groupCount()]; - for (int i = 0; i < matcher.groupCount(); i++) { - lastCaptureGroups[i] = matcher.group(i + 1); - } - } - } else { - lastCaptureGroups = null; + while (searchStart <= inputStr.length()) { + setSubstitutionRegion(matcher, searchStart, inputStr.length(), true); + if (!matcher.find()) { + break; } - // For \K, adjust match start so $& is only the post-\K portion - if (regex.hasBackslashK) { - int keepEnd = matcher.end("perlK"); - lastMatchStart = keepEnd; - lastMatchedString = inputStr.substring(keepEnd, matcher.end()); - } else { - lastMatchStart = matcher.start(); - lastMatchedString = matcher.group(0); - } - lastMatchEnd = matcher.end(); + found++; + updateReplacementMatchState(regex, matcher, inputStr, string); String replacementStr; if (replacementIsCode) { @@ -2117,7 +2156,9 @@ public static RuntimeBase replaceRegex(RuntimeScalar quotedRegex, RuntimeScalar lastAppendEnd = matcher.end(); } else { // Normal replacement: replace the entire match - matcher.appendReplacement(resultBuffer, Matcher.quoteReplacement(replacementStr)); + resultBuffer.append(inputStr, lastAppendEnd, matcher.start()); + resultBuffer.append(replacementStr); + lastAppendEnd = matcher.end(); } } @@ -2125,17 +2166,67 @@ public static RuntimeBase replaceRegex(RuntimeScalar quotedRegex, RuntimeScalar if (!regex.regexFlags.isGlobalMatch()) { break; } + + if (matcher.end() > matcher.start()) { + searchStart = matcher.end(); + continue; + } + + int zeroLengthOffset = matcher.end(); + boolean consumedNonEmptyRetry = false; + if (nonEmptySubstitutionPattern != null && zeroLengthOffset <= inputStr.length()) { + Matcher retryMatcher = nonEmptySubstitutionPattern.matcher(matchInput); + // The synthetic (?<=[\s\S]) suffix relies on opaque bounds + // so a zero-length match at the region start is rejected. + setSubstitutionRegion(retryMatcher, zeroLengthOffset, inputStr.length(), false); + if (retryMatcher.find() + && retryMatcher.start() == zeroLengthOffset + && retryMatcher.end() > zeroLengthOffset) { + found++; + updateReplacementMatchState(regex, retryMatcher, inputStr, string); + + String retryReplacementStr; + if (replacementIsCode) { + RuntimeArray args = (callerArgs != null) ? callerArgs : new RuntimeArray(); + RuntimeList result = RuntimeCode.apply(replacement, args, RuntimeContextType.SCALAR); + if (Utf8.isUtf8(result.scalar())) { + resultNeedsUtf8 = true; + } + retryReplacementStr = result.toString(); + } else { + if (Utf8.isUtf8(replacement)) { + resultNeedsUtf8 = true; + } + retryReplacementStr = replacement.toString(); + } + + if (retryReplacementStr != null) { + if (regex.hasBackslashK) { + int keepEnd = retryMatcher.end("perlK"); + resultBuffer.append(inputStr, lastAppendEnd, keepEnd); + resultBuffer.append(retryReplacementStr); + lastAppendEnd = retryMatcher.end(); + } else { + resultBuffer.append(inputStr, lastAppendEnd, retryMatcher.start()); + resultBuffer.append(retryReplacementStr); + lastAppendEnd = retryMatcher.end(); + } + } + searchStart = retryMatcher.end(); + consumedNonEmptyRetry = true; + } + } + + if (!consumedNonEmptyRetry) { + searchStart = bumpGlobalMatchPosition(inputStr, zeroLengthOffset); + } } } catch (RegexTimeoutException e) { WarnDie.warn(new RuntimeScalar(e.getMessage() + "\n"), RuntimeScalarCache.scalarEmptyString); found = 0; } // Append the remaining text after the last match to the result buffer - if (regex.hasBackslashK) { - resultBuffer.append(inputStr, lastAppendEnd, inputStr.length()); - } else { - matcher.appendTail(resultBuffer); - } + resultBuffer.append(inputStr, lastAppendEnd, inputStr.length()); // Release captures from the replacement closure to unblock DESTROY. // The s///eg replacement is compiled as an anonymous sub that captures diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeCode.java b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeCode.java index f40d7ce02..3bce86fbf 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeCode.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeCode.java @@ -192,6 +192,14 @@ protected boolean removeEldestEntry(Map.Entry, MethodHandle> eldest) { private static final ThreadLocal> hasArgsStack = ThreadLocal.withInitial(ArrayDeque::new); + /** + * Thread-local stack tracking the context each active subroutine was called in. + * Perl exposes this as caller(EXPR)[5]: undef for void, false for scalar, true + * for list context. + */ + private static final ThreadLocal> callContextStack = + ThreadLocal.withInitial(ArrayDeque::new); + /** * Get the current subroutine's @_ array. * Used by Java-implemented functions (like List::Util::any) that need to pass @@ -281,6 +289,10 @@ public static void pushArgs(RuntimeArray args) { args != null ? new java.util.ArrayList<>(args.elements) : new java.util.ArrayList<>()); } + public static void pushCallContext(int callContext) { + callContextStack.get().push(callContext); + } + /** * Pop @_ and hasargs flag from their respective stacks when exiting a subroutine. * Both stacks are pushed in the instance apply() methods and must be popped together. @@ -299,6 +311,10 @@ public static void popArgs() { if (!haStack.isEmpty()) { haStack.pop(); } + Deque ctxStack = callContextStack.get(); + if (!ctxStack.isEmpty()) { + ctxStack.pop(); + } } /** @@ -345,6 +361,29 @@ public static Boolean getHasArgsAt(int depth) { return null; } + public static Integer getCallContextAt(int depth) { + Deque stack = callContextStack.get(); + int i = 0; + for (Integer callContext : stack) { + if (i == depth) return callContext; + i++; + } + return null; + } + + private static RuntimeScalar callerWantarrayScalar(Integer callContext) { + if (callContext == null) { + return RuntimeScalarCache.scalarUndef; + } + if (RuntimeContextType.isListLike(callContext)) { + return RuntimeScalarCache.scalarTrue; + } + if (callContext == RuntimeContextType.SCALAR || callContext == RuntimeContextType.LVALUE) { + return RuntimeScalarCache.scalarFalse; + } + return RuntimeScalarCache.scalarUndef; + } + /** * Inline method cache for fast method dispatch at monomorphic call sites. * @@ -574,6 +613,16 @@ private static void releaseMethodInvocantHold(RuntimeBase holdBase) { } } + private static boolean isReferenceToGlobInvocant(RuntimeScalar invocant) { + if (invocant.type != REFERENCE || !(invocant.value instanceof RuntimeScalar inner)) { + return false; + } + while (inner.type == READONLY_SCALAR) { + inner = (RuntimeScalar) inner.value; + } + return inner.type == GLOB || inner.type == GLOBREFERENCE; + } + public static boolean isLvalueCode(RuntimeCode code) { return code != null && code.attributes != null && code.attributes.contains("lvalue"); } @@ -2891,7 +2940,7 @@ private static RuntimeList dispatchPerlMethodAfterSelfInjected( // Handle all reference types (REFERENCE, ARRAYREFERENCE, HASHREFERENCE, etc.) int blessId = ((RuntimeBase) invocant.value).blessId; if (blessId == 0) { - if (invocant.type == GLOBREFERENCE) { + if (invocant.type == GLOBREFERENCE || isReferenceToGlobInvocant(invocant)) { // Auto-bless file handler to IO::File which inherits from both IO::Handle and IO::Seekable // This allows GLOBs to call methods like seek, tell, etc. perlClassName = "IO::File"; @@ -3322,10 +3371,17 @@ public static RuntimeList callerWithSub(RuntimeList args, int ctx, RuntimeScalar res.add(hasArgs ? RuntimeScalarCache.scalarTrue : RuntimeScalarCache.scalarUndef); } - // Add wantarray (element 5): undef for void, 0 for scalar, 1 for list - // We don't currently track this per-frame, so return undef - // TODO: Track call context per frame to return accurate wantarray - res.add(RuntimeScalarCache.scalarUndef); + // Add wantarray (element 5): undef for void, 0 for scalar, 1 for list. + Integer frameCallContext = getCallContextAt(trackedOriginalFrame); + if (WarnDie.isInsideUnhandledDieHandler() && syntheticOwnSubFramesBefore > 0) { + Integer activeCallContext = getCallContextAt(trackedActiveCodeFrame); + if (activeCallContext != null) { + frameCallContext = activeCallContext; + } + } else if (frameCallContext == null && WarnDie.isInsideUnhandledDieHandler()) { + frameCallContext = getCallContextAt(trackedActiveCodeFrame); + } + res.add(callerWantarrayScalar(frameCallContext)); // Add evaltext (element 6): The eval text if inside eval STRING // For eval {...}, this is undef; for eval "...", this is the string @@ -4770,6 +4826,7 @@ public RuntimeList apply(RuntimeArray a, int callContext) { } // Always push args for getCurrentArgs() support (used by List::Util::any/all/etc.) pushArgs(a); + pushCallContext(callContext); pushActiveCode(this); // hasArgs tracking for caller()[4]: @@ -4898,6 +4955,7 @@ public RuntimeList apply(String subroutineName, RuntimeArray a, int callContext) } // Always push args for getCurrentArgs() support (used by List::Util::any/all/etc.) pushArgs(a); + pushCallContext(callContext); pushActiveCode(this); // hasArgs tracking for caller()[4]: diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeIO.java b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeIO.java index f0d1d9105..21ab045a0 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeIO.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeIO.java @@ -1144,6 +1144,17 @@ public static RuntimeIO getRuntimeIO(RuntimeScalar runtimeScalar) { } } + if (runtimeScalar.type == RuntimeScalarType.REFERENCE + && runtimeScalar.value instanceof RuntimeScalar inner) { + while (inner.type == RuntimeScalarType.READONLY_SCALAR) { + inner = (RuntimeScalar) inner.value; + } + if (inner.type == RuntimeScalarType.GLOB + || inner.type == RuntimeScalarType.GLOBREFERENCE) { + runtimeScalar = inner; + } + } + if (runtimeScalar.isString()) { String name = runtimeScalar.toString(); String packageName = "main"; // XXX TODO: get the current package name diff --git a/src/main/perl/lib/PerlOnJava/CpanDistroprefs/AnyEvent.yml b/src/main/perl/lib/PerlOnJava/CpanDistroprefs/AnyEvent.yml index 6ecbb185c..4878497e7 100644 --- a/src/main/perl/lib/PerlOnJava/CpanDistroprefs/AnyEvent.yml +++ b/src/main/perl/lib/PerlOnJava/CpanDistroprefs/AnyEvent.yml @@ -1,15 +1,18 @@ --- comment: | - PerlOnJava distroprefs for AnyEvent when testing AnyEvent::STOMP. + PerlOnJava distroprefs for AnyEvent. - AnyEvent::STOMP's own CPAN suite is a load smoke test. Its AnyEvent - prerequisite suite covers fork, local socket, SSL, and live-network surfaces - that are broader than that downstream load test and are not stable under - PerlOnJava or this sandbox. Keep direct `jcpan -t AnyEvent` honest by only - skipping this prerequisite test phase for the AnyEvent::STOMP target. + AnyEvent's upstream suite covers fork, local socket, SSL, signal, and live + event-loop surfaces that are broader than the pure-Perl module load/install + surface. PerlOnJava does not implement fork, and several watcher tests can + hang after the fork-only child test fails. + + Suppress Canary::Stability's interactive Makefile.PL prompt, then build and + install the module while skipping the upstream test phase. Downstream modules + that depend on AnyEvent remain their own compatibility gates. match: distribution: "^MLEHMANN/AnyEvent-" - env: - PERLONJAVA_JCPAN_ARGS: "(^|[[:space:]])AnyEvent::STOMP($|[[:space:]])" +pl: + commandline: 'jperl -MPerlOnJava::Distroprefs::AnyEvent -e "PerlOnJava::Distroprefs::AnyEvent::pl_phase()"' test: commandline: "PERLONJAVA_SKIP" diff --git a/src/main/perl/lib/PerlOnJava/Distroprefs/AnyEvent.pm b/src/main/perl/lib/PerlOnJava/Distroprefs/AnyEvent.pm new file mode 100644 index 000000000..87d6c8661 --- /dev/null +++ b/src/main/perl/lib/PerlOnJava/Distroprefs/AnyEvent.pm @@ -0,0 +1,15 @@ +package PerlOnJava::Distroprefs::AnyEvent; + +use strict; +use warnings; + +sub pl_phase { + local $ENV{PERL_CANARY_STABILITY_NOPROMPT} = 1; + my $ok = do './Makefile.PL'; + die $@ if $@; + die "Could not run Makefile.PL: $!" unless defined $ok; + die "Makefile.PL returned false\n" unless $ok; + return 1; +} + +1; diff --git a/src/test/resources/unit/begin_feature_import.t b/src/test/resources/unit/begin_feature_import.t new file mode 100644 index 000000000..3beaa14db --- /dev/null +++ b/src/test/resources/unit/begin_feature_import.t @@ -0,0 +1,17 @@ +use strict; +use warnings; +use Test::More tests => 2; + +BEGIN { + require feature; + feature->import('fc'); +} + +is fc('ABC'), 'abc', 'BEGIN-time feature->import enables fc for later parsing'; + +{ + package BeginFeatureImportSub; + sub fc { 'sub' } +} + +is BeginFeatureImportSub::fc('ABC'), 'sub', 'ordinary sub named fc still works when called qualified'; diff --git a/src/test/resources/unit/blessed_code_isa.t b/src/test/resources/unit/blessed_code_isa.t new file mode 100644 index 000000000..5abd751fa --- /dev/null +++ b/src/test/resources/unit/blessed_code_isa.t @@ -0,0 +1,21 @@ +#!/usr/bin/env perl + +use strict; +use warnings; +use Scalar::Util (); +use Test::More tests => 3; + +{ + package BlessedCodeIsa; + + sub new { + my $class = shift; + return bless sub { 1 }, $class; + } +} + +my $code = BlessedCodeIsa->new; + +ok(Scalar::Util::blessed($code), 'anonymous sub can be blessed'); +ok($code->isa('CODE'), 'blessed CODE ref reports CODE through method isa'); +ok(UNIVERSAL::isa($code, 'CODE'), 'blessed CODE ref reports CODE through UNIVERSAL::isa'); diff --git a/src/test/resources/unit/caller_wantarray_context.t b/src/test/resources/unit/caller_wantarray_context.t new file mode 100644 index 000000000..ab24648e2 --- /dev/null +++ b/src/test/resources/unit/caller_wantarray_context.t @@ -0,0 +1,24 @@ +#!/usr/bin/env perl + +use strict; +use warnings; +use Test::More tests => 1; + +my @seen; + +sub capture_caller_context { + my @caller = caller(1); + my $wantarray = $caller[5]; + push @seen, defined($wantarray) ? ($wantarray ? 'list' : 'scalar') : 'void'; +} + +sub context_sensitive_function { + capture_caller_context(); + return (1, 2, 3); +} + +my $scalar = context_sensitive_function(); +my @list = context_sensitive_function(); +context_sensitive_function(); + +is_deeply(\@seen, [qw(scalar list void)], 'caller()[5] reports the inspected frame context'); diff --git a/src/test/resources/unit/defined_cached_code_ref.t b/src/test/resources/unit/defined_cached_code_ref.t new file mode 100644 index 000000000..66141a3b2 --- /dev/null +++ b/src/test/resources/unit/defined_cached_code_ref.t @@ -0,0 +1,37 @@ +#!/usr/bin/env perl + +use strict; +use warnings; +use Test::More tests => 3; + +BEGIN { + package DefinedCachedCodeRefExporter; + + sub import { + my $caller = caller; + no strict 'refs'; + *{"${caller}::cached_code"} = sub { 1 }; + } + + sub unimport { + my $caller = caller; + no strict 'refs'; + delete ${"${caller}::"}{cached_code}; + } +} + +{ + package DefinedCachedCodeRefConsumer; + + BEGIN { DefinedCachedCodeRefExporter->import; } + ::ok(defined(&cached_code), 'defined(&name) keeps compile-time imported CV'); + BEGIN { DefinedCachedCodeRefExporter->unimport; } +} + +ok(!DefinedCachedCodeRefConsumer->can('cached_code'), 'unimport removed the visible stash entry'); + +{ + package DefinedCachedCodeRefStub; + sub declared_only; + ::ok(!defined(&declared_only), 'forward-declared sub is still not defined'); +} diff --git a/src/test/resources/unit/glob_scalar_ref_io_method.t b/src/test/resources/unit/glob_scalar_ref_io_method.t new file mode 100644 index 000000000..6863b2073 --- /dev/null +++ b/src/test/resources/unit/glob_scalar_ref_io_method.t @@ -0,0 +1,27 @@ +use strict; +use warnings; +use Test::More tests => 4; +use IO::Handle; +use Scalar::Util qw(reftype); + +my $path = "/tmp/perlonjava-glob-scalar-ref-$$.txt"; +open my $out, '>', $path or die "open $path: $!"; +print {$out} "alpha\nbeta\n"; +close $out or die "close $path: $!"; + +open HANDLE, '<', $path or die "open $path: $!"; + +sub read_from_typeglob_argument { + my ($input) = @_; + is reftype(\$input), 'GLOB', 'scalar reference to typeglob reports GLOB'; + + my $fh = \$input; + is $fh->clearerr, 0, 'IO::Handle method dispatch works on scalar ref to glob'; + my @lines = $fh->getlines; + return join '', @lines; +} + +is read_from_typeglob_argument(*HANDLE), "alpha\nbeta\n", 'getlines reads through scalar ref to glob'; +ok close(HANDLE), 'closed test handle'; + +unlink $path; diff --git a/src/test/resources/unit/global_substitution_zero_length_retry.t b/src/test/resources/unit/global_substitution_zero_length_retry.t new file mode 100644 index 000000000..285a9215c --- /dev/null +++ b/src/test/resources/unit/global_substitution_zero_length_retry.t @@ -0,0 +1,31 @@ +use strict; +use warnings; +use Test::More tests => 5; + +my $s = 'abc'; +my $count = ($s =~ s{(.*?)(x)?}{'<' . (defined($1) ? $1 : 'undef') . '>'}ge); + +is $s, '<><><><>', 'global substitution retries non-empty match after zero-length match'; +is $count, 7, 'zero-length and retry replacements are both counted'; + +my $pattern = 'trailing space'; +$pattern =~ s{ + (.*?) + ( + \\. + | + \* + | + \? + )? +}{ + quotemeta $1; +}gsex; + +is $pattern, 'trailing\ space', 'nullable s///g replacement sees skipped characters'; + +my $lines = "ab\ncd\n"; +my $anchor_count = ($lines =~ s/^(.*)/[$1]/mg); + +is $anchor_count, 2, 's///g with regions does not treat region starts as ^ anchors'; +is $lines, "[ab]\n[cd]\n", 's///g with regions preserves multiline anchor semantics'; diff --git a/src/test/resources/unit/x_shebang_switch.t b/src/test/resources/unit/x_shebang_switch.t new file mode 100644 index 000000000..a1f1ccf4e --- /dev/null +++ b/src/test/resources/unit/x_shebang_switch.t @@ -0,0 +1,36 @@ +use strict; +use warnings; +use File::Spec; +use Test::More tests => 4; + +my $script = "/tmp/perlonjava-x-shebang-$$.pl"; +my $out_file = "/tmp/perlonjava-x-shebang-$$.out"; +open my $fh, '>', $script or die "open $script: $!"; +print {$fh} "#!/bin/sh\n"; +print {$fh} "eval \"exec $^X -x \\\"\$0\\\" \\\"\$@\\\"\"\n"; +print {$fh} " if 0;\n"; +print {$fh} "#!perl -w -l\n"; +print {$fh} "open my \$out, '>', \$ARGV[1] or die \"open output: \$!\";\n"; +print {$fh} "select \$out;\n"; +print {$fh} "print 'line';\n"; +print {$fh} "exit \$ARGV[0];\n"; +close $fh or die "close $script: $!"; +chmod 0755, $script or die "chmod $script: $!"; + +my $status = system $^X, '-x', $script, 7, $out_file; +is $status & 0xff, 0, '-x script exited normally'; +is $status >> 8, 7, '-x accepts #!perl with switches'; + +open my $out_fh, '<', $out_file or die "open $out_file: $!"; +my $out = do { local $/; <$out_fh> }; +close $out_fh or die "close $out_file: $!"; +is $out, "line\n", '-x applies switches from extracted shebang'; + +unlink $script, $out_file; + +open my $saved_stderr, '>&', \*STDERR or die "dup STDERR: $!"; +open STDERR, '>', File::Spec->devnull or die "redirect STDERR: $!"; +$status = system $^X, '-x', '-e', "die;\n", '-e', "#!perl\n", '-e', "warn;\n"; +open STDERR, '>&', $saved_stderr or die "restore STDERR: $!"; + +ok(($status >> 8) != 0, '-x does not extract code from -e fragments');