From 5e64f2b857558cb11124c692cec2699cf7079198 Mon Sep 17 00:00:00 2001 From: "Flavio S. Glock" Date: Mon, 7 Sep 2026 10:20:30 +0200 Subject: [PATCH 1/3] wip: snapshot before issue 1118 investigation Generated with [Codex](https://openai.com/codex) Co-Authored-By: Codex From e7633752eeb2586e748ccaf2acc8232e5f150fe0 Mon Sep 17 00:00:00 2001 From: "Flavio S. Glock" Date: Mon, 7 Sep 2026 12:12:14 +0200 Subject: [PATCH 2/3] wip: checkpoint issue 1118 compatibility fixes Preserve validated socket, parser, regex, import, interpreter, and scalar reference lifetime fixes while Object::Event guard lifetime investigation continues. Generated with [Codex](https://openai.com/codex) Co-Authored-By: Codex --- .../frontend/parser/StringDoubleQuoted.java | 14 ++++ .../frontend/parser/SubroutineParser.java | 10 ++- .../perlonjava/frontend/parser/Variable.java | 11 +++ .../org/perlonjava/runtime/io/SocketIO.java | 48 +++++++++++++ .../runtime/operators/IOOperator.java | 11 +-- .../runtime/runtimetypes/RuntimeScalar.java | 10 ++- .../unit/destroy_scalar_guard_assignment.t | 69 +++++++++++++++++++ .../indirect_object_hash_deref_constructor.t | 24 +++++++ .../interpreter_eval_redefine_direct_call.t | 12 ++++ .../regex/substitution_backreference_escape.t | 26 +++++++ src/test/resources/unit/socket_shutdown_eof.t | 16 +++++ .../resources/unit/universal_import_noop.t | 16 +++++ 12 files changed, 255 insertions(+), 12 deletions(-) create mode 100644 src/test/resources/unit/destroy_scalar_guard_assignment.t create mode 100644 src/test/resources/unit/indirect_object_hash_deref_constructor.t create mode 100644 src/test/resources/unit/interpreter_eval_redefine_direct_call.t create mode 100644 src/test/resources/unit/regex/substitution_backreference_escape.t create mode 100644 src/test/resources/unit/socket_shutdown_eof.t create mode 100644 src/test/resources/unit/universal_import_noop.t diff --git a/src/main/java/org/perlonjava/frontend/parser/StringDoubleQuoted.java b/src/main/java/org/perlonjava/frontend/parser/StringDoubleQuoted.java index 1fd9ed7b0..8a38d2daf 100644 --- a/src/main/java/org/perlonjava/frontend/parser/StringDoubleQuoted.java +++ b/src/main/java/org/perlonjava/frontend/parser/StringDoubleQuoted.java @@ -651,6 +651,20 @@ private static String normalizeUnicodePropertyPart(String part) { private void parseDoubleQuotedEscapes() { var token = tokens.get(parser.tokenIndex); + // In an s/// replacement, \1 through \9 are capture references, not + // octal character escapes. Keeping them as ordinary quoted-string + // escapes turns `s/(x)/\1/` into a control character and breaks + // substitutions that retain a delimiter through a backreference. + if (isRegexReplacement && token.type == LexerTokenType.NUMBER + && token.text.length() == 1 + && token.text.charAt(0) >= '1' && token.text.charAt(0) <= '9') { + flushCurrentSegment(); + hasRuntimeInterpolation = true; + String group = TokenUtils.consumeChar(parser); + addStringSegment(new OperatorNode("$", new IdentifierNode(group, tokenIndex), tokenIndex)); + return; + } + // Handle octal escapes (\123) // Octal escapes start with a digit 0-7 if (token.type == LexerTokenType.NUMBER) { diff --git a/src/main/java/org/perlonjava/frontend/parser/SubroutineParser.java b/src/main/java/org/perlonjava/frontend/parser/SubroutineParser.java index 1f4114fd2..e4698f8d6 100644 --- a/src/main/java/org/perlonjava/frontend/parser/SubroutineParser.java +++ b/src/main/java/org/perlonjava/frontend/parser/SubroutineParser.java @@ -256,6 +256,13 @@ && isValidIndirectMethod(subName, parser) } } LexerToken token = peek(parser); + // `%{...}` starts a list argument by dereferencing a hash. `%` + // is also an infix operator, but treating it as one here rejects + // the classic indirect constructor form + // `new Class %{ $options }, key => value`. + boolean hashDereferenceArgument = token.text.equals("%") + && parser.tokenIndex + 1 < parser.tokens.size() + && parser.tokens.get(parser.tokenIndex + 1).text.equals("{"); boolean qualifiedNamedArgument = packageName.contains("::") && token.text.equals("-") && parser.tokenIndex + 1 < parser.tokens.size() @@ -329,7 +336,8 @@ && isValidIndirectMethod(subName, parser) // Not a known subroutine, check if it's valid indirect object syntax if (!isKnownSub && !isLexicalSub && isValidIndirectMethod(packageName)) { if (!(token.text.equals("->") || token.text.equals("=>") - || (INFIX_OP.contains(token.text) && !qualifiedNamedArgument))) { + || (INFIX_OP.contains(token.text) && !qualifiedNamedArgument + && !hashDereferenceArgument))) { // System.out.println(" package loaded: " + packageName + "->" + subName); ListNode arguments; diff --git a/src/main/java/org/perlonjava/frontend/parser/Variable.java b/src/main/java/org/perlonjava/frontend/parser/Variable.java index 8508f16eb..c55d8f49e 100644 --- a/src/main/java/org/perlonjava/frontend/parser/Variable.java +++ b/src/main/java/org/perlonjava/frontend/parser/Variable.java @@ -922,6 +922,17 @@ static Node parseCoderefVariable(Parser parser, LexerToken token) { } } + // An explicit &name invocation, like an ordinary named call, resolves + // the current CODE slot at the call site. Lazy routines commonly + // replace themselves through eval and then invoke &name to enter the + // replacement. Snapshotting the old CV instead recurses into the + // lazy wrapper. + if (node instanceof OperatorNode operatorNode + && operatorNode.operator.equals("&") + && operatorNode.operand instanceof IdentifierNode) { + operatorNode.setAnnotation("directNamedCall", true); + } + Node list; boolean shareArgs = false; // If the next token is not `(`, handle auto-call by transforming `&subr` to `&subr(@_)` diff --git a/src/main/java/org/perlonjava/runtime/io/SocketIO.java b/src/main/java/org/perlonjava/runtime/io/SocketIO.java index 84a416655..b8e5a87eb 100644 --- a/src/main/java/org/perlonjava/runtime/io/SocketIO.java +++ b/src/main/java/org/perlonjava/runtime/io/SocketIO.java @@ -1036,6 +1036,54 @@ public RuntimeScalar eof() { return isEOF ? scalarTrue : scalarFalse; } + /** + * Shuts down one or both directions of a connected stream socket without + * closing its descriptor. This is the socket-level half-close used by + * protocols that must send EOF after a response while retaining the handle + * briefly for event-loop cleanup. + * + * @param how 0 for input, 1 for output, or 2 for both directions + * @return a Perl true value on success, false with {@code $!} set otherwise + */ + public RuntimeScalar shutdown(int how) { + try { + if (socketChannel != null) { + switch (how) { + case 0 -> socketChannel.shutdownInput(); + case 1 -> socketChannel.shutdownOutput(); + case 2 -> { + socketChannel.shutdownInput(); + socketChannel.shutdownOutput(); + } + default -> { + getGlobalVariable("main::!").set("Invalid shutdown mode"); + return scalarFalse; + } + } + return scalarTrue; + } + if (socket != null) { + switch (how) { + case 0 -> socket.shutdownInput(); + case 1 -> socket.shutdownOutput(); + case 2 -> { + socket.shutdownInput(); + socket.shutdownOutput(); + } + default -> { + getGlobalVariable("main::!").set("Invalid shutdown mode"); + return scalarFalse; + } + } + return scalarTrue; + } + getGlobalVariable("main::!").set("Not a connected stream socket"); + return scalarFalse; + } catch (IOException e) { + return handleIOException(e, "shutdown operation failed"); + } + } + /** * Closes the socket or server socket, releasing any associated resources. * diff --git a/src/main/java/org/perlonjava/runtime/operators/IOOperator.java b/src/main/java/org/perlonjava/runtime/operators/IOOperator.java index 8a362740e..9ebe83492 100644 --- a/src/main/java/org/perlonjava/runtime/operators/IOOperator.java +++ b/src/main/java/org/perlonjava/runtime/operators/IOOperator.java @@ -2859,16 +2859,7 @@ public static RuntimeScalar shutdown(int ctx, RuntimeBase... args) { return scalarFalse; } - // For now, implement basic shutdown by closing the socket - // In a full implementation, we would handle the different HOW values: - // 0 = SHUT_RD (shutdown reading), 1 = SHUT_WR (shutdown writing), 2 = SHUT_RDWR (shutdown both) - if (socketIO.getSocketHandle() != null) { - // For simplicity, just return success - actual socket shutdown would be more complex - return scalarTrue; - } else { - getGlobalVariable("main::!").set("Not a socket handle for shutdown"); - return scalarFalse; - } + return socketIO.getSocketHandle().shutdown(how); } catch (Exception e) { getGlobalVariable("main::!").set("shutdown failed: " + e.getMessage()); diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeScalar.java b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeScalar.java index ddf829f32..0be3624c9 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeScalar.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeScalar.java @@ -2028,6 +2028,13 @@ && isSocketIOHandle(oldIo.ioHandle)) { if ((this.type & RuntimeScalarType.REFERENCE_BIT) != 0 && this.value != null) { oldBase = (RuntimeBase) this.value; } + // A reference to this scalar keeps its current contents alive through + // scalarReferenceContents. Assigning through $$ref transfers that + // ownership to the new contents, so the old referent must be released + // even though this scalar did not itself record a direct store owner. + boolean oldOwnedByScalarReference = oldBase != null + && referencedByScalarReference + && refCount > 0; boolean oldOwnedScalarReferenceContents = this.ownsScalarReferenceContents; RuntimeScalar oldScalarReferenceContents = scalarReferenceContentsReferent(this); boolean shouldReleaseUnrootedRescuedGraph = false; @@ -2178,7 +2185,8 @@ && hasLiveIo(assignedGlob)) { // Decrement old value's refCount AFTER assignment (skip for weak refs // and for scalars that didn't own a refCount increment). - if (oldBase != null && !thisWasWeak && this.refCountOwned) { + if (oldBase != null && !thisWasWeak + && (this.refCountOwned || oldOwnedByScalarReference)) { if (oldBase.refCount > 0) { oldBase.traceRefCount(-1, "RuntimeScalar.setLargeRefCounted (decrement on overwrite)"); oldBase.releaseOwner(this, "setLargeRefCounted overwrite"); diff --git a/src/test/resources/unit/destroy_scalar_guard_assignment.t b/src/test/resources/unit/destroy_scalar_guard_assignment.t new file mode 100644 index 000000000..0e6baade5 --- /dev/null +++ b/src/test/resources/unit/destroy_scalar_guard_assignment.t @@ -0,0 +1,69 @@ +use strict; +use warnings; +use Test::More; + +our $destroyed = 0; +our $callback_ran = 0; + +{ + package Local::Guard; + + sub DESTROY { + ++$main::destroyed; + ${$_[0]}->(); + } +} + +sub guard { + bless \(my $callback = shift), 'Local::Guard'; +} + +my $guard = guard(sub { ++$callback_ran }); +$guard = guard(sub { }); + +is $destroyed, 1, 'overwriting a scalar guard destroys its previous referent'; +is $callback_ran, 1, 'the scalar guard callback runs once'; + +our @released; + +{ + package Local::WrappedGuard; + + sub DESTROY { push @main::released, $_[0]->[0] } +} + +sub wrapped_guard { + my ($name) = @_; + \(my $guard = bless [$name], 'Local::WrappedGuard'); +} + +my $id = wrapped_guard('first'); +$$id = undef; +$id = wrapped_guard('second'); + +is_deeply \@released, ['first'], + 'writing through a scalar reference releases its old guard referent'; +is $$id->[0], 'second', 'the scalar reference receives its replacement guard'; + +our @returned_releases; + +{ + package Local::ReturnedGuard; + + sub DESTROY { ${$_[0]}->() } +} + +sub returned_guard { + my ($name) = @_; + \(my $guard = bless \(my $callback = sub { push @returned_releases, $name }), + 'Local::ReturnedGuard'); +} + +my $returned_id = returned_guard('first'); +$$returned_id = undef; +$returned_id = returned_guard('second'); + +is_deeply \@returned_releases, ['first'], + 'a returned scalar reference transfers its guard owner to the caller'; +ok defined $$returned_id, 'the replacement returned guard remains alive'; +done_testing; diff --git a/src/test/resources/unit/indirect_object_hash_deref_constructor.t b/src/test/resources/unit/indirect_object_hash_deref_constructor.t new file mode 100644 index 000000000..9844502ce --- /dev/null +++ b/src/test/resources/unit/indirect_object_hash_deref_constructor.t @@ -0,0 +1,24 @@ +use strict; +use warnings; +use Test::More; + +{ + package Issue1118::Constructor; + + sub new { + my ($class, %args) = @_; + return bless \%args, $class; + } +} + +my %options = (handle_params => { from_hash => 'preserved' }); +my $object = new Issue1118::Constructor + %{ $options{handle_params} }, + explicit => 'argument'; + +isa_ok($object, 'Issue1118::Constructor', + 'indirect constructor accepts a hash dereference as its first argument'); +is($object->{from_hash}, 'preserved', 'hash dereference expands into constructor arguments'); +is($object->{explicit}, 'argument', 'following named arguments are retained'); + +done_testing; diff --git a/src/test/resources/unit/interpreter_eval_redefine_direct_call.t b/src/test/resources/unit/interpreter_eval_redefine_direct_call.t new file mode 100644 index 000000000..e9e8260cb --- /dev/null +++ b/src/test/resources/unit/interpreter_eval_redefine_direct_call.t @@ -0,0 +1,12 @@ +use strict; +use warnings; +use Test::More; + +sub lazy { + eval q{ *lazy = sub { 42 } }; + die $@ if $@; + &lazy; +} + +is lazy(), 42, 'an explicit named call observes an eval-installed replacement'; +done_testing; diff --git a/src/test/resources/unit/regex/substitution_backreference_escape.t b/src/test/resources/unit/regex/substitution_backreference_escape.t new file mode 100644 index 000000000..f1ef7cc41 --- /dev/null +++ b/src/test/resources/unit/regex/substitution_backreference_escape.t @@ -0,0 +1,26 @@ +use strict; +use warnings; +use Test::More; + +my $single = 'left:right'; +is($single =~ s/(left):/\1=/, 1, 'single substitution with escaped capture succeeds'); +is($single, 'left=right', 'escaped capture expands to capture group rather than an octal byte'); + +my $boundary = 'Aa'; +my $multipart = "--Aa\015\012H: one\015\012\015\012first\015\012" + . "--Aa\015\012H: two\015\012\015\012second\015\012--Aa--\015\012"; +my @parts; +while ($multipart =~ s/ + ^--\Q$boundary\E \015?\012 + ((?:[^\015\012]+\015\012)* ) \015?\012 + (.*?) \015?\012 + (--\Q$boundary\E (--)? \015?\012) + /\3/xs) { + push @parts, $2; +} + +is_deeply(\@parts, [qw(first second)], + 'escaped boundary capture permits every multipart section to be decoded'); +is($multipart, "--Aa--\015\012", 'final boundary remains after each captured replacement'); + +done_testing; diff --git a/src/test/resources/unit/socket_shutdown_eof.t b/src/test/resources/unit/socket_shutdown_eof.t new file mode 100644 index 000000000..a10c04607 --- /dev/null +++ b/src/test/resources/unit/socket_shutdown_eof.t @@ -0,0 +1,16 @@ +use strict; +use warnings; +use Socket qw(AF_UNIX SOCK_STREAM PF_UNSPEC); +use Test::More; + +socketpair(my $writer, my $reader, AF_UNIX, SOCK_STREAM, PF_UNSPEC) + or plan skip_all => "socketpair unavailable: $!"; + +is(syswrite($writer, 'response'), 8, 'writer sends response bytes'); +ok(shutdown($writer, 1), 'shutdown closes only the writer send side'); +is(sysread($reader, my $response, 8), 8, 'reader receives response bytes'); +is($response, 'response', 'reader receives the complete response'); +is(sysread($reader, my $eof, 1), 0, + 'reader promptly observes EOF after peer shuts down its send side'); + +done_testing; diff --git a/src/test/resources/unit/universal_import_noop.t b/src/test/resources/unit/universal_import_noop.t new file mode 100644 index 000000000..dddee2df4 --- /dev/null +++ b/src/test/resources/unit/universal_import_noop.t @@ -0,0 +1,16 @@ +use strict; +use warnings; +use Test::More; + +{ + package Issue1118::InheritedImport; + our @ISA = qw(UNIVERSAL); +} + +BEGIN { + Issue1118::InheritedImport->import('already_available'); +} + +pass('an inherited default UNIVERSAL::import accepts an import list as a no-op'); + +done_testing; From dd894a00e967a08fe3f695b4df6b7a82bbf422ca Mon Sep 17 00:00:00 2001 From: "Flavio S. Glock" Date: Mon, 7 Sep 2026 14:55:01 +0200 Subject: [PATCH 3/3] fix: preserve deferred interpreter-fallback return guards Delay deferred-mortal flushing while releasing a previous scalar-reference owner, so a guard DESTROY cannot release a new interpreter-fallback return before the caller installs it. Add a focused regression modeled on Object::Event's registration guards. Generated with [Codex](https://openai.com/codex) Co-Authored-By: Codex --- docs/about/changelog.md | 4 + .../runtime/runtimetypes/RuntimeScalar.java | 11 ++- ...erpreter_fallback_scalar_reference_guard.t | 79 +++++++++++++++++++ 3 files changed, 93 insertions(+), 1 deletion(-) create mode 100644 src/test/resources/unit/interpreter_fallback_scalar_reference_guard.t diff --git a/docs/about/changelog.md b/docs/about/changelog.md index c68814256..8247f5149 100644 --- a/docs/about/changelog.md +++ b/docs/about/changelog.md @@ -6,6 +6,10 @@ priorities and future plans. ## Work in progress +- Keep deferred interpreter-fallback return values alive while a replacement + scalar reference releases a guard, restoring Object::Event callback-guard + assignment semantics. + - Make PPIx::Regexp 0.092's upstream suite pass by clearing its private weak parent-map test hook at the post-parse quiescence point. diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeScalar.java b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeScalar.java index 0be3624c9..c6c8ff009 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeScalar.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeScalar.java @@ -2273,7 +2273,16 @@ && hasLiveIo(assignedGlob)) { } if (oldOwnedScalarReferenceContents) { - releaseScalarReferenceContents(oldScalarReferenceContents); + // Releasing the previous scalar-reference owner may invoke a + // guard's DESTROY. Keep deferred return owners dormant until the + // replacement has been fully installed in this scalar; otherwise + // nested DESTROY cleanup can release the just-returned value. + boolean flushWasSuppressed = MortalList.suppressFlush(true); + try { + releaseScalarReferenceContents(oldScalarReferenceContents); + } finally { + MortalList.suppressFlush(flushWasSuppressed); + } } if (undefAssignmentOfDestroyableRef && !DestroyDispatch.isInsideDestroy()) { shouldReleaseUnrootedRescuedGraph = true; diff --git a/src/test/resources/unit/interpreter_fallback_scalar_reference_guard.t b/src/test/resources/unit/interpreter_fallback_scalar_reference_guard.t new file mode 100644 index 000000000..f424bf12a --- /dev/null +++ b/src/test/resources/unit/interpreter_fallback_scalar_reference_guard.t @@ -0,0 +1,79 @@ +use strict; +use warnings; +use Test::More; + +{ + package Local::FallbackGuard; + + sub DESTROY { ${$_[0]}->() } +} + +sub make_guard (&) { + bless \(my $callback = shift), 'Local::FallbackGuard'; +} + +{ + package Local::FallbackRegistry; + + our $DEBUG = 0; + + sub new { bless { next => 'a', entries => [] }, shift } + + sub register { + my ($self, @args) = @_; + my $debuginfo = caller; + if ($DEBUG > 0) { + my ($package, $file, $line) = caller; + $debuginfo = "$file:$line ($package::)"; + } + + my $generation = $self->{next}++; + my @callbacks; + while (@args) { + my ($event, $callback) = (shift @args, shift @args); + my ($priority, $registered) = (0, undef); + if (ref $callback) { + $registered = $callback; + } else { + $priority = $callback; + $registered = shift @args; + } + push @callbacks, $registered; + push @{$self->{entries}}, "$registered|$generation"; + } + + defined wantarray + ? \(my $guard = main::make_guard { + if ($self) { + $self->remove($_, $generation) for @callbacks; + } + }) + : (); + } + + sub remove { + my ($self, $callback, $generation) = @_; + push @main::removed_generations, $generation; + @{$self->{entries}} = grep { $_ ne "$callback|$generation" } + @{$self->{entries}}; + } +} + +my $registry = Local::FallbackRegistry->new; +my $callback = sub { }; +our @removed_generations; +my $guard = $registry->register(event => $callback); +$guard = $registry->register(event => $callback); + +is scalar @{$registry->{entries}}, 1, + 'a returned scalar-reference guard survives assignment after interpreter fallback'; +is_deeply \@removed_generations, ['a'], + 'replacing the caller guard releases only the prior registration'; + +undef $guard; +is scalar @{$registry->{entries}}, 0, + 'the final guard is released when its caller-owned reference is dropped'; +is_deeply \@removed_generations, ['a', 'b'], + 'dropping the final guard releases its registration'; + +done_testing;