From 092617bfcd09d80d6bf77cb62c5d2e668f3b2b62 Mon Sep 17 00:00:00 2001 From: "Flavio S. Glock" Date: Thu, 30 Jul 2026 12:01:09 +0200 Subject: [PATCH] fix: support additional CPAN installation suites Fix compiler and runtime semantics exposed by HTML::Diff, Graph::PetriNet, MIME::Lite, File::Path::Tiny, Net::UDP, IO::Socket::INET6, Email::Sender, and JSONP. Add focused compatibility shims where XS or unsupported process features require them, plus regression coverage and documentation. Generated with [Codex](https://openai.com/codex) Co-Authored-By: Codex --- dev/modules/want.md | 15 +- docs/about/changelog.md | 22 ++ docs/reference/bundled-modules.md | 9 + docs/reference/feature-matrix.md | 9 +- .../backend/bytecode/BytecodeCompiler.java | 13 +- .../bytecode/CompileBinaryOperatorHelper.java | 2 +- .../frontend/parser/CoreOperatorResolver.java | 6 +- .../frontend/parser/StringDoubleQuoted.java | 23 ++ .../frontend/parser/StringSegmentParser.java | 11 + .../perlonjava/frontend/parser/Variable.java | 12 ++ .../runtime/io/PipeInputChannel.java | 6 +- .../runtime/io/PipeOutputChannel.java | 6 +- .../org/perlonjava/runtime/io/SocketIO.java | 39 ++-- .../runtime/mro/InheritanceResolver.java | 11 +- .../runtime/operators/IOOperator.java | 58 +++--- .../runtime/operators/SystemOperator.java | 2 +- .../perlonjava/runtime/perlmodule/NetGen.java | 196 ++++++++++++++++++ .../perlonjava/runtime/perlmodule/Socket.java | 36 ++-- .../runtime/runtimetypes/RuntimeCode.java | 39 +++- src/main/perl/lib/CPAN/Config.pm | 6 + src/main/perl/lib/Email/Address/XS.pm | 174 ++++++++++++++++ .../CpanDistroprefs/Class-Trait.yml | 13 ++ .../lib/PerlOnJava/CpanDistroprefs/Graph.yml | 2 +- .../CpanDistroprefs/IO-Socket-INET6.yml | 13 ++ .../SkipObsoleteModPerlWarningTest.patch | 7 + .../SkipForkSocketTests.patch | 27 +++ src/main/perl/lib/Socket6.pm | 88 ++++++++ src/main/perl/lib/Want.pm | 37 ++++ .../module/Email-Address-XS/t/basic.t | 12 ++ src/test/resources/module/Socket6/t/basic.t | 14 ++ .../unit/autoload_byte_method_name.t | 22 ++ src/test/resources/unit/core_dump_guarded.t | 6 + .../resources/unit/glob_slot_hash_deref.t | 31 +++ .../resources/unit/inherited_autoload_stub.t | 12 ++ .../resources/unit/lib/GlobSlotRegistry.pm | 33 +++ .../unit/lib/InheritedAutoLoaderChild.pm | 15 ++ .../unit/lib/InheritedAutoLoaderParent.pm | 7 + .../InheritedAutoLoaderParent/autosplit.ix | 4 + .../InheritedAutoLoaderParent/from_parent.al | 7 + src/test/resources/unit/pipe_jperl_shebang.t | 28 +++ .../resources/unit/socket_getaddrinfo_ipv6.t | 39 ++++ src/test/resources/unit/source_utf8_octets.t | 19 ++ .../resources/unit/subroutine_return_rvalue.t | 59 ++++++ 43 files changed, 1114 insertions(+), 76 deletions(-) create mode 100644 src/main/java/org/perlonjava/runtime/perlmodule/NetGen.java create mode 100644 src/main/perl/lib/Email/Address/XS.pm create mode 100644 src/main/perl/lib/PerlOnJava/CpanDistroprefs/Class-Trait.yml create mode 100644 src/main/perl/lib/PerlOnJava/CpanDistroprefs/IO-Socket-INET6.yml create mode 100644 src/main/perl/lib/PerlOnJava/CpanPatches/Class-Trait-0.33/SkipObsoleteModPerlWarningTest.patch create mode 100644 src/main/perl/lib/PerlOnJava/CpanPatches/IO-Socket-INET6-2.73/SkipForkSocketTests.patch create mode 100644 src/main/perl/lib/Socket6.pm create mode 100644 src/main/perl/lib/Want.pm create mode 100644 src/test/resources/module/Email-Address-XS/t/basic.t create mode 100644 src/test/resources/module/Socket6/t/basic.t create mode 100644 src/test/resources/unit/autoload_byte_method_name.t create mode 100644 src/test/resources/unit/core_dump_guarded.t create mode 100644 src/test/resources/unit/glob_slot_hash_deref.t create mode 100644 src/test/resources/unit/inherited_autoload_stub.t create mode 100644 src/test/resources/unit/lib/GlobSlotRegistry.pm create mode 100644 src/test/resources/unit/lib/InheritedAutoLoaderChild.pm create mode 100644 src/test/resources/unit/lib/InheritedAutoLoaderParent.pm create mode 100644 src/test/resources/unit/lib/auto/InheritedAutoLoaderParent/autosplit.ix create mode 100644 src/test/resources/unit/lib/auto/InheritedAutoLoaderParent/from_parent.al create mode 100644 src/test/resources/unit/pipe_jperl_shebang.t create mode 100644 src/test/resources/unit/socket_getaddrinfo_ipv6.t create mode 100644 src/test/resources/unit/source_utf8_octets.t create mode 100644 src/test/resources/unit/subroutine_return_rvalue.t diff --git a/dev/modules/want.md b/dev/modules/want.md index 637b25d2c..16ade5b59 100644 --- a/dev/modules/want.md +++ b/dev/modules/want.md @@ -229,15 +229,26 @@ The port is "done enough" when: ## Progress Tracking -### Current Status: scoping / design +### Current Status: JSONP compatibility subset implemented; A1 remains planned ### Completed Steps -- [ ] Design doc reviewed +- [x] Design doc reviewed (2026-07-29) +- [x] Added a focused pure-Perl compatibility subset for JSONP (2026-07-29) + - Implements `OBJECT`, `RVALUE`, `BOOL`, scalar/list/void queries, and + conservative non-lvalue defaults. + - File: `src/main/perl/lib/Want.pm` - [ ] A1 proof-of-concept on a feature branch - [ ] Class::Accessor::Lvalue passes - [ ] ActiveResource passes (sans network I/O) - [ ] Want.pm shim merged +### Next Steps + +1. Add the per-call-frame lvalue context described in A1. +2. Replace the conservative `OBJECT`/`RVALUE` answers with compiler-provided + call-site metadata. +3. Add `want_basics.t` and validate Class::Accessor::Lvalue. + ### Open Questions - A1 vs A2 vs B: confirm A1 (runtime hook + Perl shim) is the right starting point. diff --git a/docs/about/changelog.md b/docs/about/changelog.md index a8fe30d35..f1e57adc5 100644 --- a/docs/about/changelog.md +++ b/docs/about/changelog.md @@ -2,6 +2,28 @@ Release history of PerlOnJava. See [Roadmap](roadmap.md) for future plans. +## Work in progress + +- Add compatibility modules for `Socket6`, `Email::Address::XS`, and the + JSONP-used subset of `Want`; add a Java `Net::Gen` XS bridge for Net-ext. +- Bugfix: subroutine return values are rvalue copies instead of aliases to + reusable scalar containers. +- Bugfix: interpreter `map` now inherits the caller's scalar/list context. +- Bugfix: valid UTF-8 octets in interpolated source strings compile without + `use utf8` while retaining byte-string semantics. +- Bugfix: inherited AutoSplit forward declarations now participate in method + resolution, allowing parent `.al` methods to load before child `AUTOLOAD` + fallbacks. +- Bugfix: nested typeglob hash/code dereferences and numeric or byte-string + `AUTOLOAD` method names retain their Perl symbol-table semantics. +- Bugfix: IPv6 bind/listen/send/receive, socket-name packing, and + `getnameinfo` work through Java NIO; UDP sends to wildcard local addresses + are routed consistently. +- Bugfix: generated `jperl` shebang commands work in piped opens without being + misclassified as shell syntax. +- CPAN: `HTML::Diff`, `Graph::PetriNet`, `MIME::Lite`, + `File::Path::Tiny`, `Net::UDP`, `IO::Socket::INET6`, + `Email::Sender`, and `JSONP` pass their installation test suites. ## v5.44.0: Named Parameters in Signatures diff --git a/docs/reference/bundled-modules.md b/docs/reference/bundled-modules.md index a6785a79c..41cf75935 100644 --- a/docs/reference/bundled-modules.md +++ b/docs/reference/bundled-modules.md @@ -7,6 +7,15 @@ Additional pure-Perl modules can be installed from CPAN with This page lists every bundled module, grouped by category, and documents modules that have **external requirements** or **special instructions**. +Recent CPAN compatibility additions include: + +| Module | Implementation | Notes | +|--------|----------------|-------| +| `Socket6` | Pure Perl over Java-backed `Socket` | Legacy Socket6 flat-result API and IPv6 sockaddr helpers | +| `Email::Address::XS` | Pure Perl compatibility subset | Address parsing/object API used by `Email::Sender` | +| `Want` | Pure Perl compatibility subset | Non-lvalue predicates used by `JSONP`; full op-tree introspection is not yet available | +| `Net::Gen` | Java XS bridge | Net-ext constants and sockaddr helpers used by `Net::UDP` | + --- ## Modules with External Requirements diff --git a/docs/reference/feature-matrix.md b/docs/reference/feature-matrix.md index 1b2f066d6..0dfe40713 100644 --- a/docs/reference/feature-matrix.md +++ b/docs/reference/feature-matrix.md @@ -710,6 +710,8 @@ The `:encoding()` layer supports all encodings provided by Java's `Charset.forNa - ✅ **IO::Socket** module. - ✅ **IO::Socket::INET** module. - ✅ **IO::Socket::UNIX** module. +- ✅ **Socket6** compatibility module backed by the core `Socket` IPv6 implementation. +- ✅ **Net::Gen** XS compatibility bridge for the Net-ext socket modules. - ✅ **IO::Zlib** module. - ✅ **List::Util**: module. - ✅ **MIME::Base64** module @@ -732,7 +734,12 @@ The `:encoding()` layer supports all encodings provided by Java's `Charset.forNa - ✅ **Time::Local** module. - ✅ **UNIVERSAL**: `isa`, `can`, `DOES`, `VERSION` are implemented. `isa` operator is implemented. - ✅ **URI::Escape** module. -- ✅ **Socket** module: socket constants and functions (`pack_sockaddr_in`, `unpack_sockaddr_in`, `sockaddr_in`, `inet_aton`, `inet_ntoa`, `gethostbyname`). +- ✅ **Socket** module: IPv4/IPv6 socket constants and functions, including + sockaddr packing, address presentation conversion, `getaddrinfo`, and + `getnameinfo`. +- ⚠️ **Want** compatibility subset: scalar/list/void and the non-lvalue + predicates needed by JSONP; full lvalue/op-tree introspection remains planned. +- ✅ **Email::Address::XS** compatibility subset used by Email::Sender. - ✅ **Unicode::UCD** module. - ✅ **XSLoader** module. - 🚧 **DynaLoader** placeholder module. diff --git a/src/main/java/org/perlonjava/backend/bytecode/BytecodeCompiler.java b/src/main/java/org/perlonjava/backend/bytecode/BytecodeCompiler.java index ea765f7a0..9be05128f 100644 --- a/src/main/java/org/perlonjava/backend/bytecode/BytecodeCompiler.java +++ b/src/main/java/org/perlonjava/backend/bytecode/BytecodeCompiler.java @@ -2682,7 +2682,18 @@ void handleGeneralArrayAccess(BinaryOperatorNode node) { */ void handleGeneralHashAccess(BinaryOperatorNode node) { // Compile the left side (the expression that should yield a hash or hashref) - node.left.accept(this); + // `${EXPR}{key}` applies the hash subscript directly to EXPR. It must + // not first compile `${EXPR}` as an independent scalar dereference: + // when EXPR is a typeglob, that would select its SCALAR slot instead + // of the HASH slot. This mirrors the JVM backend's `${BLOCK}{}` path. + if (node.left instanceof OperatorNode sigilNode + && sigilNode.operator.equals("$") + && sigilNode.operand instanceof BlockNode block + && block.elements.size() == 1) { + compileNode(block.elements.getFirst(), -1, RuntimeContextType.SCALAR); + } else { + node.left.accept(this); + } int baseReg = lastResultReg; // Compile the key expression (right side) diff --git a/src/main/java/org/perlonjava/backend/bytecode/CompileBinaryOperatorHelper.java b/src/main/java/org/perlonjava/backend/bytecode/CompileBinaryOperatorHelper.java index 1362923d6..2e69f3af6 100644 --- a/src/main/java/org/perlonjava/backend/bytecode/CompileBinaryOperatorHelper.java +++ b/src/main/java/org/perlonjava/backend/bytecode/CompileBinaryOperatorHelper.java @@ -284,7 +284,7 @@ private static int compileBinaryOperatorSwitch(BytecodeCompiler bytecodeCompiler bytecodeCompiler.emitReg(rd); bytecodeCompiler.emitReg(rs2); // List register bytecodeCompiler.emitReg(rs1); // Closure register - bytecodeCompiler.emit(RuntimeContextType.LIST); // Map always uses list context + bytecodeCompiler.emit(bytecodeCompiler.currentCallContext); } case "grep" -> { // Grep operator: grep { block } list diff --git a/src/main/java/org/perlonjava/frontend/parser/CoreOperatorResolver.java b/src/main/java/org/perlonjava/frontend/parser/CoreOperatorResolver.java index 8b3236f38..9a77c6e2b 100644 --- a/src/main/java/org/perlonjava/frontend/parser/CoreOperatorResolver.java +++ b/src/main/java/org/perlonjava/frontend/parser/CoreOperatorResolver.java @@ -130,7 +130,11 @@ public static Node parseCoreOperator(Parser parser, LexerToken token, int startI case "method" -> parseAnonymousMethodExpression(parser, startIndex); case "q", "qq", "qx", "qw", "qr", "tr", "y", "s", "m" -> OperatorParser.parseSpecialQuoted(parser, token, startIndex); - case "dump", "dbmclose", "dbmopen" -> + // CORE::dump is an obsolete process/core-dump primitive. Parse it + // as a harmless false value so legacy modules can compile guarded + // diagnostics without terminating the JVM. + case "dump" -> new NumberNode("0", parser.tokenIndex); + case "dbmclose", "dbmopen" -> throw new PerlJavaUnimplementedException(parser.tokenIndex, "Not implemented: operator: " + token.text, parser.ctx.errorUtil); case "format" -> // Format statements should be handled by StatementResolver, not as operators diff --git a/src/main/java/org/perlonjava/frontend/parser/StringDoubleQuoted.java b/src/main/java/org/perlonjava/frontend/parser/StringDoubleQuoted.java index 5055370b7..7a5d06b24 100644 --- a/src/main/java/org/perlonjava/frontend/parser/StringDoubleQuoted.java +++ b/src/main/java/org/perlonjava/frontend/parser/StringDoubleQuoted.java @@ -146,6 +146,29 @@ static Node parseDoubleQuotedString(EmitterContext ctx, StringParser.ParsedStrin var isRegex = !parseEscapes; if (CompilerOptions.DEBUG_ENABLED) ctx.logDebug("parseDoubleQuotedString isRegex:" + isRegex); + // StringParser represents non-utf8 source text as UTF-8 octets stored in + // Java chars. Decode those octets while tokenizing interpolation syntax; + // otherwise continuation bytes (for example 0x80 in a curly quote) are + // interpreted as source tokens and rejected. Literal segments are encoded + // back to octets by StringSegmentParser.flushCurrentSegment(). + if (!ctx.symbolTable.isStrictOptionEnabled(org.perlonjava.runtime.perlmodule.Strict.HINT_UTF8) + && !ctx.compilerOptions.isUnicodeSource + && !ctx.compilerOptions.isByteStringSource) { + byte[] octets = new byte[input.length()]; + boolean allOctets = true; + for (int i = 0; i < input.length(); i++) { + char ch = input.charAt(i); + if (ch > 0xff) { + allOctets = false; + break; + } + octets[i] = (byte) ch; + } + if (allOctets) { + input = new String(octets, java.nio.charset.StandardCharsets.UTF_8); + } + } + // Tokenize the string content var lexer = new Lexer(input); var tokens = lexer.tokenize(); diff --git a/src/main/java/org/perlonjava/frontend/parser/StringSegmentParser.java b/src/main/java/org/perlonjava/frontend/parser/StringSegmentParser.java index 3e5ca1c58..a292a26dd 100644 --- a/src/main/java/org/perlonjava/frontend/parser/StringSegmentParser.java +++ b/src/main/java/org/perlonjava/frontend/parser/StringSegmentParser.java @@ -192,6 +192,17 @@ protected void addStringSegment(Node node) { protected void flushCurrentSegment() { if (!currentSegment.isEmpty()) { String value = currentSegment.toString(); + if (currentSegmentHasSourceNonAscii + && !ctx.symbolTable.isStrictOptionEnabled(HINT_UTF8) + && !ctx.compilerOptions.isUnicodeSource + && !ctx.compilerOptions.isByteStringSource) { + byte[] utf8 = value.getBytes(java.nio.charset.StandardCharsets.UTF_8); + StringBuilder octets = new StringBuilder(utf8.length); + for (byte b : utf8) { + octets.append((char) (b & 0xff)); + } + value = octets.toString(); + } boolean forceByteString = shouldForceByteStringLiteral(value); addStringSegment(new StringNode(value, false, forceByteString, tokenIndex)); currentSegment.setLength(0); diff --git a/src/main/java/org/perlonjava/frontend/parser/Variable.java b/src/main/java/org/perlonjava/frontend/parser/Variable.java index 3af89c921..1d84a0269 100644 --- a/src/main/java/org/perlonjava/frontend/parser/Variable.java +++ b/src/main/java/org/perlonjava/frontend/parser/Variable.java @@ -1018,6 +1018,18 @@ public static Node parseBracedVariable(Parser parser, String sigil, boolean isSt bracedVarName = IdentifierParser.parseComplexIdentifierInner(parser, true); } + if (bracedVarName != null) { + // In a dereference such as `%{ $ {*$glob}{Keys} }`, the `$` + // starts a nested scalar expression; it is not the name of a + // global hash `%$`. Fall back to block parsing so the glob-slot + // expression remains intact. + if ((sigil.equals("%") || sigil.equals("@") || sigil.equals("&")) + && bracedVarName.equals("$")) { + bracedVarName = null; + parser.tokenIndex = savedIndex; + } + } + if (bracedVarName != null) { // Check if this might be ambiguous with an operator boolean isAmbiguous = isAmbiguousOperatorName(bracedVarName); diff --git a/src/main/java/org/perlonjava/runtime/io/PipeInputChannel.java b/src/main/java/org/perlonjava/runtime/io/PipeInputChannel.java index 848b6d4ba..a08ed892e 100644 --- a/src/main/java/org/perlonjava/runtime/io/PipeInputChannel.java +++ b/src/main/java/org/perlonjava/runtime/io/PipeInputChannel.java @@ -5,6 +5,7 @@ import org.perlonjava.runtime.runtimetypes.RuntimeIO; import org.perlonjava.runtime.runtimetypes.RuntimeScalar; import org.perlonjava.runtime.runtimetypes.RuntimeScalarCache; +import org.perlonjava.runtime.operators.SystemOperator; import java.io.*; import java.nio.charset.Charset; @@ -33,7 +34,7 @@ public class PipeInputChannel implements IOHandle { /** * Pattern to detect shell metacharacters */ - private static final Pattern SHELL_METACHARACTERS = Pattern.compile("[*?\\[\\]{}()<>|&;`'\"\\\\$\\s]"); + private static final Pattern SHELL_METACHARACTERS = Pattern.compile("[*?\\[\\]{}()<>|&;`'\"\\\\$]"); /** * The external process @@ -237,7 +238,8 @@ private void startProcess(String command) throws IOException { * @throws IOException if an I/O error occurs starting the process */ private void startProcessDirect(List commandArgs) throws IOException { - ProcessBuilder processBuilder = new ProcessBuilder(commandArgs); + ProcessBuilder processBuilder = new ProcessBuilder( + SystemOperator.resolveCommandForProcessBuilder(commandArgs)); setupProcess(processBuilder); } diff --git a/src/main/java/org/perlonjava/runtime/io/PipeOutputChannel.java b/src/main/java/org/perlonjava/runtime/io/PipeOutputChannel.java index f8a6b3973..81d05f884 100644 --- a/src/main/java/org/perlonjava/runtime/io/PipeOutputChannel.java +++ b/src/main/java/org/perlonjava/runtime/io/PipeOutputChannel.java @@ -5,6 +5,7 @@ import org.perlonjava.runtime.runtimetypes.RuntimeIO; import org.perlonjava.runtime.runtimetypes.RuntimeScalar; import org.perlonjava.runtime.runtimetypes.RuntimeScalarCache; +import org.perlonjava.runtime.operators.SystemOperator; import java.io.*; import java.nio.charset.Charset; @@ -52,7 +53,7 @@ public class PipeOutputChannel implements IOHandle { /** * Pattern to detect shell metacharacters */ - private static final Pattern SHELL_METACHARACTERS = Pattern.compile("[*?\\[\\]{}()<>|&;`'\"\\\\$\\s]"); + private static final Pattern SHELL_METACHARACTERS = Pattern.compile("[*?\\[\\]{}()<>|&;`'\"\\\\$]"); /** * The external process @@ -139,7 +140,8 @@ private void startProcess(String command) throws IOException { * @throws IOException if an I/O error occurs starting the process */ private void startProcessDirect(List commandArgs) throws IOException { - ProcessBuilder processBuilder = new ProcessBuilder(commandArgs); + ProcessBuilder processBuilder = new ProcessBuilder( + SystemOperator.resolveCommandForProcessBuilder(commandArgs)); setupProcess(processBuilder); } diff --git a/src/main/java/org/perlonjava/runtime/io/SocketIO.java b/src/main/java/org/perlonjava/runtime/io/SocketIO.java index daf62c12f..9e4ef55f9 100644 --- a/src/main/java/org/perlonjava/runtime/io/SocketIO.java +++ b/src/main/java/org/perlonjava/runtime/io/SocketIO.java @@ -517,7 +517,9 @@ public RuntimeScalar listen(int backlog) { } // Create a new ServerSocketChannel and bind to the same address - serverSocketChannel = ServerSocketChannel.open(); + serverSocketChannel = protocolFamily != null + ? ServerSocketChannel.open(protocolFamily) + : ServerSocketChannel.open(); // Transfer non-blocking mode from the original socket if (!blocking) { serverSocketChannel.configureBlocking(false); @@ -1045,26 +1047,35 @@ public RuntimeScalar getpeername() { */ private RuntimeScalar packSockaddrIn(InetSocketAddress address) { try { - byte[] sockaddr = new byte[16]; + byte[] ipBytes = address.getAddress().getAddress(); + if (ipBytes.length == 16) { + byte[] sockaddr = new byte[28]; + sockaddr[0] = 0; + sockaddr[1] = (byte) org.perlonjava.runtime.perlmodule.Socket.AF_INET6; + + int port = address.getPort(); + sockaddr[2] = (byte) ((port >> 8) & 0xFF); + sockaddr[3] = (byte) (port & 0xFF); + System.arraycopy(ipBytes, 0, sockaddr, 8, 16); + + int scopeId = address.getAddress() instanceof Inet6Address inet6 + ? inet6.getScopeId() + : 0; + sockaddr[24] = (byte) ((scopeId >> 24) & 0xFF); + sockaddr[25] = (byte) ((scopeId >> 16) & 0xFF); + sockaddr[26] = (byte) ((scopeId >> 8) & 0xFF); + sockaddr[27] = (byte) (scopeId & 0xFF); + return new RuntimeScalar(new String(sockaddr, StandardCharsets.ISO_8859_1)); + } - // Family: AF_INET = 2 (network byte order) + byte[] sockaddr = new byte[16]; sockaddr[0] = 0; - sockaddr[1] = 2; - - // Port (network byte order - big endian) + sockaddr[1] = (byte) org.perlonjava.runtime.perlmodule.Socket.AF_INET; int port = address.getPort(); sockaddr[2] = (byte) ((port >> 8) & 0xFF); sockaddr[3] = (byte) (port & 0xFF); - - // IP address (4 bytes) - byte[] ipBytes = address.getAddress().getAddress(); System.arraycopy(ipBytes, 0, sockaddr, 4, 4); - // Padding (8 bytes of zeros) - for (int i = 8; i < 16; i++) { - sockaddr[i] = 0; - } - return new RuntimeScalar(new String(sockaddr, StandardCharsets.ISO_8859_1)); } catch (Exception e) { return scalarUndef; diff --git a/src/main/java/org/perlonjava/runtime/mro/InheritanceResolver.java b/src/main/java/org/perlonjava/runtime/mro/InheritanceResolver.java index 003c4e594..af2a42b40 100644 --- a/src/main/java/org/perlonjava/runtime/mro/InheritanceResolver.java +++ b/src/main/java/org/perlonjava/runtime/mro/InheritanceResolver.java @@ -433,7 +433,16 @@ public static RuntimeScalar findMethodInHierarchy(String methodName, String perl if (GlobalVariable.existsGlobalCodeRef(normalizedClassMethodName)) { RuntimeScalar codeRef = GlobalVariable.getGlobalCodeRef(normalizedClassMethodName); - if (!RuntimeCode.isCodeDefined(codeRef)) { + // A forward declaration is a real method-table entry even + // before it has a body. AutoSplit relies on this: the stub + // in a parent class must win method lookup so invoking it + // reaches that package's AUTOLOAD and corresponding .al + // file. Ignore only incidental undefined code slots that + // were never declared. + boolean isDeclaredForward = codeRef != null + && codeRef.value instanceof RuntimeCode code + && code.isDeclared; + if (!RuntimeCode.isCodeDefined(codeRef) && !isDeclaredForward) { continue; } cacheMethod(cacheKey, codeRef); diff --git a/src/main/java/org/perlonjava/runtime/operators/IOOperator.java b/src/main/java/org/perlonjava/runtime/operators/IOOperator.java index 0324851ec..1519a9364 100644 --- a/src/main/java/org/perlonjava/runtime/operators/IOOperator.java +++ b/src/main/java/org/perlonjava/runtime/operators/IOOperator.java @@ -1863,11 +1863,11 @@ public static RuntimeScalar socket(int ctx, RuntimeBase... args) { // Map Perl socket constants to Java ProtocolFamily family; - if (domain == 2) { // AF_INET + if (domain == Socket.AF_INET) { family = StandardProtocolFamily.INET; - } else if (domain == 10) { // AF_INET6 + } else if (domain == Socket.AF_INET6) { family = StandardProtocolFamily.INET6; - } else if (domain == 1) { // AF_UNIX + } else if (domain == Socket.AF_UNIX) { family = StandardProtocolFamily.UNIX; } else { getGlobalVariable("main::!").set("Unsupported socket domain: " + domain); @@ -1937,27 +1937,25 @@ private static String[] parseSockaddrIn(String packedAddress) { byte[] bytes = packedAddress.getBytes(StandardCharsets.ISO_8859_1); // Get raw bytes if (bytes.length < 8) { - return null; // Too short for sockaddr_in + return null; } - // Check if first 2 bytes indicate AF_INET (family = 2) int family = ((bytes[0] & 0xFF) << 8) | (bytes[1] & 0xFF); - if (family != 2) { // AF_INET = 2 - return null; // Not a valid sockaddr_in structure - } - - // Extract port (bytes 2-3, network byte order) int port = ((bytes[2] & 0xFF) << 8) | (bytes[3] & 0xFF); - // Extract IP address (bytes 4-7) - int ip1 = bytes[4] & 0xFF; - int ip2 = bytes[5] & 0xFF; - int ip3 = bytes[6] & 0xFF; - int ip4 = bytes[7] & 0xFF; - - String host = ip1 + "." + ip2 + "." + ip3 + "." + ip4; - - return new String[]{host, String.valueOf(port)}; + if (family == Socket.AF_INET) { + String host = (bytes[4] & 0xFF) + "." + + (bytes[5] & 0xFF) + "." + + (bytes[6] & 0xFF) + "." + + (bytes[7] & 0xFF); + return new String[]{host, String.valueOf(port)}; + } + if (family == Socket.AF_INET6 && bytes.length >= 24) { + byte[] address = Arrays.copyOfRange(bytes, 8, 24); + String host = InetAddress.getByAddress(address).getHostAddress(); + return new String[]{host, String.valueOf(port)}; + } + return null; } catch (Exception e) { return null; @@ -2553,15 +2551,21 @@ public static RuntimeScalar send(int ctx, RuntimeBase... args) { if (socketIO.ioHandle instanceof SocketIO sio && sio.isDatagramSocket()) { byte[] data = message.getBytes(java.nio.charset.StandardCharsets.ISO_8859_1); if (args.length >= 4) { - // 4th arg is packed sockaddr_in (destination address) String packedAddr = args[3].toString(); - byte[] addrBytes = packedAddr.getBytes(java.nio.charset.StandardCharsets.ISO_8859_1); - if (addrBytes.length >= 8) { - int port = ((addrBytes[2] & 0xFF) << 8) | (addrBytes[3] & 0xFF); - String ip = String.format("%d.%d.%d.%d", - addrBytes[4] & 0xFF, addrBytes[5] & 0xFF, - addrBytes[6] & 0xFF, addrBytes[7] & 0xFF); - InetSocketAddress target = new InetSocketAddress(ip, port); + String[] targetParts = parseSockaddrIn(packedAddr); + if (targetParts != null) { + InetAddress targetAddress = InetAddress.getByName(targetParts[0]); + // Legacy socket code such as Net-ext reuses a + // wildcard getsockname() value as a local datagram + // destination. Route that local-only convention + // explicitly; Java channels otherwise drop it. + if (targetAddress.isAnyLocalAddress()) { + targetAddress = targetAddress instanceof java.net.Inet6Address + ? InetAddress.getByName("::1") + : InetAddress.getByName("127.0.0.1"); + } + InetSocketAddress target = new InetSocketAddress( + targetAddress, Integer.parseInt(targetParts[1])); int sent = sio.sendTo(data, target); return new RuntimeScalar(sent); } diff --git a/src/main/java/org/perlonjava/runtime/operators/SystemOperator.java b/src/main/java/org/perlonjava/runtime/operators/SystemOperator.java index 49892b4cf..4ff03918a 100644 --- a/src/main/java/org/perlonjava/runtime/operators/SystemOperator.java +++ b/src/main/java/org/perlonjava/runtime/operators/SystemOperator.java @@ -199,7 +199,7 @@ private static List splitDirectCommandWords(String command) { * Java's ProcessBuilder does not reliably perform execvp-style PATH lookup * for argv-list commands. Perl's system LIST, exec LIST, and simple qx// do. */ - private static List resolveCommandForProcessBuilder(List commandArgs) { + public static List resolveCommandForProcessBuilder(List commandArgs) { if (commandArgs.isEmpty()) { return commandArgs; } diff --git a/src/main/java/org/perlonjava/runtime/perlmodule/NetGen.java b/src/main/java/org/perlonjava/runtime/perlmodule/NetGen.java new file mode 100644 index 000000000..7197504cf --- /dev/null +++ b/src/main/java/org/perlonjava/runtime/perlmodule/NetGen.java @@ -0,0 +1,196 @@ +package org.perlonjava.runtime.perlmodule; + +import org.perlonjava.runtime.operators.ModuleOperators; +import org.perlonjava.runtime.runtimetypes.GlobalVariable; +import org.perlonjava.runtime.runtimetypes.RuntimeArray; +import org.perlonjava.runtime.runtimetypes.RuntimeList; +import org.perlonjava.runtime.runtimetypes.RuntimeScalar; + +import static org.perlonjava.runtime.runtimetypes.RuntimeContextType.LIST; + +/** + * XS compatibility for the socket constants and address helpers used by the + * historical Net-ext distribution. The socket implementation itself remains + * in PerlOnJava's core Socket module. + */ +public final class NetGen extends PerlModuleBase { + public static final String XS_VERSION = "1.011"; + + private static final String[] ERRNO_CONSTANTS = { + "EINPROGRESS", "EALREADY", "ENOTSOCK", "EDESTADDRREQ", + "EMSGSIZE", "EPROTOTYPE", "ENOPROTOOPT", "EPROTONOSUPPORT", + "ESOCKTNOSUPPORT", "EOPNOTSUPP", "EPFNOSUPPORT", "EAFNOSUPPORT", + "EADDRINUSE", "EADDRNOTAVAIL", "ENETDOWN", "ENETUNREACH", + "ENETRESET", "ECONNABORTED", "ECONNRESET", "ENOBUFS", "EISCONN", + "ENOTCONN", "ESHUTDOWN", "ETOOMANYREFS", "ETIMEDOUT", + "ECONNREFUSED", "EHOSTDOWN", "EHOSTUNREACH", "ENOSR", "ETIME", + "EBADMSG", "EPROTO", "ENODATA", "ENOSTR", "EAGAIN", + "EWOULDBLOCK", "ENOENT", "EINVAL", "EBADF" + }; + + private static final String[] SOCKET_CONSTANTS = { + "SHUT_RD", "SHUT_WR", "SHUT_RDWR", "SOL_SOCKET", "SOMAXCONN", + "MSG_OOB", + "SO_ACCEPTCONN", "SO_BROADCAST", "SO_ERROR", "SO_KEEPALIVE", + "SO_LINGER", "SO_RCVBUF", "SO_REUSEADDR", "SO_REUSEPORT", + "SO_SNDBUF", "SO_TYPE", "SOCK_STREAM", "SOCK_DGRAM", "SOCK_RAW", + "AF_UNSPEC", "AF_UNIX", "AF_INET", "PF_UNSPEC", "PF_UNIX", + "PF_INET", "IPPROTO_IP", "IPPROTO_ICMP", "IPPROTO_TCP", + "IPPROTO_UDP", "IP_TOS", "IP_TTL", "TCP_NODELAY" + }; + + private static final String[] ZERO_CONSTANTS = { + "VAL_O_NONBLOCK", "VAL_EAGAIN", "RD_NODATA", "EOF_NONBLOCK", + "SO_DEBUG", "SO_DONTROUTE", "SO_EXPANDED_RIGHTS", "SO_FAMILY", + "SO_OOBINLINE", "SO_PAIRABLE", "SO_RCVLOWAT", "SO_RCVTIMEO", + "SO_SNDLOWAT", "SO_SNDTIMEO", "SO_STATE", "SO_USELOOPBACK", + "SO_XSE", "SOCK_RDM", "SOCK_SEQPACKET", "AF_IMPLINK", "AF_PUP", + "AF_CHAOS", "AF_NS", "AF_ISO", "AF_OSI", "AF_ECMA", "AF_DATAKIT", + "AF_CCITT", "AF_SNA", "AF_DECnet", "AF_DLI", "AF_LAT", + "AF_HYLINK", "AF_APPLETALK", "AF_ROUTE", "AF_LINK", "AF_NETMAN", + "AF_X25", "AF_CTF", "AF_WAN", "AF_USER", "AF_LAST", "AF_LOCAL", + "PF_IMPLINK", "PF_PUP", "PF_CHAOS", "PF_NS", "PF_ISO", "PF_OSI", + "PF_ECMA", "PF_DATAKIT", "PF_CCITT", "PF_SNA", "PF_DECnet", + "PF_DLI", "PF_LAT", "PF_HYLINK", "PF_APPLETALK", "PF_ROUTE", + "PF_LINK", "PF_NETMAN", "PF_X25", "PF_CTF", "PF_WAN", "PF_USER", + "PF_LAST", "PF_LOCAL" + }; + + private static final String[] INET_ZERO_CONSTANTS = { + "DEFTTL", "ICMP_ADVLENMIN", "ICMP_ECHO", "ICMP_ECHOREPLY", + "ICMP_IREQ", "ICMP_IREQREPLY", "ICMP_MASKLEN", "ICMP_MASKREPLY", + "ICMP_MASKREQ", "ICMP_MAXTYPE", "ICMP_MINLEN", "ICMP_PARAMPROB", + "ICMP_REDIRECT", "ICMP_REDIRECT_HOST", "ICMP_REDIRECT_NET", + "ICMP_REDIRECT_TOSHOST", "ICMP_REDIRECT_TOSNET", + "ICMP_SOURCEQUENCH", "ICMP_TIMXCEED", "ICMP_TIMXCEED_INTRANS", + "ICMP_TIMXCEED_REASS", "ICMP_TSLEN", "ICMP_TSTAMP", + "ICMP_TSTAMPREPLY", "ICMP_UNREACH", "ICMP_UNREACH_HOST", + "ICMP_UNREACH_NEEDFRAG", "ICMP_UNREACH_NET", "ICMP_UNREACH_PORT", + "ICMP_UNREACH_PROTOCOL", "ICMP_UNREACH_SRCFAIL", "IN_CLASSA_HOST", + "IN_CLASSA_MAX", "IN_CLASSA_NET", "IN_CLASSA_NSHIFT", + "IN_CLASSA_SUBHOST", "IN_CLASSA_SUBNET", "IN_CLASSA_SUBNSHIFT", + "IN_CLASSB_HOST", "IN_CLASSB_MAX", "IN_CLASSB_NET", + "IN_CLASSB_NSHIFT", "IN_CLASSB_SUBHOST", "IN_CLASSB_SUBNET", + "IN_CLASSB_SUBNSHIFT", "IN_CLASSC_HOST", "IN_CLASSC_MAX", + "IN_CLASSC_NET", "IN_CLASSC_NSHIFT", "IN_CLASSD_HOST", + "IN_CLASSD_NET", "IN_CLASSD_NSHIFT", "IN_LOOPBACKNET", "IPFRAGTTL", + "IPOPT_CIPSO", "IPOPT_CONTROL", "IPOPT_DEBMEAS", "IPOPT_EOL", + "IPOPT_LSRR", "IPOPT_MINOFF", "IPOPT_NOP", "IPOPT_OFFSET", + "IPOPT_OLEN", "IPOPT_OPTVAL", "IPOPT_RESERVED1", "IPOPT_RESERVED2", + "IPOPT_RIPSO_AUX", "IPOPT_RR", "IPOPT_SATID", "IPOPT_SECURITY", + "IPOPT_SECUR_CONFID", "IPOPT_SECUR_EFTO", "IPOPT_SECUR_MMMM", + "IPOPT_SECUR_RESTR", "IPOPT_SECUR_SECRET", "IPOPT_SECUR_TOPSECRET", + "IPOPT_SECUR_UNCLASS", "IPOPT_SSRR", "IPOPT_TS", "IPOPT_TS_PRESPEC", + "IPOPT_TS_TSANDADDR", "IPOPT_TS_TSONLY", "IPPORT_RESERVED", + "IPPORT_TIMESERVER", "IPPORT_USERRESERVED", "IPPROTO_EGP", + "IPPROTO_EON", "IPPROTO_GGP", "IPPROTO_HELLO", "IPPROTO_IDP", + "IPPROTO_IGMP", "IPPROTO_IPIP", "IPPROTO_MAX", "IPPROTO_PUP", + "IPPROTO_RAW", "IPPROTO_RSVP", "IPPROTO_TP", "IPTOS_LOWDELAY", + "IPTOS_PREC_CRITIC_ECP", "IPTOS_PREC_FLASH", + "IPTOS_PREC_FLASHOVERRIDE", "IPTOS_PREC_IMMEDIATE", + "IPTOS_PREC_INTERNETCONTROL", "IPTOS_PREC_NETCONTROL", + "IPTOS_PREC_PRIORITY", "IPTOS_PREC_ROUTINE", "IPTOS_RELIABILITY", + "IPTOS_THROUGHPUT", "IPTTLDEC", "IPVERSION", "IP_ADD_MEMBERSHIP", + "IP_DEFAULT_MULTICAST_LOOP", "IP_DEFAULT_MULTICAST_TTL", "IP_DF", + "IP_DROP_MEMBERSHIP", "IP_HDRINCL", "IP_MAXPACKET", + "IP_MAX_MEMBERSHIPS", "IP_MF", "IP_MSS", "IP_MULTICAST_IF", + "IP_MULTICAST_LOOP", "IP_MULTICAST_TTL", "IP_OPTIONS", + "IP_RECVDSTADDR", "IP_RECVOPTS", "IP_RECVRETOPTS", "IP_RETOPTS", + "MAXTTL", "MAX_IPOPTLEN", "MINTTL", "SUBNETSHIFT", + "INADDR_ALLHOSTS_GROUP", "INADDR_ALLRTRS_GROUP", + "INADDR_MAX_LOCAL_GROUP", "INADDR_UNSPEC_GROUP" + }; + + private NetGen() { + super("Net::Gen", false); + } + + public static void initialize() { + ModuleOperators.require(new RuntimeScalar("Errno.pm")); + ModuleOperators.require(new RuntimeScalar("Socket.pm")); + + NetGen module = new NetGen(); + try { + module.registerMethod("_pack_sockaddr_in", null); + module.registerMethod("unpack_sockaddr_in", null); + module.registerMethod("pack_sockaddr", null); + module.registerMethod("unpack_sockaddr", null); + module.registerMethod("_constant_zero", ""); + module.registerMethodInPackage( + "Net::Inet", "_pack_sockaddr_in", "_pack_sockaddr_in"); + module.registerMethodInPackage( + "Net::Inet", "unpack_sockaddr_in", "unpack_sockaddr_in"); + } catch (NoSuchMethodException e) { + throw new RuntimeException(e); + } + + for (String name : ERRNO_CONSTANTS) { + alias("Errno::" + name, "Net::Gen::" + name); + } + for (String name : SOCKET_CONSTANTS) { + alias("Socket::" + name, "Net::Gen::" + name); + } + for (String name : ZERO_CONSTANTS) { + alias("Net::Gen::_constant_zero", "Net::Gen::" + name); + } + for (String name : INET_ZERO_CONSTANTS) { + alias("Net::Gen::_constant_zero", "Net::Inet::" + name); + } + for (String name : new String[]{ + "IPPROTO_IP", "IPPROTO_ICMP", "IPPROTO_TCP", "IPPROTO_UDP", + "IP_TOS", "IP_TTL", "INADDR_ANY", "INADDR_LOOPBACK", + "INADDR_BROADCAST"}) { + alias("Socket::" + name, "Net::Inet::" + name); + } + } + + private static void alias(String source, String destination) { + GlobalVariable.getGlobalCodeRef(destination) + .set(GlobalVariable.getGlobalCodeRef(source)); + } + + public static RuntimeList _constant_zero(RuntimeArray args, int ctx) { + return new RuntimeScalar(0).getList(); + } + + public static RuntimeList _pack_sockaddr_in(RuntimeArray args, int ctx) { + RuntimeArray socketArgs = new RuntimeArray(); + socketArgs.add(args.get(1)); + socketArgs.add(args.get(2)); + return Socket.pack_sockaddr_in(socketArgs, ctx); + } + + public static RuntimeList unpack_sockaddr_in(RuntimeArray args, int ctx) { + RuntimeList unpacked = Socket.unpack_sockaddr_in(args, LIST); + RuntimeList result = new RuntimeList(); + result.add(new RuntimeScalar(Socket.AF_INET)); + if (unpacked.size() >= 2) { + result.add(unpacked.elements.get(0)); + result.add(unpacked.elements.get(1)); + } + return result; + } + + public static RuntimeList pack_sockaddr(RuntimeArray args, int ctx) { + int family = args.get(0).getInt(); + String address = args.get(1).toString(); + byte[] bytes = address.getBytes(java.nio.charset.StandardCharsets.ISO_8859_1); + byte[] packed = new byte[bytes.length + 2]; + packed[0] = 0; + packed[1] = (byte) family; + System.arraycopy(bytes, 0, packed, 2, bytes.length); + return new RuntimeScalar(new String( + packed, java.nio.charset.StandardCharsets.ISO_8859_1)).getList(); + } + + public static RuntimeList unpack_sockaddr(RuntimeArray args, int ctx) { + byte[] packed = args.get(0).toString() + .getBytes(java.nio.charset.StandardCharsets.ISO_8859_1); + RuntimeList result = new RuntimeList(); + result.add(new RuntimeScalar(packed.length > 1 ? packed[1] & 0xff : 0)); + result.add(new RuntimeScalar(new String( + packed, Math.min(2, packed.length), Math.max(0, packed.length - 2), + java.nio.charset.StandardCharsets.ISO_8859_1))); + return result; + } +} diff --git a/src/main/java/org/perlonjava/runtime/perlmodule/Socket.java b/src/main/java/org/perlonjava/runtime/perlmodule/Socket.java index 33b06aade..a7aaa3a9b 100644 --- a/src/main/java/org/perlonjava/runtime/perlmodule/Socket.java +++ b/src/main/java/org/perlonjava/runtime/perlmodule/Socket.java @@ -7,6 +7,7 @@ import java.net.InetAddress; import java.net.UnknownHostException; import java.nio.charset.StandardCharsets; +import java.util.Arrays; import static org.perlonjava.runtime.runtimetypes.RuntimeScalarCache.scalarUndef; @@ -575,13 +576,21 @@ public static RuntimeList getnameinfo(RuntimeArray args, int ctx) { byte[] sockBytes = sockaddr.getBytes(StandardCharsets.ISO_8859_1); - // Extract port (bytes 2-3, big endian) + int family = ((sockBytes[0] & 0xFF) << 8) | (sockBytes[1] & 0xFF); int port = ((sockBytes[2] & 0xFF) << 8) | (sockBytes[3] & 0xFF); - // Extract IP address (bytes 4-7) - String ipAddress = String.format("%d.%d.%d.%d", - sockBytes[4] & 0xFF, sockBytes[5] & 0xFF, - sockBytes[6] & 0xFF, sockBytes[7] & 0xFF); + byte[] addressBytes; + if (family == AF_INET6 && sockBytes.length >= 24) { + addressBytes = Arrays.copyOfRange(sockBytes, 8, 24); + } else if (family == AF_INET) { + addressBytes = Arrays.copyOfRange(sockBytes, 4, 8); + } else { + RuntimeList result = new RuntimeList(); + result.add(new RuntimeScalar("Unsupported address family")); + return result; + } + InetAddress inetAddress = InetAddress.getByAddress(addressBytes); + String ipAddress = inetAddress.getHostAddress(); // Resolve hostname based on NI_NUMERICHOST flag String hostname; @@ -589,8 +598,7 @@ public static RuntimeList getnameinfo(RuntimeArray args, int ctx) { hostname = ipAddress; } else { try { - InetAddress addr = InetAddress.getByName(ipAddress); - hostname = addr.getHostName(); + hostname = inetAddress.getHostName(); } catch (Exception e) { hostname = ipAddress; // Fall back to IP if resolution fails } @@ -793,14 +801,14 @@ public static RuntimeList getaddrinfo(RuntimeArray args, int ctx) { InetAddress[] addresses; if (host == null || host.isEmpty()) { if ((hintFlags & AI_PASSIVE) != 0) { - // Passive: use wildcard addresses - addresses = new InetAddress[]{ - InetAddress.getByName("0.0.0.0") - }; + // Passive: use a wildcard matching the requested family. + addresses = hintFamily == AF_INET6 + ? new InetAddress[]{InetAddress.getByName("::")} + : new InetAddress[]{InetAddress.getByName("0.0.0.0")}; } else { - addresses = new InetAddress[]{ - InetAddress.getByName("127.0.0.1") - }; + addresses = hintFamily == AF_INET6 + ? new InetAddress[]{InetAddress.getByName("::1")} + : new InetAddress[]{InetAddress.getByName("127.0.0.1")}; } } else { addresses = InetAddress.getAllByName(host); diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeCode.java b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeCode.java index 25ae31aa7..d6e2f4bd2 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeCode.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeCode.java @@ -525,8 +525,7 @@ private static RuntimeList copyReturnedReferenceScalars(RuntimeList result, int } for (RuntimeBase value : result.elements) { if (value instanceof RuntimeScalar scalar - && !isCodeScalar(scalar) - && (RuntimeScalarType.isReference(scalar) || scalar.captureCount > 0)) { + && !isCodeScalar(scalar)) { return result.cloneScalars(); } } @@ -1091,6 +1090,25 @@ private static String autoloadVarFor(RuntimeScalar autoloadCoderef, String looku return lookupPackage + "::AUTOLOAD"; } + /** + * Preserve the byte/Unicode flag of a dynamically named method in + * $AUTOLOAD. Perl treats that flag as part of string regex semantics. + */ + private static void setAutoloadMethodName( + String variableName, String fullMethodName, RuntimeScalar methodName) { + RuntimeScalar value = new RuntimeScalar(fullMethodName); + if (methodName.type == RuntimeScalarType.BYTE_STRING) { + value.type = RuntimeScalarType.BYTE_STRING; + } + getGlobalVariable(variableName).set(value); + } + + private static String qualifyAutoloadMethodName(String methodName, String perlClassName) { + return methodName.contains("::") + ? methodName + : perlClassName + "::" + methodName; + } + public static boolean isCodeDefined(RuntimeScalar codeRef) { return codeRef != null && codeRef.type == RuntimeScalarType.CODE @@ -2860,8 +2878,10 @@ private static RuntimeList callCachedInner(int callsiteId, // where AUTOLOAD was found. Perl sets $AUTOLOAD to Child::method // even when AUTOLOAD is inherited from Base. String perlClassName = NameNormalizer.getBlessStr(blessId); - String fullMethodName = NameNormalizer.normalizeVariableName(methodName, perlClassName); - getGlobalVariable(autoloadVariableName).set(fullMethodName); + String fullMethodName = + qualifyAutoloadMethodName(methodName, perlClassName); + setAutoloadMethodName( + autoloadVariableName, fullMethodName, method); } } @@ -2910,8 +2930,10 @@ private static RuntimeList callCachedInner(int callsiteId, String autoloadVariableName = code.autoloadVariableName; if (autoloadVariableName != null && !methodName.equals("AUTOLOAD")) { // Use the original calling class, not where AUTOLOAD was found - String fullMethodName = NameNormalizer.normalizeVariableName(methodName, perlClassName); - getGlobalVariable(autoloadVariableName).set(fullMethodName); + String fullMethodName = + qualifyAutoloadMethodName(methodName, perlClassName); + setAutoloadMethodName( + autoloadVariableName, fullMethodName, method); } MortalList.pushMark(); try { @@ -3118,9 +3140,10 @@ private static RuntimeList dispatchPerlMethodAfterSelfInjected( // Extract class name from the original calling class (perlClassName), // not from the AUTOLOAD variable name. In Perl, $AUTOLOAD is set to // OriginalClass::method even when AUTOLOAD is inherited from a parent. - String fullMethodName = NameNormalizer.normalizeVariableName(methodName, perlClassName); + String fullMethodName = + qualifyAutoloadMethodName(methodName, perlClassName); // Set the $AUTOLOAD variable to the fully qualified name of the method - getGlobalVariable(autoloadVariableName).set(fullMethodName); + setAutoloadMethodName(autoloadVariableName, fullMethodName, method); } return apply(method, args, callContext); diff --git a/src/main/perl/lib/CPAN/Config.pm b/src/main/perl/lib/CPAN/Config.pm index c5e1a22f7..5235194d4 100644 --- a/src/main/perl/lib/CPAN/Config.pm +++ b/src/main/perl/lib/CPAN/Config.pm @@ -42,6 +42,7 @@ sub _bootstrap_prefs { 'IO-Async.yml' => 'PerlOnJava/CpanDistroprefs/IO-Async.yml', 'IO-Compress.yml' => 'PerlOnJava/CpanDistroprefs/IO-Compress.yml', 'IO-HTML.yml' => 'PerlOnJava/CpanDistroprefs/IO-HTML.yml', + 'IO-Socket-INET6.yml' => 'PerlOnJava/CpanDistroprefs/IO-Socket-INET6.yml', 'Image-BMP.yml' => 'PerlOnJava/CpanDistroprefs/Image-BMP.yml', 'Javascript-Menu-Full.yml' => 'PerlOnJava/CpanDistroprefs/Javascript-Menu-Full.yml', 'CGI-Widget-Tabs.yml' => 'PerlOnJava/CpanDistroprefs/CGI-Widget-Tabs.yml', @@ -56,6 +57,7 @@ sub _bootstrap_prefs { 'Carp-Assert.yml' => 'PerlOnJava/CpanDistroprefs/Carp-Assert.yml', 'Regexp-Common.yml' => 'PerlOnJava/CpanDistroprefs/Regexp-Common.yml', 'Class-Method-Modifiers.yml' => 'PerlOnJava/CpanDistroprefs/Class-Method-Modifiers.yml', + 'Class-Trait.yml' => 'PerlOnJava/CpanDistroprefs/Class-Trait.yml', 'Sub-Quote.yml' => 'PerlOnJava/CpanDistroprefs/Sub-Quote.yml', 'IPC-Run.yml' => 'PerlOnJava/CpanDistroprefs/IPC-Run.yml', 'IPC-Run3.yml' => 'PerlOnJava/CpanDistroprefs/IPC-Run3.yml', @@ -229,6 +231,8 @@ sub _bootstrap_patches { 'PerlOnJava/CpanPatches/IO-Async-0.805/PerlOnJava.patch' ], [ 'IO-Async-0.805/SkipUnsupportedSocketTests.patch', 'PerlOnJava/CpanPatches/IO-Async-0.805/SkipUnsupportedSocketTests.patch' ], + [ 'IO-Socket-INET6-2.73/SkipForkSocketTests.patch', + 'PerlOnJava/CpanPatches/IO-Socket-INET6-2.73/SkipForkSocketTests.patch' ], [ 'OpenAI-API-0.37/EventLoop.patch', 'PerlOnJava/CpanPatches/OpenAI-API-0.37/EventLoop.patch' ], [ 'OpenAI-API-0.37/NoNetworkTests.patch', @@ -273,6 +277,8 @@ sub _bootstrap_patches { 'PerlOnJava/CpanPatches/XML-FromPerl-0.01/Makefile.PL.patch' ], [ 'Class-DBI-v3.0.17/Class-DBI.pm.patch', 'PerlOnJava/CpanPatches/Class-DBI-v3.0.17/Class-DBI.pm.patch' ], + [ 'Class-Trait-0.33/SkipObsoleteModPerlWarningTest.patch', + 'PerlOnJava/CpanPatches/Class-Trait-0.33/SkipObsoleteModPerlWarningTest.patch' ], [ 'XML-TreePP-0.43/TreePP.pm.patch', 'PerlOnJava/CpanPatches/XML-TreePP-0.43/TreePP.pm.patch' ], [ 'Graph-0.9735/Graph.pm.patch', diff --git a/src/main/perl/lib/Email/Address/XS.pm b/src/main/perl/lib/Email/Address/XS.pm new file mode 100644 index 000000000..f7f52d429 --- /dev/null +++ b/src/main/perl/lib/Email/Address/XS.pm @@ -0,0 +1,174 @@ +# Copyright (c) 2015-2018 by Pali +# +# PerlOnJava compatibility implementation of the object and parsing surface +# used by Email::Sender. The CPAN distribution's parser is implemented in XS. + +package Email::Address::XS; + +use strict; +use warnings; +use Exporter 'import'; + +our $VERSION = '1.05'; +our @EXPORT_OK = qw( + parse_email_addresses parse_email_groups + format_email_addresses format_email_groups + compose_address split_address +); + +sub compose_address { + my ($user, $host) = @_; + return undef unless defined $user && defined $host; + if ($user =~ /[\s()<>\[\]:;@\\,"]/) { + $user =~ s/([\\"])/\\$1/g; + $user = qq{"$user"}; + } + return "$user\@$host"; +} + +sub split_address { + my ($address) = @_; + return (undef, undef) unless defined $address; + $address =~ s/^\s+|\s+$//g; + return (undef, undef) + unless $address =~ /\A("(?:\\.|[^"])*"|[^@]+)\@([^@]+)\z/; + my ($user, $host) = ($1, $2); + if ($user =~ /\A"(.*)"\z/s) { + $user = $1; + $user =~ s/\\(.)/$1/g; + } + $host =~ s/^\s+|\s+$//g; + return ($user, $host); +} + +sub new { + my ($class, @args) = @_; + my %args; + if (@args && @args % 2 == 0 && $args[0] =~ /\A(?:phrase|address|user|host|comment|copy)\z/) { + %args = @args; + } else { + @args{qw(phrase address comment)} = @args; + } + if (my $copy = $args{copy}) { + %args = map { $_ => $copy->{$_} } qw(phrase user host comment); + } + my $self = bless {}, $class; + @{$self}{qw(phrase comment)} = @args{qw(phrase comment)}; + if (exists $args{address}) { + $self->address($args{address}); + } else { + @{$self}{qw(user host)} = @args{qw(user host)}; + } + return $self; +} + +sub parse_email_addresses { + my ($string, $class) = @_; + $class ||= __PACKAGE__; + return () unless defined $string; + my @parts; + my ($part, $quoted, $angle) = ('', 0, 0); + for my $char (split //, $string) { + $quoted = !$quoted if $char eq '"' && $part !~ /\\\z/; + $angle++ if !$quoted && $char eq '<'; + $angle-- if !$quoted && $char eq '>'; + if (!$quoted && !$angle && $char eq ',') { + push @parts, $part; + $part = ''; + } else { + $part .= $char; + } + } + push @parts, $part if length $part; + + my @objects; + for (@parts) { + s/^\s+|\s+$//g; + next unless length; + my ($phrase, $address); + if (/\A(.*?)\s*<([^>]+)>/) { + ($phrase, $address) = ($1, $2); + $phrase =~ s/^\s+|\s+$//g; + $phrase =~ s/\A"(.*)"\z/$1/; + } else { + ($address = $_) =~ s/\s*\([^)]*\)\s*\z//; + } + push @objects, $class->new(phrase => $phrase, address => $address); + } + return @objects; +} + +sub parse_email_groups { + my ($string, $class) = @_; + return (undef, [parse_email_addresses($string, $class)]); +} + +sub parse { + my ($class, $string) = @_; + my @objects = parse_email_addresses($string, $class); + return @objects if wantarray; + return @objects ? $objects[0] : $class->new; +} + +sub parse_bare_address { + my ($class, $string) = @_; + return $class->new(address => $string); +} + +sub format_email_addresses { join ', ', map { $_->format } @_ } +sub format_email_groups { + my @args = @_; + my @groups; + while (@args) { + my ($name, $addresses) = splice @args, 0, 2; + my $formatted = format_email_addresses(@$addresses); + push @groups, defined($name) ? "$name: $formatted;" : $formatted; + } + return join ', ', @groups; +} + +sub format { + my ($self) = @_; + my $address = $self->address; + return '' unless defined $address; + my $result = $address; + if (defined $self->{phrase} && length $self->{phrase}) { + my $phrase = $self->{phrase}; + $phrase = qq{"$phrase"} if $phrase =~ /[",]/; + $result = "$phrase <$address>"; + } + $result .= " ($self->{comment})" + if defined $self->{comment} && length $self->{comment}; + return $result; +} + +sub is_valid { + my ($self) = @_; + return defined($self->{user}) && defined($self->{host}) && length($self->{host}); +} + +sub phrase { $_[0]->{phrase} = $_[1] if @_ > 1; $_[0]->{phrase} } +sub user { $_[0]->{user} = $_[1] if @_ > 1; $_[0]->{user} } +sub host { $_[0]->{host} = $_[1] if @_ > 1; $_[0]->{host} } +sub comment { $_[0]->{comment} = $_[1] if @_ > 1; $_[0]->{comment} } +sub name { + my ($self) = @_; + return $self->{phrase} if defined $self->{phrase} && length $self->{phrase}; + return $self->{comment} if defined $self->{comment} && length $self->{comment}; + return defined $self->{user} ? $self->{user} : ''; +} +sub address { + my ($self, $value) = @_; + if (@_ > 1) { + @{$self}{qw(user host)} = split_address($value); + } + return compose_address(@{$self}{qw(user host)}); +} +sub as_string { $_[0]->format } +sub original { $_[0]->{original} } +sub is_obj { ref($_[1]) && eval { $_[1]->isa(__PACKAGE__) } } +sub purge_cache { } +sub disable_cache { } +sub enable_cache { } + +1; diff --git a/src/main/perl/lib/PerlOnJava/CpanDistroprefs/Class-Trait.yml b/src/main/perl/lib/PerlOnJava/CpanDistroprefs/Class-Trait.yml new file mode 100644 index 000000000..e3aacb1ac --- /dev/null +++ b/src/main/perl/lib/PerlOnJava/CpanDistroprefs/Class-Trait.yml @@ -0,0 +1,13 @@ +--- +comment: | + PerlOnJava distroprefs for Class::Trait 0.33. + + t/070_Trait_mod_perl_test.t expects loading Class::Trait to emit no warning, + but Class::Trait 0.33 itself now deliberately emits a deprecation warning. + The assertion fails under current standard Perl as well. Skip only that + obsolete mod_perl startup assertion while retaining the other 404 functional + trait tests needed by Graph::PetriNet. +match: + distribution: "^OVID/Class-Trait-0\\.33" +patches: + - "Class-Trait-0.33/SkipObsoleteModPerlWarningTest.patch" diff --git a/src/main/perl/lib/PerlOnJava/CpanDistroprefs/Graph.yml b/src/main/perl/lib/PerlOnJava/CpanDistroprefs/Graph.yml index 8df3cf9c6..69e2a7d54 100644 --- a/src/main/perl/lib/PerlOnJava/CpanDistroprefs/Graph.yml +++ b/src/main/perl/lib/PerlOnJava/CpanDistroprefs/Graph.yml @@ -9,7 +9,7 @@ comment: | Graph::Directed and the rest of Graph's test suite exercise the same logic without depending on that fragile control-flow shape. match: - distribution: "^.*/Graph-" + distribution: "^.*/Graph-[0-9]" patches: - "Graph-0.9735/Graph.pm.patch" - "Graph-0.9735/AdjacencyMap.pm.patch" diff --git a/src/main/perl/lib/PerlOnJava/CpanDistroprefs/IO-Socket-INET6.yml b/src/main/perl/lib/PerlOnJava/CpanDistroprefs/IO-Socket-INET6.yml new file mode 100644 index 000000000..dae044b46 --- /dev/null +++ b/src/main/perl/lib/PerlOnJava/CpanDistroprefs/IO-Socket-INET6.yml @@ -0,0 +1,13 @@ +--- +comment: | + PerlOnJava distroprefs for IO::Socket::INET6 2.73. + + The distribution's blocking.t, io_sock6.t, and io_multihomed6.t tests + create local client/server pairs with fork(). PerlOnJava does not implement + POSIX fork(), so make their existing Config-based skip apply to installed + CPAN builds as well as Perl core-tree builds. All non-fork IPv6 socket tests, + including the UDP and listener tests, continue to run. +match: + distribution: "IO-Socket-INET6-2\\.73" +patches: + - "IO-Socket-INET6-2.73/SkipForkSocketTests.patch" diff --git a/src/main/perl/lib/PerlOnJava/CpanPatches/Class-Trait-0.33/SkipObsoleteModPerlWarningTest.patch b/src/main/perl/lib/PerlOnJava/CpanPatches/Class-Trait-0.33/SkipObsoleteModPerlWarningTest.patch new file mode 100644 index 000000000..a3ac68509 --- /dev/null +++ b/src/main/perl/lib/PerlOnJava/CpanPatches/Class-Trait-0.33/SkipObsoleteModPerlWarningTest.patch @@ -0,0 +1,7 @@ +--- t/070_Trait_mod_perl_test.t.orig ++++ t/070_Trait_mod_perl_test.t +@@ -6 +6,3 @@ +-use Test::More tests => 2; ++use Test::More; ++plan skip_all => ++ 'obsolete warning assertion fails with the module deprecation warning'; diff --git a/src/main/perl/lib/PerlOnJava/CpanPatches/IO-Socket-INET6-2.73/SkipForkSocketTests.patch b/src/main/perl/lib/PerlOnJava/CpanPatches/IO-Socket-INET6-2.73/SkipForkSocketTests.patch new file mode 100644 index 000000000..0afb61d8d --- /dev/null +++ b/src/main/perl/lib/PerlOnJava/CpanPatches/IO-Socket-INET6-2.73/SkipForkSocketTests.patch @@ -0,0 +1,27 @@ +--- t/blocking.t.orig ++++ t/blocking.t +@@ -9,2 +9,6 @@ + BEGIN { ++ if (! $Config{'d_fork'}) { ++ print "1..0 # Skip: no fork\n"; ++ exit 0; ++ } + if (-d "lib" && -f "TEST") { +--- t/io_sock6.t.orig ++++ t/io_sock6.t +@@ -14,2 +14,6 @@ + BEGIN { ++ if (! $Config{'d_fork'}) { ++ print "1..0 # Skip: no fork\n"; ++ exit 0; ++ } + if (-d "lib" && -f "TEST") { +--- t/io_multihomed6.t.orig ++++ t/io_multihomed6.t +@@ -15,2 +15,6 @@ + BEGIN { ++ if (! $Config{'d_fork'}) { ++ print "1..0 # SKIP no fork\n"; ++ exit 0; ++ } + if(-d "lib" && -f "TEST") { diff --git a/src/main/perl/lib/Socket6.pm b/src/main/perl/lib/Socket6.pm new file mode 100644 index 000000000..93533b3b0 --- /dev/null +++ b/src/main/perl/lib/Socket6.pm @@ -0,0 +1,88 @@ +# Copyright (C) 2000-2018 Hajimu UMEMOTO . +# Copyright (C) 1995-1999 WIDE Project. +# +# PerlOnJava compatibility implementation. Socket6's XS entry points are +# adapters around the IPv6 support already provided by the bundled Socket. + +package Socket6; + +use strict; +use warnings; +use Exporter 'import'; +use Socket (); + +our $VERSION = '0.29'; + +our @EXPORT = qw( + inet_pton inet_ntop pack_sockaddr_in6 pack_sockaddr_in6_all + unpack_sockaddr_in6 unpack_sockaddr_in6_all sockaddr_in6 + getaddrinfo getnameinfo in6addr_any in6addr_loopback + AF_INET6 PF_INET6 AI_PASSIVE AI_CANONNAME AI_NUMERICHOST AI_ADDRCONFIG + NI_NUMERICHOST NI_NUMERICSERV NI_NUMERICSERVER NI_DGRAM EAI_NONAME EAI_FAIL +); +our @EXPORT_OK = @EXPORT; +our %EXPORT_TAGS = (all => \@EXPORT); + +sub AF_INET6 () { Socket::AF_INET6() } +sub PF_INET6 () { Socket::PF_INET6() } +sub AI_PASSIVE () { Socket::AI_PASSIVE() } +sub AI_CANONNAME () { Socket::AI_CANONNAME() } +sub AI_NUMERICHOST() { Socket::AI_NUMERICHOST() } +sub AI_ADDRCONFIG () { Socket::AI_ADDRCONFIG() } +sub NI_NUMERICHOST() { Socket::NI_NUMERICHOST() } +sub NI_NUMERICSERV() { Socket::NI_NUMERICSERV() } +sub NI_NUMERICSERVER() { Socket::NI_NUMERICSERV() } +sub NI_DGRAM () { Socket::NI_DGRAM() } +sub EAI_NONAME () { Socket::EAI_NONAME() } +sub EAI_FAIL () { Socket::EAI_FAIL() } + +sub inet_pton { Socket::inet_pton(@_) } +sub inet_ntop { Socket::inet_ntop(@_) } +sub pack_sockaddr_in6 { Socket::pack_sockaddr_in6(@_) } +sub unpack_sockaddr_in6 { + my ($port, $addr) = Socket::unpack_sockaddr_in6(@_); + return wantarray ? ($port, $addr) : $port; +} +sub pack_sockaddr_in6_all { + my ($port, $flowinfo, $addr, $scope_id) = @_; + return Socket::pack_sockaddr_in6($port, $addr, $scope_id, $flowinfo); +} +sub unpack_sockaddr_in6_all { + my ($port, $addr, $scope_id, $flowinfo) = + Socket::unpack_sockaddr_in6(@_); + return ($port, $flowinfo, $addr, $scope_id); +} +sub sockaddr_in6 { + return @_ == 1 ? unpack_sockaddr_in6(@_) : pack_sockaddr_in6(@_); +} +sub in6addr_any { Socket::IN6ADDR_ANY() } +sub in6addr_loopback { Socket::IN6ADDR_LOOPBACK() } + +# Socket6 predates core Socket's hash-based getaddrinfo API. Preserve its +# flat five-value records while delegating resolution to the Java runtime. +sub getaddrinfo { + my ($node, $service, $family, $socktype, $protocol, $flags) = @_; + my ($error, @records) = Socket::getaddrinfo( + $node, + $service, + { + family => $family || 0, + socktype => $socktype || 0, + protocol => $protocol || 0, + flags => $flags || 0, + }, + ); + return $error if $error; + my @result; + for my $record (@records) { + push @result, @{$record}{qw(family socktype protocol addr canonname)}; + } + return @result; +} + +sub getnameinfo { + my ($error, $host, $service) = Socket::getnameinfo(@_); + return $error ? $error : ($host, $service); +} + +1; diff --git a/src/main/perl/lib/Want.pm b/src/main/perl/lib/Want.pm new file mode 100644 index 000000000..5e9058c71 --- /dev/null +++ b/src/main/perl/lib/Want.pm @@ -0,0 +1,37 @@ +# Copyright (c) 2001-2014 Robin Houston. +# +# PerlOnJava compatibility subset. The original Want distribution uses XS +# op-tree inspection. These predicates cover the non-lvalue call patterns +# used by JSONP without pretending to provide full Want parity. + +package Want; + +use strict; +use warnings; +use Exporter 'import'; + +our $VERSION = '0.29'; +our @EXPORT = qw(want rreturn lnoreturn wantref want_ref); + +sub want { + my ($kind) = @_; + return !defined wantarray if $kind eq 'VOID'; + return defined(wantarray) && wantarray if $kind eq 'LIST'; + return defined(wantarray) && !wantarray if $kind eq 'SCALAR'; + + # PerlOnJava currently has no runtime op tree. Method chaining is the + # useful OBJECT case supported by this compatibility layer. RVALUE is + # the safe default outside lvalue calls; BOOL remains conservative. + return 1 if $kind eq 'OBJECT'; + return 1 if $kind eq 'RVALUE'; + return 0 if $kind eq 'BOOL'; + return 0 if $kind eq 'LVALUE' || $kind eq 'ASSIGN'; + return 0; +} + +sub rreturn { return wantarray ? @_ : $_[-1] } +sub lnoreturn { return } +sub wantref { return '' } +sub want_ref { return wantref() } + +1; diff --git a/src/test/resources/module/Email-Address-XS/t/basic.t b/src/test/resources/module/Email-Address-XS/t/basic.t new file mode 100644 index 000000000..db36df28f --- /dev/null +++ b/src/test/resources/module/Email-Address-XS/t/basic.t @@ -0,0 +1,12 @@ +use strict; +use warnings; +use Test::More tests => 5; +use Email::Address::XS qw(parse_email_addresses compose_address split_address); + +my ($user, $host) = split_address('alice@example.test'); +is($user, 'alice', 'split local part'); +is($host, 'example.test', 'split host'); +is(compose_address($user, $host), 'alice@example.test', 'compose address'); +my ($address) = parse_email_addresses('Alice '); +is($address->address, 'alice@example.test', 'parse address object'); +is($address->name, 'Alice', 'parse display name'); diff --git a/src/test/resources/module/Socket6/t/basic.t b/src/test/resources/module/Socket6/t/basic.t new file mode 100644 index 000000000..bf76dd67c --- /dev/null +++ b/src/test/resources/module/Socket6/t/basic.t @@ -0,0 +1,14 @@ +use strict; +use warnings; +use Test::More tests => 6; +use Socket6 qw(AF_INET6 NI_NUMERICSERV NI_NUMERICSERVER inet_pton inet_ntop pack_sockaddr_in6_all unpack_sockaddr_in6_all); + +my $packed = inet_pton(AF_INET6, '::1'); +is(length($packed), 16, 'IPv6 presentation converts to 16 octets'); +is(inet_ntop(AF_INET6, $packed), '::1', 'IPv6 octets convert back'); +my $sockaddr = pack_sockaddr_in6_all(4242, 7, $packed, 3); +my ($port, $flow, $addr, $scope) = unpack_sockaddr_in6_all($sockaddr); +is($port, 4242, 'port round trips'); +is($flow, 7, 'flow info round trips'); +is($scope, 3, 'scope id round trips'); +is(NI_NUMERICSERVER, NI_NUMERICSERV, 'historical numeric-service alias is exported'); diff --git a/src/test/resources/unit/autoload_byte_method_name.t b/src/test/resources/unit/autoload_byte_method_name.t new file mode 100644 index 000000000..66584beb5 --- /dev/null +++ b/src/test/resources/unit/autoload_byte_method_name.t @@ -0,0 +1,22 @@ +use strict; +use warnings; +use Test::More tests => 3; + +{ + package ByteAutoload; + our $AUTOLOAD; + sub AUTOLOAD { + return if $AUTOLOAD =~ /::DESTROY\z/; + my $class = ref $_[0]; + my $valid = q{[^:'[:cntrl:]]{0,1024}}; + return $AUTOLOAD =~ /^${class}::($valid)$/ ? $1 : undef; + } +} + +my $object = bless {}, 'ByteAutoload'; +my $method = '§ߨ~ nobody+5@nowhere.net 䕨 has 64K €'; +is($object->$method, $method, 'AUTOLOAD preserves byte method name'); +is(unpack('H*', $object->$method), unpack('H*', $method), + 'AUTOLOAD preserves exact method-name octets'); +is($object->${\100}, '100', + 'AUTOLOAD qualifies a numeric dynamic method with the invocant class'); diff --git a/src/test/resources/unit/core_dump_guarded.t b/src/test/resources/unit/core_dump_guarded.t new file mode 100644 index 000000000..c1f48c703 --- /dev/null +++ b/src/test/resources/unit/core_dump_guarded.t @@ -0,0 +1,6 @@ +use strict; +use warnings; +use Test::More tests => 1; + +CORE::dump if 0; +pass('guarded obsolete CORE::dump compiles'); diff --git a/src/test/resources/unit/glob_slot_hash_deref.t b/src/test/resources/unit/glob_slot_hash_deref.t new file mode 100644 index 000000000..93d42710c --- /dev/null +++ b/src/test/resources/unit/glob_slot_hash_deref.t @@ -0,0 +1,31 @@ +use strict; +use warnings; +use lib 'src/test/resources/unit/lib'; +use Test::More tests => 6; +use Symbol qw(gensym); +use GlobSlotRegistry; + +my $glob = gensym(); +$ {*$glob}{Keys} = {alpha => 1, beta => 2}; +my %copy = %{ $ {*$glob}{Keys} }; + +is($copy{alpha}, 1, 'glob scalar slot can hold a hash reference'); +is_deeply(\%copy, {alpha => 1, beta => 2}, + 'nested glob-slot hash dereference preserves contents'); + +my @names = qw(PF AF type); +@{$ {*$glob}{Keys}}{@names} = @{$ {*$glob}{Keys}}{@names}; + +ok(exists $ {*$glob}{Keys}{PF}, + 'hash slice assignment through a glob scalar slot creates keys'); +is(scalar(keys %{$ {*$glob}{Keys}}), 5, + 'glob-slot hash slice assignment preserves and extends contents'); + +my $registry = GlobSlotRegistry->new; +$registry->register_handlers({debug => sub { 1 }, timeout => sub { 1 }}); +is_deeply([$registry->registered_keys], [qw(debug timeout)], + 'glob-slot slice assignment works in a required module'); + +my $handler_name = 'debug'; +is(&{$ {*$registry}{Keys}{$handler_name}}(), 1, + 'code dereference accepts a nested glob-slot hash element'); diff --git a/src/test/resources/unit/inherited_autoload_stub.t b/src/test/resources/unit/inherited_autoload_stub.t new file mode 100644 index 000000000..0ce9ad3e5 --- /dev/null +++ b/src/test/resources/unit/inherited_autoload_stub.t @@ -0,0 +1,12 @@ +use strict; +use warnings; +use Test::More tests => 1; +use lib 'src/test/resources/unit/lib'; +use InheritedAutoLoaderChild; + +my $object = bless {}, 'InheritedAutoLoaderChild'; +is( + $object->from_parent, + 'loaded from parent', + 'an inherited AutoSplit stub wins over a child AUTOLOAD', +); diff --git a/src/test/resources/unit/lib/GlobSlotRegistry.pm b/src/test/resources/unit/lib/GlobSlotRegistry.pm new file mode 100644 index 000000000..3b827e8fd --- /dev/null +++ b/src/test/resources/unit/lib/GlobSlotRegistry.pm @@ -0,0 +1,33 @@ +package GlobSlotRegistry; + +use strict; +use warnings; +use Symbol qw(gensym); + +sub new { + my ($class) = @_; + my $self = gensym(); + bless $self, $class; + $ {*$self}{Keys} = {}; + return $self; +} + +sub register_handlers { + my ($self, $names, @handlers, $handlers) = @_; + if (ref $names eq 'HASH') { + $handlers = [values %$names]; + $names = [keys %$names]; + } + else { + $handlers = \@handlers; + $handlers = $_[2] if @_ == 3 && ref($_[2]) eq 'ARRAY'; + } + @{$ {*$self}{Keys}}{@$names} = @$handlers; +} + +sub registered_keys { + my ($self) = @_; + return sort keys %{$ {*$self}{Keys}}; +} + +1; diff --git a/src/test/resources/unit/lib/InheritedAutoLoaderChild.pm b/src/test/resources/unit/lib/InheritedAutoLoaderChild.pm new file mode 100644 index 000000000..41629f945 --- /dev/null +++ b/src/test/resources/unit/lib/InheritedAutoLoaderChild.pm @@ -0,0 +1,15 @@ +package InheritedAutoLoaderChild; + +use strict; +use warnings; +use InheritedAutoLoaderParent; + +our @ISA = ('InheritedAutoLoaderParent'); +our $AUTOLOAD; + +sub AUTOLOAD { + return if $AUTOLOAD =~ /::DESTROY\z/; + die "child AUTOLOAD incorrectly selected for $AUTOLOAD"; +} + +1; diff --git a/src/test/resources/unit/lib/InheritedAutoLoaderParent.pm b/src/test/resources/unit/lib/InheritedAutoLoaderParent.pm new file mode 100644 index 000000000..5b863aa7d --- /dev/null +++ b/src/test/resources/unit/lib/InheritedAutoLoaderParent.pm @@ -0,0 +1,7 @@ +package InheritedAutoLoaderParent; + +use strict; +use warnings; +use AutoLoader 'AUTOLOAD'; + +1; diff --git a/src/test/resources/unit/lib/auto/InheritedAutoLoaderParent/autosplit.ix b/src/test/resources/unit/lib/auto/InheritedAutoLoaderParent/autosplit.ix new file mode 100644 index 000000000..7247858ad --- /dev/null +++ b/src/test/resources/unit/lib/auto/InheritedAutoLoaderParent/autosplit.ix @@ -0,0 +1,4 @@ +# Index created by AutoSplit for InheritedAutoLoaderParent.pm +package InheritedAutoLoaderParent; +sub from_parent; +1; diff --git a/src/test/resources/unit/lib/auto/InheritedAutoLoaderParent/from_parent.al b/src/test/resources/unit/lib/auto/InheritedAutoLoaderParent/from_parent.al new file mode 100644 index 000000000..b2ae9ebfb --- /dev/null +++ b/src/test/resources/unit/lib/auto/InheritedAutoLoaderParent/from_parent.al @@ -0,0 +1,7 @@ +package InheritedAutoLoaderParent; + +sub from_parent { + return 'loaded from parent'; +} + +1; diff --git a/src/test/resources/unit/pipe_jperl_shebang.t b/src/test/resources/unit/pipe_jperl_shebang.t new file mode 100644 index 000000000..8ee898e14 --- /dev/null +++ b/src/test/resources/unit/pipe_jperl_shebang.t @@ -0,0 +1,28 @@ +use strict; +use warnings; +use Test::More tests => 3; +use File::Spec; + +my $script = File::Spec->catfile( + File::Spec->tmpdir, + "perlonjava-pipe-shebang-$$.pl", +); +my $output = "$script.out"; + +open my $source, '>', $script or die "open $script: $!"; +print {$source} "#!$^X\n"; +print {$source} "use strict;\n"; +print {$source} 'my $out = shift; open my $fh, q{>}, $out or die $!; '; +print {$source} 'print {$fh} join q{}, ; close $fh;' . "\n"; +close $source; +chmod 0755, $script; + +open my $pipe, "| $script $output" or die "pipe $script: $!"; +print {$pipe} "through jperl shebang\n"; +ok(close($pipe), 'output pipe closes successfully'); + +open my $result, '<', $output or die "open $output: $!"; +is(join('', <$result>), "through jperl shebang\n", 'script receives pipe input'); +close $result; + +ok(unlink($script, $output), 'temporary files removed'); diff --git a/src/test/resources/unit/socket_getaddrinfo_ipv6.t b/src/test/resources/unit/socket_getaddrinfo_ipv6.t new file mode 100644 index 000000000..97aafd819 --- /dev/null +++ b/src/test/resources/unit/socket_getaddrinfo_ipv6.t @@ -0,0 +1,39 @@ +use strict; +use warnings; +use Test::More tests => 9; +use Socket qw( + AF_INET6 SOCK_STREAM AI_PASSIVE getaddrinfo inet_pton + pack_sockaddr_in6 unpack_sockaddr_in6 getnameinfo + NI_NUMERICHOST NI_NUMERICSERV +); + +my ($error, @records) = getaddrinfo( + undef, + 0, + { + family => AF_INET6, + socktype => SOCK_STREAM, + flags => AI_PASSIVE, + }, +); + +is($error, '', 'passive IPv6 lookup succeeds'); +ok(@records, 'passive IPv6 lookup returns a record'); +is($records[0]{family}, AF_INET6, 'record has requested IPv6 family'); +ok(length($records[0]{addr}) >= 24, 'record contains an IPv6 sockaddr'); + +ok(socket(my $socket, AF_INET6, SOCK_STREAM, 0), + 'socket accepts the platform IPv6 address-family constant'); +ok(bind($socket, pack_sockaddr_in6(0, inet_pton(AF_INET6, '::1'))), + 'bind accepts a packed IPv6 socket address'); +ok(listen($socket, 1), 'IPv6 stream socket can listen after binding'); +my ($bound_port, $bound_address) = unpack_sockaddr_in6(getsockname($socket)); +ok($bound_port > 0 && length($bound_address) == 16, + 'getsockname returns a packed IPv6 socket address'); +my ($name_error, $numeric_host, $numeric_service) = getnameinfo( + getsockname($socket), NI_NUMERICHOST | NI_NUMERICSERV, +); +is_deeply([$name_error, $numeric_host, $numeric_service], + ['', '::1', "$bound_port"], + 'getnameinfo decodes a packed IPv6 socket address'); +close $socket; diff --git a/src/test/resources/unit/source_utf8_octets.t b/src/test/resources/unit/source_utf8_octets.t new file mode 100644 index 000000000..33ef1dbf9 --- /dev/null +++ b/src/test/resources/unit/source_utf8_octets.t @@ -0,0 +1,19 @@ +use strict; +use warnings; + +use Test::More tests => 2; + +my $path = 'dir'; +my $message = "Failed to change directory to “$path”: permission denied"; + +is( + length($message), + 58, + 'valid UTF-8 bytes are accepted in an interpolated source string without use utf8', +); + +is( + unpack('H*', substr($message, 30, 3)), + 'e2809c', + 'source text without use utf8 preserves UTF-8 as octets', +); diff --git a/src/test/resources/unit/subroutine_return_rvalue.t b/src/test/resources/unit/subroutine_return_rvalue.t new file mode 100644 index 000000000..07f429940 --- /dev/null +++ b/src/test/resources/unit/subroutine_return_rvalue.t @@ -0,0 +1,59 @@ +use strict; +use warnings; + +use Test::More tests => 5; + +our $shared; + +sub global_key { + $shared = shift; + return $shared; +} + +isnt( + global_key('left'), + global_key('right'), + 'ordinary subroutine returns copy a reused global scalar slot', +); + +{ + my $slot; + sub lexical_key { + $slot = shift; + return $slot; + } +} + +isnt( + lexical_key('first'), + lexical_key('second'), + 'ordinary subroutine returns copy a captured lexical scalar slot', +); + +my $object = bless {}, 'ReturnRvalueObject'; +sub return_object { return $object } + +is( + return_object(), + $object, + 'copying a returned scalar preserves its referent', +); + +sub depth_first { + my ($node) = @_; + return ($node, map { depth_first($_) } @$node); +} + +my $tree = [[[], []], []]; +my @depth_first = depth_first($tree); +is( + scalar(@depth_first), + 5, + 'recursive map returns the complete list in list context', +); + +is( + scalar(depth_first($tree)), + 4, + 'recursive map returns its generated element count in scalar context', +);