From 97f902956296356936fd03ff4e1ea48d38d24343 Mon Sep 17 00:00:00 2001 From: "Flavio S. Glock" Date: Thu, 21 May 2026 13:23:33 +0200 Subject: [PATCH 1/3] fix: support namespace::clean test suite Normalize parser token mismatch diagnostics to Perl-style syntax errors, preserve bareword filehandle IO slot identity across open, and restore IO slots through Package::Stash glob assignment. Generated with Codex (https://openai.com/codex) Co-Authored-By: Codex --- .../frontend/parser/FileHandle.java | 4 +- .../frontend/parser/OperatorParser.java | 6 +-- .../frontend/parser/PrototypeArgs.java | 4 +- .../frontend/parser/TokenUtils.java | 4 +- .../runtime/operators/IOOperator.java | 6 +-- .../runtime/perlmodule/ScalarUtil.java | 9 +++- .../runtime/runtimetypes/GlobalVariable.java | 15 +++++++ .../runtime/runtimetypes/RuntimeGlob.java | 16 +++++++ .../runtime/runtimetypes/RuntimeIO.java | 24 ++++++++++ .../runtime/runtimetypes/RuntimeScalar.java | 4 +- .../runtimetypes/RuntimeStashEntry.java | 8 +--- src/test/resources/unit/parser_syntax_error.t | 8 ++++ src/test/resources/unit/typeglob.t | 44 +++++++++++++++++++ 13 files changed, 131 insertions(+), 21 deletions(-) create mode 100644 src/test/resources/unit/parser_syntax_error.t diff --git a/src/main/java/org/perlonjava/frontend/parser/FileHandle.java b/src/main/java/org/perlonjava/frontend/parser/FileHandle.java index 6edc378a4..c99b937f2 100644 --- a/src/main/java/org/perlonjava/frontend/parser/FileHandle.java +++ b/src/main/java/org/perlonjava/frontend/parser/FileHandle.java @@ -198,7 +198,7 @@ else if (token.type == LexerTokenType.IDENTIFIER) { if (fileHandle == null && name.matches("^[A-Z_][A-Z0-9_]*$") && !isDoubleUnderscoreMagicBareword(name)) { - GlobalVariable.getGlobalIO(normalizeBarewordHandle(parser, name)); + GlobalVariable.vivifyGlobalIO(normalizeBarewordHandle(parser, name)); fileHandle = parseBarewordHandle(parser, name); } } @@ -331,4 +331,4 @@ public static String normalizeBarewordHandle(Parser parser, String name) { private static boolean isDoubleUnderscoreMagicBareword(String name) { return name.length() >= 4 && name.startsWith("__") && name.endsWith("__"); } -} \ No newline at end of file +} diff --git a/src/main/java/org/perlonjava/frontend/parser/OperatorParser.java b/src/main/java/org/perlonjava/frontend/parser/OperatorParser.java index 971a411ca..04bbfca93 100644 --- a/src/main/java/org/perlonjava/frontend/parser/OperatorParser.java +++ b/src/main/java/org/perlonjava/frontend/parser/OperatorParser.java @@ -145,7 +145,7 @@ static Node parseDiamondOperator(Parser parser, LexerToken token) { parser.tokenIndex++; // consume NUMBER TokenUtils.consume(parser); // consume '>' String digitName = operand.text; - GlobalVariable.getGlobalIO(FileHandle.normalizeBarewordHandle(parser, digitName)); + GlobalVariable.vivifyGlobalIO(FileHandle.normalizeBarewordHandle(parser, digitName)); Node globRef = FileHandle.parseBarewordHandle(parser, digitName); if (globRef != null) { BinaryOperatorNode readlineNode = new BinaryOperatorNode("readline", @@ -710,7 +710,7 @@ public static OperatorNode parseSelect(Parser parser, LexerToken token, int curr // select FILEHANDLE if (listNode1.elements.getFirst() instanceof IdentifierNode identifierNode) { // Autovivify the filehandle IO slot so parseBarewordHandle succeeds - GlobalVariable.getGlobalIO(FileHandle.normalizeBarewordHandle(parser, identifierNode.name)); + GlobalVariable.vivifyGlobalIO(FileHandle.normalizeBarewordHandle(parser, identifierNode.name)); Node handle = FileHandle.parseBarewordHandle(parser, identifierNode.name); if (handle != null) { // handle is Bareword @@ -979,7 +979,7 @@ static OperatorNode parseStat(Parser parser, LexerToken token, int currentIndex) if (name.matches("^[A-Z_][A-Z0-9_]*$")) { TokenUtils.consume(parser); // autovivify filehandle and convert to globref - GlobalVariable.getGlobalIO(FileHandle.normalizeBarewordHandle(parser, name)); + GlobalVariable.vivifyGlobalIO(FileHandle.normalizeBarewordHandle(parser, name)); Node fh = FileHandle.parseBarewordHandle(parser, name); Node operand = fh != null ? fh : new IdentifierNode(name, parser.tokenIndex); if (paren) { diff --git a/src/main/java/org/perlonjava/frontend/parser/PrototypeArgs.java b/src/main/java/org/perlonjava/frontend/parser/PrototypeArgs.java index e4e6211b6..d5f11814f 100644 --- a/src/main/java/org/perlonjava/frontend/parser/PrototypeArgs.java +++ b/src/main/java/org/perlonjava/frontend/parser/PrototypeArgs.java @@ -632,7 +632,7 @@ private static void handleScalarArgument(Parser parser, ListNode args, boolean i } // Not a known filehandle, but still allow bareword (will be treated as filename string) // Autovivify the filehandle in case it's used later - GlobalVariable.getGlobalIO(FileHandle.normalizeBarewordHandle(parser, idNode.name)); + GlobalVariable.vivifyGlobalIO(FileHandle.normalizeBarewordHandle(parser, idNode.name)); } } Node scalarArg = ParserNodeUtils.toScalarContext(arg); @@ -740,7 +740,7 @@ private static int handleTypeGlobArgument(Parser parser, ListNode args, boolean // Builtin bareword filehandle - create a typeglob reference // autovivify the bareword handle - GlobalVariable.getGlobalIO(FileHandle.normalizeBarewordHandle(parser, idNode.name)); + GlobalVariable.vivifyGlobalIO(FileHandle.normalizeBarewordHandle(parser, idNode.name)); Node typeglobRef = FileHandle.parseBarewordHandle(parser, idNode.name); args.elements.add(typeglobRef == null ? expr : typeglobRef); diff --git a/src/main/java/org/perlonjava/frontend/parser/TokenUtils.java b/src/main/java/org/perlonjava/frontend/parser/TokenUtils.java index 08effc3ed..37793ee5f 100644 --- a/src/main/java/org/perlonjava/frontend/parser/TokenUtils.java +++ b/src/main/java/org/perlonjava/frontend/parser/TokenUtils.java @@ -136,7 +136,7 @@ public static LexerToken consume(Parser parser, LexerTokenType type) { LexerToken token = consume(parser); if (token.type != type) { throw new PerlCompilerException( - parser.tokenIndex, "Expected token " + type + " but got " + token, parser.ctx.errorUtil); + parser.tokenIndex, "syntax error", parser.ctx.errorUtil); } return token; } @@ -155,7 +155,7 @@ public static void consume(Parser parser, LexerTokenType type, String text) { if (token.type != type || !token.text.equals(text)) { throw new PerlCompilerException( parser.tokenIndex, - "Expected token " + type + " with text " + text + " but got " + token, + "syntax error", parser.ctx.errorUtil); } } diff --git a/src/main/java/org/perlonjava/runtime/operators/IOOperator.java b/src/main/java/org/perlonjava/runtime/operators/IOOperator.java index 5ecbc2ce5..cc0b65b4f 100644 --- a/src/main/java/org/perlonjava/runtime/operators/IOOperator.java +++ b/src/main/java/org/perlonjava/runtime/operators/IOOperator.java @@ -634,7 +634,7 @@ public static RuntimeScalar open(int ctx, RuntimeBase... args) { targetGlob = GlobalVariable.getGlobalIO(filehandleName); } if (targetGlob != null) { - targetGlob.setIO(oneFh); + targetGlob.openIO(oneFh); // If args[0] is a writable scalar (not readonly), update it to point // at the glob. We must NOT call set() on a readonly scalar (e.g. when // args[0] is a numeric literal like in `open 0`). @@ -851,7 +851,7 @@ else if (secondArg.type == RuntimeScalarType.GLOB || secondArg.type == RuntimeSc " ioHandleId=" + (fh != null && fh.ioHandle != null ? System.identityHashCode(fh.ioHandle) : 0)); System.err.flush(); } - targetGlob.setIO(fh); + targetGlob.openIO(fh); } else { // Create a new anonymous GLOB and assign it to the lvalue RuntimeScalar newGlob = new RuntimeScalar(); @@ -1540,7 +1540,7 @@ public static RuntimeScalar sysopen(int ctx, RuntimeBase... args) { } if (targetGlob != null) { - targetGlob.setIO(fh); + targetGlob.openIO(fh); } else { RuntimeScalar newGlob = new RuntimeScalar(); newGlob.type = RuntimeScalarType.GLOBREFERENCE; diff --git a/src/main/java/org/perlonjava/runtime/perlmodule/ScalarUtil.java b/src/main/java/org/perlonjava/runtime/perlmodule/ScalarUtil.java index 014ac9647..1585ccbbe 100644 --- a/src/main/java/org/perlonjava/runtime/perlmodule/ScalarUtil.java +++ b/src/main/java/org/perlonjava/runtime/perlmodule/ScalarUtil.java @@ -160,7 +160,14 @@ yield switch (inner.type) { case ARRAYREFERENCE -> "ARRAY"; case HASHREFERENCE -> "HASH"; case CODE -> "CODE"; - case GLOB, GLOBREFERENCE -> "GLOB"; + case GLOB -> { + if (scalar.value instanceof RuntimeIO) yield "IO"; + yield null; + } + case GLOBREFERENCE -> { + if (scalar.value instanceof RuntimeIO) yield "IO"; + yield "GLOB"; + } case FORMAT -> "FORMAT"; case REGEX -> "REGEXP"; default -> null; diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/GlobalVariable.java b/src/main/java/org/perlonjava/runtime/runtimetypes/GlobalVariable.java index cb9d602f1..5ed6d332e 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/GlobalVariable.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/GlobalVariable.java @@ -1289,6 +1289,21 @@ public static RuntimeGlob getGlobalIO(String key) { return glob; } + /** + * Vivifies the IO slot for a bareword filehandle seen at compile time. + * Generic glob creation must not define {@code *name{IO}}, but Perl creates + * a PVIO object when it parses a bareword filehandle argument such as + * {@code open FH, ...}. BEGIN blocks can observe that placeholder before + * the runtime open call installs the real handle. + */ + public static RuntimeGlob vivifyGlobalIO(String key) { + RuntimeGlob glob = getGlobalIO(key); + if (glob.IO == null || glob.IO.type == RuntimeScalarType.UNDEF || glob.IO.value == null) { + glob.setIO(new RuntimeIO()); + } + return glob; + } + /** * Peek at a glob entry without vivifying it. Returns null if no glob has * been registered under this name. Used by anon-sub naming lookups diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeGlob.java b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeGlob.java index a9a768656..6fc826a86 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeGlob.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeGlob.java @@ -857,6 +857,22 @@ public RuntimeGlob setIO(RuntimeIO io) { return this; } + public RuntimeGlob openIO(RuntimeIO io) { + if (this.IO != null + && this.IO.type != RuntimeScalarType.TIED_SCALAR + && this.IO.value instanceof RuntimeIO existingIO + && existingIO != io) { + RuntimeIO oldSelected = existingIO == RuntimeIO.selectedHandle ? existingIO : null; + existingIO.replaceStateFrom(io); + existingIO.globName = this.globName; + if (oldSelected != null) { + RuntimeIO.selectedHandle = existingIO; + } + return this; + } + return setIO(io); + } + /** * Counts the number of elements in the typeglob. * diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeIO.java b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeIO.java index 609fde661..9243dffc9 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeIO.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeIO.java @@ -422,6 +422,30 @@ public RuntimeIO(DirectoryIO directoryIO) { this.directoryIO = directoryIO; } + /** + * Replace this handle's runtime state with another handle while preserving + * object identity. Perl keeps the PVIO object stable across {@code open FH} + * on an already-vivified bareword handle, so values captured by + * {@code *FH{IO}} before the open see the newly opened stream. + */ + public void replaceStateFrom(RuntimeIO other) { + if (other == null || other == this) { + return; + } + + Integer fd = ioToFileno.remove(other); + if (fd != null) { + ioToFileno.put(this, fd); + filenoToIO.put(fd, this); + } + + this.currentLineNumber = other.currentLineNumber; + this.ioHandle = other.ioHandle; + this.directoryIO = other.directoryIO; + this.needFlush = other.needFlush; + this.autoFlush = other.autoFlush; + } + /** * Checks if this handle is in byte mode (no encoding layers). * diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeScalar.java b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeScalar.java index 25485b44b..93c6483bc 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeScalar.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeScalar.java @@ -2338,7 +2338,7 @@ public RuntimeGlob globDeref() { // PCS (Proxy Constant Subroutine) creation should only happen via direct // stash hash assignment ($stash->{name} = \$scalar), handled by RuntimeStashEntry.set(). if (value instanceof RuntimeStashEntry stashEntry) { - yield new RuntimeGlob(stashEntry.globName); + yield GlobalVariable.getGlobalIO(stashEntry.globName); } yield (RuntimeGlob) value; } @@ -2404,7 +2404,7 @@ public RuntimeGlob globDerefNonStrict(String packageName) { // When glob-dereferencing a stash entry, return a plain RuntimeGlob. // This prevents *{$stash->{name}} = \$scalar from creating PCS constant subs. if (value instanceof RuntimeStashEntry stashEntry) { - yield new RuntimeGlob(stashEntry.globName); + yield GlobalVariable.getGlobalIO(stashEntry.globName); } yield (RuntimeGlob) value; } diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeStashEntry.java b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeStashEntry.java index 6f5b50934..a9f0ca191 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeStashEntry.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeStashEntry.java @@ -46,16 +46,12 @@ public RuntimeGlob createDetachedCopy() { */ @Override public RuntimeGlob globDeref() { - RuntimeGlob pure = new RuntimeGlob(this.globName); - pure.IO = this.IO; - return pure; + return GlobalVariable.getGlobalIO(this.globName); } @Override public RuntimeGlob globDerefNonStrict(String packageName) { - RuntimeGlob pure = new RuntimeGlob(this.globName); - pure.IO = this.IO; - return pure; + return GlobalVariable.getGlobalIO(this.globName); } // Note on Stash Operations: diff --git a/src/test/resources/unit/parser_syntax_error.t b/src/test/resources/unit/parser_syntax_error.t new file mode 100644 index 000000000..0d1bfc9dd --- /dev/null +++ b/src/test/resources/unit/parser_syntax_error.t @@ -0,0 +1,8 @@ +use strict; +use warnings; +use Test::More; + +eval q{sub parser_syntax_error_probe { if }}; +like($@, qr/\Asyntax error at /, 'unexpected token reports Perl syntax error'); + +done_testing(); diff --git a/src/test/resources/unit/typeglob.t b/src/test/resources/unit/typeglob.t index 3ca483de0..608573748 100644 --- a/src/test/resources/unit/typeglob.t +++ b/src/test/resources/unit/typeglob.t @@ -45,6 +45,50 @@ subtest 'Scalar::Util::refaddr for named glob references' => sub { 'different named glob refs report different refaddrs'); }; +subtest 'Scalar::Util::reftype for glob IO slots' => sub { + require Scalar::Util; + + open typeglob_reftype_io, '<', 'Makefile' or die "open Makefile: $!"; + is(Scalar::Util::reftype(*typeglob_reftype_io{IO}), 'IO', + 'IO slot reports reftype IO'); + is(Scalar::Util::reftype(*typeglob_reftype_io), undef, + 'bare typeglob is not a reference'); +}; + +our $typeglob_compile_time_io; +{ + package TypeglobCompileTimeFH; + { + no warnings; + open foo, '<', 'Makefile' or die "open Makefile: $!"; + } + BEGIN { $main::typeglob_compile_time_io = *foo{IO} } +} + +subtest 'bareword open vivifies IO slot at compile time' => sub { + ok(defined $typeglob_compile_time_io, 'BEGIN sees IO slot for later bareword open'); + is(*TypeglobCompileTimeFH::foo{IO}, $typeglob_compile_time_io, + 'runtime open preserves compile-time IO slot identity'); +}; + +subtest 'dynamic stash glob assignment restores IO slots' => sub { + require Package::Stash; + + { + package TypeglobStashIO; + open foo, '<', 'Makefile' or die "open Makefile: $!"; + } + + my $stash = Package::Stash->new('TypeglobStashIO'); + my $io = $stash->get_symbol('foo'); + $stash->remove_glob('foo'); + ok(!defined *TypeglobStashIO::foo{IO}, 'IO slot removed with glob'); + + $stash->add_symbol('foo', $io); + ok(defined *TypeglobStashIO::foo{IO}, 'IO slot restored through stash entry glob assignment'); + is(*TypeglobStashIO::foo{IO}, $io, 'restored IO slot is the original handle'); +}; + subtest 'Using typeglobs as file handles' => sub { my $fh = *STDOUT; my $fh2 = \*STDOUT; From e3078bb2aada41103191af04237e50fae52c483d Mon Sep 17 00:00:00 2001 From: "Flavio S. Glock" Date: Thu, 21 May 2026 14:20:42 +0200 Subject: [PATCH 2/3] fix: keep live weak closure arguments callable DBIx::Class::Storage::BlockRunner weakens a fresh closure argument copy before invoking it. Perl keeps the caller's strong lexical alive, but PerlOnJava's CODE weak-ref sweep cleared the weak copy immediately when the closure had no counted owners. Teach the CODE weak-ref cleanup path to preserve weak CODE refs while a current live scalar still points at the same RuntimeCode, without preserving stale deleted stash slots used by Sub::Quote cleanup. Generated with Codex (https://openai.com/codex) Co-Authored-By: Codex --- .../runtimetypes/ReachabilityWalker.java | 20 +++++++++++++++++ .../runtime/runtimetypes/WeakRefRegistry.java | 10 ++++++++- .../unit/refcount/weaken_closure_argument.t | 22 +++++++++++++++++++ 3 files changed, 51 insertions(+), 1 deletion(-) create mode 100644 src/test/resources/unit/refcount/weaken_closure_argument.t diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/ReachabilityWalker.java b/src/main/java/org/perlonjava/runtime/runtimetypes/ReachabilityWalker.java index 046580ceb..722ad09e2 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/ReachabilityWalker.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/ReachabilityWalker.java @@ -522,6 +522,26 @@ && followGlobalCodeCaptures(code, target, seen, todo)) { return false; } + public static boolean hasLiveStrongScalarReferent(RuntimeBase target) { + if (target == null) return false; + for (Object liveVar : MyVarCleanupStack.snapshotLiveVars()) { + if (liveVar instanceof RuntimeScalar sc + && !WeakRefRegistry.isweak(sc) + && !sc.scopeExited + && sc.value == target) { + return true; + } + } + for (RuntimeScalar sc : ScalarRefRegistry.snapshot()) { + if (sc == null) continue; + if (WeakRefRegistry.isweak(sc)) continue; + if (sc.scopeExited) continue; + if (!MyVarCleanupStack.isLive(sc)) continue; + if (sc.value == target) return true; + } + return false; + } + public static boolean isReachableFromGlobalCodeCaptures(RuntimeBase target) { if (target == null) return false; Set seen = Collections.newSetFromMap(new IdentityHashMap<>()); diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/WeakRefRegistry.java b/src/main/java/org/perlonjava/runtime/runtimetypes/WeakRefRegistry.java index 6dfdccf85..aa6d20f29 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/WeakRefRegistry.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/WeakRefRegistry.java @@ -188,10 +188,13 @@ public static void weaken(RuntimeScalar ref) { ref.refCountOwned = false; base.refCount = WEAKLY_TRACKED; } + boolean shouldSweepLiveCodeRef = weakenedLiveCodeRef + && codeRefHasCountedOwners(base) + && !ModuleInitGuard.inModuleInit(); if (base instanceof RuntimeCode code && code.refCount >= 0 && weakRefsExist - && ((weakenedLiveCodeRef && !ModuleInitGuard.inModuleInit()) + && (shouldSweepLiveCodeRef || (code.hadStashRef && code.stashRefCount <= 0 && !isInstalledGlobalCodeRef(code)))) { @@ -205,6 +208,10 @@ public static void weaken(RuntimeScalar ref) { } } + private static boolean codeRefHasCountedOwners(RuntimeBase base) { + return base.refCount > 0 || base.activeOwnerCount() > 0; + } + /** * Check if a RuntimeScalar is a weak reference. */ @@ -295,6 +302,7 @@ private static boolean isInstalledGlobalCodeRef(RuntimeCode code) { private static boolean shouldKeepCodeWeakRefs(RuntimeCode code) { if (code.stashRefCount > 0 || isInstalledGlobalCodeRef(code)) return true; + if (ReachabilityWalker.hasLiveStrongScalarReferent(code)) return true; return RuntimeCode.isActiveCode(code); } diff --git a/src/test/resources/unit/refcount/weaken_closure_argument.t b/src/test/resources/unit/refcount/weaken_closure_argument.t new file mode 100644 index 000000000..abc391603 --- /dev/null +++ b/src/test/resources/unit/refcount/weaken_closure_argument.t @@ -0,0 +1,22 @@ +#!/usr/bin/env perl +use strict; +use warnings; + +use Scalar::Util qw(isweak weaken); +use Test::More tests => 3; + +sub run_callback { + my $callback = shift; + return weaken_and_call($callback); +} + +sub weaken_and_call { + weaken(my $weak_callback = shift); + + ok(isweak($weak_callback), 'closure argument copy is weak'); + ok(defined $weak_callback, 'weak closure argument copy survives while caller holds it'); + is($weak_callback->(), 'captured value', 'weak closure argument remains callable'); +} + +my $captured = 'captured value'; +run_callback(sub { $captured }); From 8ee80477265d9c3a6d74af70ba0b83610bf41ddf Mon Sep 17 00:00:00 2001 From: "Flavio S. Glock" Date: Thu, 21 May 2026 14:51:07 +0200 Subject: [PATCH 3/3] fix: dispatch tie class strings as packages When tie receives a class-name string, resolve the TIE* constructor directly through package method lookup instead of routing through generic string method dispatch. Generic dispatch treats a same-named IO slot as a filehandle object, which regressed op/tie.t after bareword filehandles began preserving IO::File identity. Add a focused regression test for fileno FOO followed by tie @array, "FOO". Generated with [OpenAI Codex](https://openai.com/codex) Co-Authored-By: OpenAI Codex --- .../runtime/operators/TieOperators.java | 37 +++++++++++++++---- .../unit/tie_bareword_filehandle_package.t | 19 ++++++++++ 2 files changed, 49 insertions(+), 7 deletions(-) create mode 100644 src/test/resources/unit/tie_bareword_filehandle_package.t diff --git a/src/main/java/org/perlonjava/runtime/operators/TieOperators.java b/src/main/java/org/perlonjava/runtime/operators/TieOperators.java index 2539a3563..8a95d23e4 100644 --- a/src/main/java/org/perlonjava/runtime/operators/TieOperators.java +++ b/src/main/java/org/perlonjava/runtime/operators/TieOperators.java @@ -1,9 +1,11 @@ package org.perlonjava.runtime.operators; +import org.perlonjava.runtime.mro.InheritanceResolver; import org.perlonjava.runtime.runtimetypes.*; import java.util.Arrays; +import static org.perlonjava.runtime.runtimetypes.GlobalVariable.getGlobalVariable; import static org.perlonjava.runtime.runtimetypes.RuntimeArray.TIED_ARRAY; import static org.perlonjava.runtime.runtimetypes.RuntimeHash.TIED_HASH; import static org.perlonjava.runtime.runtimetypes.RuntimeScalarCache.scalarTrue; @@ -64,13 +66,15 @@ public static RuntimeScalar tie(int ctx, RuntimeBase... scalars) { // (not a string). This matches Perl's tie() behavior where `tie *$obj, $obj` // passes the blessed object as $_[0] to TIEHANDLE. RuntimeScalar invocant = blessId != 0 ? classArg : new RuntimeScalar(className); - RuntimeScalar self = RuntimeCode.call( - invocant, - new RuntimeScalar(method), - null, - args, - RuntimeContextType.SCALAR - ).getFirst(); + RuntimeScalar self = blessId != 0 + ? RuntimeCode.call( + invocant, + new RuntimeScalar(method), + null, + args, + RuntimeContextType.SCALAR + ).getFirst() + : callTieConstructor(className, method, args); switch (variable.type) { case REFERENCE -> { @@ -132,6 +136,25 @@ public static RuntimeScalar tie(int ctx, RuntimeBase... scalars) { return self; } + private static RuntimeScalar callTieConstructor(String className, String methodName, RuntimeArray args) { + args.elements.addFirst(new RuntimeScalar(className)); + + RuntimeScalar method = InheritanceResolver.findMethodInHierarchy(methodName, className, null, 0); + if (method == null) { + throw new PerlCompilerException("Can't locate object method \"" + methodName + + "\" via package \"" + className + "\" (perhaps you forgot to load \"" + + className + "\"?)"); + } + + String autoloadVariableName = ((RuntimeCode) method.value).autoloadVariableName; + if (autoloadVariableName != null && !methodName.equals("AUTOLOAD")) { + getGlobalVariable(autoloadVariableName).set( + NameNormalizer.normalizeVariableName(methodName, className)); + } + + return RuntimeCode.apply(method, args, RuntimeContextType.SCALAR).getFirst(); + } + /** * Implements Perl's untie() builtin function. * diff --git a/src/test/resources/unit/tie_bareword_filehandle_package.t b/src/test/resources/unit/tie_bareword_filehandle_package.t new file mode 100644 index 000000000..1e8ad9023 --- /dev/null +++ b/src/test/resources/unit/tie_bareword_filehandle_package.t @@ -0,0 +1,19 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More tests => 1; + +sub IO::File::TIEARRAY { + die "tie used the bareword filehandle object\n"; +} + +fileno FOO; + +my @array; +eval { tie @array, "FOO" }; + +like( + $@, + qr/^Can't locate object method "TIEARRAY" via package "FOO"/, + 'tie class string does not dispatch through a same-named filehandle' +);