diff --git a/src/main/java/org/perlonjava/frontend/parser/FileHandle.java b/src/main/java/org/perlonjava/frontend/parser/FileHandle.java index c99b937f2..5820f2db2 100644 --- a/src/main/java/org/perlonjava/frontend/parser/FileHandle.java +++ b/src/main/java/org/perlonjava/frontend/parser/FileHandle.java @@ -75,6 +75,10 @@ public class FileHandle { * @return A Node representing the parsed file handle, or null if no valid file handle was found */ public static Node parseFileHandle(Parser parser) { + return parseFileHandle(parser, false); + } + + public static Node parseFileHandle(Parser parser, boolean autovivifyUnknownBareword) { boolean hasBracket = false; // Check if the file handle is enclosed in curly braces @@ -192,12 +196,7 @@ else if (token.type == LexerTokenType.IDENTIFIER) { String name = IdentifierParser.parseSubroutineIdentifier(parser); if (name != null) { fileHandle = parseBarewordHandle(parser, name); - // Do not treat compile-time magic like __PACKAGE__ as print filehandles: - // they match ^[A-Z_][A-Z0-9_]*$ but must fall through to the expression list - // (perl5_t/t/comp/package.t test 13: print __PACKAGE__ eq 'Pkg' ? ...). - if (fileHandle == null - && name.matches("^[A-Z_][A-Z0-9_]*$") - && !isDoubleUnderscoreMagicBareword(name)) { + if (fileHandle == null && shouldAutovivifyBarewordHandle(parser, name, autovivifyUnknownBareword)) { GlobalVariable.vivifyGlobalIO(normalizeBarewordHandle(parser, name)); fileHandle = parseBarewordHandle(parser, name); } @@ -261,11 +260,12 @@ else if (hasBracket) { public static Node parseBarewordHandle(Parser parser, String name) { name = normalizeBarewordHandle(parser, name); - // Check if this name has a CODE ref defined (it's a subroutine, not a filehandle) + // Check if this name has a CODE slot (it's a subroutine, not a filehandle) // This handles the case where a subroutine was imported via typeglob assignment // (e.g., *main::myconfig = \&Config::myconfig), creating a glob entry but - // with only a CODE slot, not an IO slot. - if (GlobalVariable.isGlobalCodeRefDefined(name)) { + // with only a CODE slot, not an IO slot. Forward declarations also win: + // `sub foo; print foo "x"` is a subroutine call, not a bareword filehandle. + if (GlobalVariable.existsGlobalCodeRefAsScalar(name).getBoolean()) { return null; // Not a filehandle, it's a subroutine } @@ -331,4 +331,64 @@ public static String normalizeBarewordHandle(Parser parser, String name) { private static boolean isDoubleUnderscoreMagicBareword(String name) { return name.length() >= 4 && name.startsWith("__") && name.endsWith("__"); } + + private static boolean isVStringBarewordPrefix(String name) { + if (name.length() < 2 || name.charAt(0) != 'v') { + return false; + } + for (int i = 1; i < name.length(); i++) { + if (!Character.isDigit(name.charAt(i))) { + return false; + } + } + return true; + } + + private static boolean isImmediatelyFollowedByOpenParen(Parser parser) { + return parser.tokenIndex < parser.tokens.size() + && "(".equals(parser.tokens.get(parser.tokenIndex).text); + } + + private static boolean isFollowedByMethodDereference(Parser parser) { + int idx = parser.tokenIndex; + while (idx < parser.tokens.size() + && parser.tokens.get(idx).type == LexerTokenType.WHITESPACE) { + idx++; + } + return idx < parser.tokens.size() && "->".equals(parser.tokens.get(idx).text); + } + + private static boolean shouldAutovivifyBarewordHandle(Parser parser, String name, boolean autovivifyUnknownBareword) { + // Do not treat compile-time magic like __PACKAGE__ as print filehandles: + // they match ^[A-Z_][A-Z0-9_]*$ but must fall through to the expression list + // (perl5_t/t/comp/package.t test 13: print __PACKAGE__ eq 'Pkg' ? ...). + if (isDoubleUnderscoreMagicBareword(name)) { + return false; + } + + if (isVStringBarewordPrefix(name)) { + return false; + } + + // Perl treats `print foo("x")` as printing the result of foo(), while + // `print foo ("x")` can be a print to filehandle foo. + if (isImmediatelyFollowedByOpenParen(parser)) { + return false; + } + + if (isFollowedByMethodDereference(parser)) { + return false; + } + + if (ParserTables.CORE_PROTOTYPES.containsKey(name)) { + return false; + } + + String normalizedName = normalizeBarewordHandle(parser, name); + if (GlobalVariable.existsGlobalCodeRefAsScalar(normalizedName).getBoolean()) { + return false; + } + + return autovivifyUnknownBareword || name.matches("^[A-Z_][A-Z0-9_]*$"); + } } diff --git a/src/main/java/org/perlonjava/frontend/parser/ListParser.java b/src/main/java/org/perlonjava/frontend/parser/ListParser.java index 77f3286ba..0f1287312 100644 --- a/src/main/java/org/perlonjava/frontend/parser/ListParser.java +++ b/src/main/java/org/perlonjava/frontend/parser/ListParser.java @@ -102,6 +102,10 @@ static ListNode parseZeroOrOneList(Parser parser, int minItems, String tooManyAr * @throws PerlCompilerException If the syntax is incorrect or the minimum number of items is not met. */ static ListNode parseZeroOrMoreList(Parser parser, int minItems, boolean wantBlockNode, boolean obeyParentheses, boolean wantFileHandle, boolean wantRegex) { + return parseZeroOrMoreList(parser, minItems, wantBlockNode, obeyParentheses, wantFileHandle, wantRegex, false); + } + + static ListNode parseZeroOrMoreList(Parser parser, int minItems, boolean wantBlockNode, boolean obeyParentheses, boolean wantFileHandle, boolean wantRegex, boolean autovivifyUnknownBarewordFileHandle) { if (CompilerOptions.DEBUG_ENABLED) parser.ctx.logDebug("parseZeroOrMoreList start"); ListNode expr = new ListNode(parser.tokenIndex); @@ -168,7 +172,7 @@ static ListNode parseZeroOrMoreList(Parser parser, int minItems, boolean wantBlo TokenUtils.consume(parser); hasParen = true; } - expr.handle = FileHandle.parseFileHandle(parser); + expr.handle = FileHandle.parseFileHandle(parser, autovivifyUnknownBarewordFileHandle); if (expr.handle == null || !isSpaceAfterPrintBlock(parser)) { // Backtrack parser.debugHeredocState("FILEHANDLE_BEFORE_BACKTRACK"); diff --git a/src/main/java/org/perlonjava/frontend/parser/OperatorParser.java b/src/main/java/org/perlonjava/frontend/parser/OperatorParser.java index 04bbfca93..ffa1fe12a 100644 --- a/src/main/java/org/perlonjava/frontend/parser/OperatorParser.java +++ b/src/main/java/org/perlonjava/frontend/parser/OperatorParser.java @@ -249,7 +249,7 @@ static BinaryOperatorNode parsePrint(Parser parser, LexerToken token, int curren parser.debugHeredocState("PRINT_START"); try { - operand = ListParser.parseZeroOrMoreList(parser, 0, false, true, true, false); + operand = ListParser.parseZeroOrMoreList(parser, 0, false, true, true, false, true); parser.debugHeredocState("PRINT_PARSE_SUCCESS"); } catch (PerlCompilerException e) { parser.debugHeredocState("PRINT_BEFORE_BACKTRACK"); diff --git a/src/test/resources/unit/print_bareword_filehandle.t b/src/test/resources/unit/print_bareword_filehandle.t new file mode 100644 index 000000000..0130213f2 --- /dev/null +++ b/src/test/resources/unit/print_bareword_filehandle.t @@ -0,0 +1,110 @@ +use strict; +use warnings; +use Test::More tests => 10; + +package PrintBarewordTarget; + +sub Dumper { + die "Dumper method should not be called"; +} + +package main; + +my $object = bless {}, 'PrintBarewordTarget'; + +{ + no warnings qw(once unopened); + my $ok = eval { + print Dumper $object; + 1; + }; + ok($ok, 'unresolved print bareword is a filehandle, not an indirect method') or diag $@; +} + +our $known_called = 0; + +sub KnownPrintArg { + $known_called++; + return ""; +} + +print KnownPrintArg $object; +is($known_called, 1, 'known bareword after print remains a subroutine call'); + +{ + my $buffer = ''; + open my $capture, '>', \$buffer or die $!; + my $old = select $capture; + my $ok = eval { + print q(a); + print qq(b); + print join('', 'c'); + 1; + }; + my $error = $@; + select $old; + close $capture; + ok($ok, 'core operators after print are not bareword filehandles') or diag $error; + is($buffer, 'abc', 'print parses q, qq, and join as core operators'); +} + +{ + my $buffer = ''; + open my $capture, '>', \$buffer or die $!; + my $old = select $capture; + my $ok = eval { + print v65.66; + 1; + }; + my $error = $@; + select $old; + close $capture; + ok($ok, 'v-string after print is not a bareword filehandle') or diag $error; + is($buffer, 'AB', 'print parses v-string operands'); +} + +{ + my $ok = eval { + print UnknownPrintFunction("x"); + 1; + }; + my $error = $@; + ok(!$ok && $error =~ /Undefined subroutine .*UnknownPrintFunction/, + 'bareword immediately followed by parens remains a subroutine call'); +} + +package PrintBarewordMethodTarget; + +sub foo { + return "method"; +} + +package main; + +{ + my $buffer = ''; + open my $capture, '>', \$buffer or die $!; + my $old = select $capture; + my $ok = eval { + print PrintBarewordMethodTarget->foo; + 1; + }; + my $error = $@; + select $old; + close $capture; + ok($ok, 'bareword method call after print is not a filehandle') or diag $error; + is($buffer, 'method', 'print parses bareword method calls as operands'); +} + +sub DeclaredOnly; + +{ + no warnings qw(once unopened); + my $ok = eval { + print DeclaredOnly "x"; + 1; + }; + my $error = $@; + ok(!$ok && $error =~ /Undefined subroutine .*DeclaredOnly/, + 'forward-declared bareword after print remains a subroutine call'); +}