WIP: Fix issue #1118 module test failures

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.
 

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) {

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;

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(@_)`

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.
      *

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());

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");
@@ -2265,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;

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;

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;

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;

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;