diff --git a/dev/design/JCPAN_DATETIME_FIXES.md b/dev/design/JCPAN_DATETIME_FIXES.md new file mode 100644 index 000000000..6666ac61f --- /dev/null +++ b/dev/design/JCPAN_DATETIME_FIXES.md @@ -0,0 +1,311 @@ +# jcpan DateTime Fix Plan + +## Overview + +This document tracks all errors and warnings that occur when running `jcpan install DateTime` with a clean cache, and the plan to fix them. + +## Error Categories + +### 1. CRITICAL: DateTime::Locale Installation Fails + +**Root Cause**: `File::stat.pm` is missing + +``` +Can't locate File/stat.pm in @INC at /Users/fglock/.perlonjava/lib/File/ShareDir/Install.pm line 11 +``` + +**Impact**: DateTime::Locale cannot be configured, which means DateTime tests fail with: +``` +Can't locate DateTime/Locale.pm in @INC +``` + +**Solution**: Implement `File::stat.pm` - a stub or full implementation + +**Priority**: HIGH + +--- + +### 2. IPC::Open3 Read-Only Modification Error + +**Error**: +``` +open3: Modification of a read-only value attempted + at IPCOpen3.java line 162 +``` + +**Impact**: Many module tests fail in `t/00-compile.t` type tests that use open3 to test module compilation + +**Solution**: Fix IPCOpen3.java line 162 to handle read-only values + +**Priority**: MEDIUM + +--- + +### 3. Missing Core Modules + +| Module | Used By | Priority | +|--------|---------|----------| +| File::stat | File::ShareDir::Install | HIGH | +| IO::Select | Various | MEDIUM | +| PerlIO::encoding | Encode tests | LOW | +| encoding.pm | Encode | LOW | + +--- + +### 4. Encode Module Issues + +**Errors**: +``` +Can't locate object method "decode" via package "ISO-8859-1" +Can't locate object method "encode" via package "UTF-8" +Can't locate object method "encodings" via package "Encode" +Undefined subroutine &Encode::define_encoding called +``` + +**Root Cause**: Encode is an XS module; PerlOnJava has a Java implementation but some methods are missing + +**Solution**: Add missing methods to Encode.java: +- `encodings()` +- Ensure `decode`/`encode` work with encoding names as package names + +**Priority**: MEDIUM + +--- + +### 5. Version Format Errors + +**Error**: +``` +Invalid version format (version required) at Version.java line 334 +``` + +**Solution**: Handle edge cases in Version.java + +**Priority**: LOW + +--- + +### 6. CPAN::Meta::Requirements Warning + +**Error**: +``` +Use of uninitialized value in numeric gt (>) at jar:PERL5LIB/CPAN/Meta/Requirements.pm line 215 +``` + +**Solution**: Check for undef before numeric comparison + +**Priority**: LOW + +--- + +### 7. Test::Builder Overload Issue + +**Error**: +``` +Undefined subroutine &*version::("" called at jar:PERL5LIB/Test/Builder.pm line 771 +``` + +**Solution**: Fix overload handling for version objects + +**Priority**: LOW + +--- + +### 8. Exporter require_version Missing [FIXED] + +**Error**: +``` +Can't locate object method "require_version" via package "Testing" +``` + +**Solution**: Added `require_version` method to Java `Exporter.java` which delegates to `UNIVERSAL::VERSION` + +**Files changed**: +- `src/main/java/org/perlonjava/runtime/perlmodule/Exporter.java` + +**Priority**: MEDIUM - **FIXED** (commit 70ce06938) + +--- + +### 9. Too Many Arguments for like() + +**Error**: +``` +Too many arguments for main::like at t/conflicts.t line 109 +``` + +**Root Cause**: Test::More's `like()` has different prototype handling + +**Priority**: LOW (cosmetic test failure) + +--- + +### 10. Carp.pm Bareword Error with CORE::GLOBAL::require [FIXED] + +**Error**: +``` +Bareword "Exporter" not allowed while "strict subs" in use at jar:PERL5LIB/Carp.pm line 224 +``` + +**Root Cause**: When `CORE::GLOBAL::require` is overridden and a module uses `require Bareword;` under strict subs, the bareword was parsed as an expression instead of using require's special bareword-to-filename conversion. + +**Solution**: Added special handling in `ParsePrimary.java` for `require` when `CORE::GLOBAL::require` is overridden: +1. Parse the argument using standard require handling (converts bareword to filename string) +2. Build a subroutine call node with `&CORE::GLOBAL::require(...)` form + +**Files changed**: +- `src/main/java/org/perlonjava/frontend/parser/ParsePrimary.java` + +**Priority**: MEDIUM - **FIXED** (commit 70ce06938) + +--- + +### 11. JVM VerifyError: Inconsistent Stackmap Frames [FIXED] + +**Error**: +``` +java.lang.VerifyError: Inconsistent stackmap frames at branch target 518 +Exception Details: + Location: + org/perlonjava/anon195.apply(...) @507: goto + Reason: + Current frame's stack size doesn't match stackmap. +``` + +**Triggered by**: perl5's `File/stat.pm` (imported via sync.pl) + +**Minimal Reproducer**: +```perl +no strict "refs"; +my $result = defined eval { &{"Fcntl::S_IFX"} }; +``` + +The issue requires BOTH of these: +1. `no strict "refs"` in scope (enables symbolic subroutine calls) +2. `defined eval { &{"symbolic_ref"} }` (eval-wrapped symbolic sub call with defined check) + +**Works** (any element missing): +- `eval { &{"..."} }` without `defined` - OK +- `defined eval { die "x" }` - OK (no symbolic ref call) +- `defined eval { Func() }` - OK (direct call, not symbolic) +- With `use strict "refs"` - OK (throws error at compile time) + +**Root Cause Analysis**: The bytecode generator in `EmitVariable.java` creates inconsistent stack states when handling control flow markers from subroutine calls inside eval blocks. + +When `&{"symbolic_ref"}` is called: +1. `RuntimeCode.apply()` may return a `RuntimeControlFlowList` marker (LAST/NEXT/REDO) +2. The code checks `isNonLocalGoto()` and branches to handle the marker +3. For unlabeled LAST/NEXT, the original code jumped directly to loop labels with an **empty stack** +4. But the `applyNoControlFlow` merge point expects a **RuntimeList on the stack** (from DUP or cfSlot load) +5. JVM frame computation fails because paths arriving at merge point have different stack states + +**Specific bytecode issue** (from disassembly before fix): +``` +L9 checkUnlabeled + ILOAD 29; ICONST_0; IF_ICMPEQ L11 // LAST? + ILOAD 29; ICONST_1; IF_ICMPEQ L12 // NEXT? + ILOAD 29; ICONST_2; IF_ICMPEQ L13 // REDO? + GOTO L8 +L11 GOTO L7 // LAST: empty stack, jumps to L7 +L12 GOTO L7 // NEXT: empty stack, jumps to L7 +L13 GOTO L6 // REDO: OK, goes to redo label +L8 ALOAD 27 // Load cfSlot, falls through to L7 +L7 FRAME [...] [RuntimeList] // Expects value on stack! + ASTORE 25 +``` + +**Fix** (commit 280d03af2): Push the control flow marker (from cfSlot) onto the stack before jumping to the merge point: +```java +mv.visitLabel(isLast); +mv.visitVarInsn(Opcodes.ALOAD, cfSlot); // Push marker +mv.visitJumpInsn(Opcodes.GOTO, applyNoControlFlow); + +mv.visitLabel(isNext); +mv.visitVarInsn(Opcodes.ALOAD, cfSlot); // Push marker +mv.visitJumpInsn(Opcodes.GOTO, applyNoControlFlow); +``` + +**Files changed**: +- `src/main/java/org/perlonjava/backend/jvm/EmitVariable.java` lines 710-721 + +**Impact**: File::stat.pm and other modules using `eval { &{...} }` pattern now load correctly. + +**Priority**: HIGH (blocks File::stat and potentially other complex modules) - **FIXED** + +--- + +## Implementation Plan + +### Phase 1: Critical (enables DateTime to install) + +1. **Fix JVM VerifyError for complex control flow** (Issue #11) + - Debug why File::stat.pm causes stackmap frame inconsistency + - Create minimal reproduction case + - Fix bytecode emitter + - Files: `EmitterMethodCreator.java`, `EmitterVisitor.java`, `EmitControlFlow.java` + +2. **Implement File::stat.pm stub** (if JVM fix takes too long) + - Create `src/main/perl/lib/File/stat.pm` + - Implement basic stat() wrapper returning object with standard fields + - File: `src/main/perl/lib/File/stat.pm` + +### Phase 2: High Priority (reduces test failures) + +2. **Fix IPC::Open3 read-only error** + - File: `src/main/java/org/perlonjava/runtime/perlmodule/IPCOpen3.java` + - Line 162: clone value before modification + +3. **Add Encode::encodings() method** + - File: `src/main/java/org/perlonjava/runtime/perlmodule/Encode.java` + +4. **Implement require_version in UNIVERSAL** + - File: `src/main/java/org/perlonjava/runtime/perlmodule/Universal.java` + +### Phase 3: Medium Priority + +5. **Fix Version.java edge cases** +6. **Fix CPAN::Meta::Requirements undef check** +7. **Implement IO::Select stub** + +### Phase 4: Low Priority (polish) + +8. **Fix Test::Builder overload handling** +9. **Fix Carp.pm bareword issue** +10. **Fix like() prototype handling** + +--- + +## Progress Tracking + +### Completed +- [x] Phase 16: utf8::valid() fix for CPAN::Meta parsing (2026-03-20) +- [x] ExtUtils::MakeMaker MYMETA.yml meta-spec v2 format (2026-03-20) +- [x] Added File::stat.pm via import system (2026-03-20) - but triggers JVM bug +- [x] JVM VerifyError fix for eval block control flow (2026-03-20, commit 280d03af2) +- [x] Add missing S_* mode constants to Fcntl.pm (2026-03-20, commit 94974ba79) + - File::stat.pm now loads successfully +- [x] Exporter::require_version() implementation (2026-03-20, commit 70ce06938) +- [x] CORE::GLOBAL::require bareword handling fix (2026-03-20, commit 70ce06938) +- [x] Exporter version check in import (2026-03-21, commit a2e0aa131) + - First argument starting with digit is now treated as version check + - Fixes: "Symbol 0.03 not allowed for export in package File::ShareDir::Install" +- [x] MakeMaker $(INST_LIB) variable expansion (2026-03-21, commit f42f9125c) + - Fixes modules with explicit PM hash using Make-style variables + +### In Progress +- None + +### All fixes complete! +- `jcpan install DateTime` works successfully +- DateTime module loads and functions correctly: + ``` + ./jperl -e 'use DateTime; print DateTime->now->strftime("%Y-%m-%d")' + 2026-03-21 + ``` + +--- + +## Related Documents + +- `dev/design/cpan_client.md` - Main CPAN client documentation +- `dev/design/xsloader.md` - XSLoader implementation diff --git a/dev/design/cpan_client.md b/dev/design/cpan_client.md index d4f9d1100..f3f5bb8fa 100644 --- a/dev/design/cpan_client.md +++ b/dev/design/cpan_client.md @@ -355,6 +355,58 @@ All major DateTime issues have been fixed. The 7 remaining test failures are: --- +## Phase 16: utf8::valid() Fix for CPAN::Meta Parsing (2026-03-20) + +### Problem Statement + +When installing DateTime with empty caches, CPAN::Meta::YAML parsing would fail with: +``` +Read an invalid UTF-8 string (maybe mixed UTF-8 and 8-bit character set). +Did you decode with lax ":utf8" instead of strict ":encoding(UTF-8)"? +``` + +This error prevented proper parsing of META.yml/MYMETA.yml files, which meant test dependencies like Test::Without::Module and CPAN::Meta::Check were not being properly detected. + +### Root Cause + +CPAN::Meta::YAML validates strings before parsing: +```perl +if ( utf8::is_utf8($string) && ! utf8::valid($string) ) { + die "Read an invalid UTF-8 string..."; +} +``` + +The `utf8::valid()` function in PerlOnJava was using `CharsetDetector` which was fundamentally wrong: +- It converted the string to bytes using the default charset +- Then tried to detect if those bytes were UTF-8 +- This always failed for properly decoded Unicode strings + +### Solution + +Rewrote `utf8::valid()` in `Utf8.java` to correctly check string validity: +- **For character strings (UTF-8 flag on)**: Validates that surrogate pairs are properly formed +- **For byte strings (UTF-8 flag off)**: Attempts to decode bytes as UTF-8 + +### Files Changed + +- `src/main/java/org/perlonjava/runtime/perlmodule/Utf8.java` - Fixed `valid()` method + +### Test Results + +The fix allows CPAN::Meta::YAML to properly parse MYMETA.yml files, enabling CPAN.pm to detect and install test dependencies. + +--- + +## Known Remaining CPAN Issues + +| Issue | Status | Impact | +|-------|--------|--------| +| File::stat.pm missing | Not implemented | DateTime::Locale installation fails | +| IPC::Open3 read-only error | Bug in IPCOpen3.java | Some module tests fail | +| Test::Harness UTF-8 error | Pre-existing | Some test output parsing fails | + +--- + ## Related Documents - `dev/design/xsloader.md` - XSLoader/Java integration diff --git a/dev/import-perl5/config.yaml b/dev/import-perl5/config.yaml index bd473e18f..318ae3233 100644 --- a/dev/import-perl5/config.yaml +++ b/dev/import-perl5/config.yaml @@ -172,6 +172,10 @@ imports: - source: perl5/lib/File/Compare.pm target: src/main/perl/lib/File/Compare.pm + # File::stat - by-name interface to stat() (required by IO::Dir) + - source: perl5/lib/File/stat.pm + target: src/main/perl/lib/File/stat.pm + # From core library - source: perl5/lib/Tie/Array.pm target: src/main/perl/lib/Tie/Array.pm @@ -620,6 +624,11 @@ imports: - source: perl5/cpan/Term-ANSIColor/lib/Term/ANSIColor.pm target: src/main/perl/lib/Term/ANSIColor.pm + # Class::Struct - Declare struct-like datatypes as Perl classes + # Required by File::stat.pm + - source: perl5/lib/Class/Struct.pm + target: src/main/perl/lib/Class/Struct.pm + # Add more imports below as needed # Example with minimal fields: # - source: perl5/lib/SomeModule.pm diff --git a/src/main/java/org/perlonjava/backend/jvm/EmitVariable.java b/src/main/java/org/perlonjava/backend/jvm/EmitVariable.java index 37071b539..bb4b6281b 100644 --- a/src/main/java/org/perlonjava/backend/jvm/EmitVariable.java +++ b/src/main/java/org/perlonjava/backend/jvm/EmitVariable.java @@ -707,11 +707,15 @@ static void handleVariableOperator(EmitterVisitor emitterVisitor, OperatorNode n mv.visitJumpInsn(Opcodes.IF_ICMPEQ, isRedo); mv.visitJumpInsn(Opcodes.GOTO, applyNotNextLastRedo); + // Push a value before GOTO to match expected stack state at merge point. + // The applyNoControlFlow merge point expects a value on the stack. mv.visitLabel(isLast); - mv.visitJumpInsn(Opcodes.GOTO, unlabeledTarget.lastLabel); + mv.visitVarInsn(Opcodes.ALOAD, cfSlot); + mv.visitJumpInsn(Opcodes.GOTO, applyNoControlFlow); mv.visitLabel(isNext); - mv.visitJumpInsn(Opcodes.GOTO, unlabeledTarget.nextLabel); + mv.visitVarInsn(Opcodes.ALOAD, cfSlot); + mv.visitJumpInsn(Opcodes.GOTO, applyNoControlFlow); mv.visitLabel(isRedo); mv.visitJumpInsn(Opcodes.GOTO, unlabeledTarget.redoLabel); diff --git a/src/main/java/org/perlonjava/core/Configuration.java b/src/main/java/org/perlonjava/core/Configuration.java index 2bb71a46c..957fe3691 100644 --- a/src/main/java/org/perlonjava/core/Configuration.java +++ b/src/main/java/org/perlonjava/core/Configuration.java @@ -33,14 +33,14 @@ public final class Configuration { * Automatically populated by Gradle/Maven during build. * DO NOT EDIT MANUALLY - this value is replaced at build time. */ - public static final String gitCommitId = "d493a1ec3"; + public static final String gitCommitId = "3f00c2f24"; /** * Git commit date of the build (ISO format: YYYY-MM-DD). * Automatically populated by Gradle/Maven during build. * DO NOT EDIT MANUALLY - this value is replaced at build time. */ - public static final String gitCommitDate = "2026-03-20"; + public static final String gitCommitDate = "2026-03-21"; // Prevent instantiation private Configuration() { diff --git a/src/main/java/org/perlonjava/frontend/parser/ParsePrimary.java b/src/main/java/org/perlonjava/frontend/parser/ParsePrimary.java index d6644c96f..778b9b285 100644 --- a/src/main/java/org/perlonjava/frontend/parser/ParsePrimary.java +++ b/src/main/java/org/perlonjava/frontend/parser/ParsePrimary.java @@ -173,6 +173,25 @@ private static Node parseIdentifier(Parser parser, int startIndex, LexerToken to String coreGlobalName = "CORE::GLOBAL::" + operator; if (RuntimeGlob.isGlobAssigned(coreGlobalName) && existsGlobalCodeRef(coreGlobalName)) { // Example: 'BEGIN { *CORE::GLOBAL::hex = sub { 456 } } print hex("123"), "\n"' + + // Special handling for 'require' - need to convert bareword module name to string + // before passing to the override subroutine, to avoid strict subs violation + if (operator.equals("require")) { + // Parse the require argument using standard require handling + Node requireNode = CoreOperatorResolver.parseCoreOperator(parser, token, startIndex); + if (requireNode instanceof OperatorNode requireOp && requireOp.operator.equals("require")) { + // Convert to CORE::GLOBAL::require subroutine call with the parsed argument + // Use &CORE::GLOBAL::require(...) form to properly call as code ref + OperatorNode codeRef = new OperatorNode("&", + new IdentifierNode(coreGlobalName, startIndex), + startIndex); + return new BinaryOperatorNode("(", + codeRef, + (ListNode) requireOp.operand, + startIndex); + } + } + parser.tokenIndex = startIndex; // backtrack // Rewrite the tokens to call CORE::GLOBAL::operator parser.tokens.add(startIndex, new LexerToken(LexerTokenType.IDENTIFIER, "CORE")); diff --git a/src/main/java/org/perlonjava/runtime/perlmodule/Exporter.java b/src/main/java/org/perlonjava/runtime/perlmodule/Exporter.java index 841418801..62d7551ef 100644 --- a/src/main/java/org/perlonjava/runtime/perlmodule/Exporter.java +++ b/src/main/java/org/perlonjava/runtime/perlmodule/Exporter.java @@ -30,6 +30,7 @@ public static void initialize() { exporter.registerMethod("export_to_level", "exportToLevel", null); exporter.registerMethod("export_tags", "exportTags", null); exporter.registerMethod("export_ok_tags", "exportOkTags", null); + exporter.registerMethod("require_version", "requireVersion", null); // Set up @EXPORTER::EXPORT_OK = ("import"); RuntimeArray.push(GlobalVariable.getGlobalArray("Exporter::EXPORT_OK"), new RuntimeScalar("import")); @@ -179,9 +180,34 @@ public static RuntimeList exportToLevel(RuntimeArray args, int ctx) { // Process the requested symbols and tags RuntimeArray tagArray = new RuntimeArray(); + boolean hadVersionCheck = false; for (RuntimeScalar symbolObj : args.elements) { String symbolString = symbolObj.toString(); + // Check if this looks like a version number (starts with digit) + // Perl's Exporter treats these as version checks, not symbols to export + if (!symbolString.isEmpty() && Character.isDigit(symbolString.charAt(0))) { + // Call VERSION check: $pkg->VERSION($version) + RuntimeArray versionArgs = new RuntimeArray(); + versionArgs.push(new RuntimeScalar(packageName)); + versionArgs.push(symbolObj); + Universal.VERSION(versionArgs, RuntimeContextType.SCALAR); + hadVersionCheck = true; + + // If the version number was the only thing specified, + // act as if nothing was specified (import @EXPORT) + if (args.size() == 1) { + tagArray.elements.addAll(export.elements); + } + // Handle "use Foo 1.23, ''" pattern - import nothing + else if (args.size() == 2 && args.get(1).toString().isEmpty()) { + // Don't import anything + return new RuntimeList(); + } + // Otherwise, skip the version and continue with other imports + continue; + } + if (symbolString.startsWith(":")) { String tagName = symbolString.substring(1); @@ -282,6 +308,23 @@ public static RuntimeList exportOkTags(RuntimeArray args, int ctx) { return new RuntimeList(); } + /** + * require_version - delegates to the package's VERSION method. + * This exists for historical compatibility with older Exporter usage. + * + * @param args The arguments: $package, $version + * @param ctx The calling context + * @return Result of VERSION method call + */ + public static RuntimeList requireVersion(RuntimeArray args, int ctx) { + // $pkg->require_version($version) delegates to $pkg->VERSION($version) + if (args.size() < 1) { + throw new PerlCompilerException("Not enough arguments for require_version"); + } + // Call UNIVERSAL::VERSION($package, $version) + return Universal.VERSION(args, ctx); + } + private static void importFunction(String packageName, String caller, String functionName) { RuntimeScalar exportSymbol = GlobalVariable.getGlobalCodeRef(packageName + "::" + functionName); if (exportSymbol.type == RuntimeScalarType.CODE) { diff --git a/src/main/java/org/perlonjava/runtime/perlmodule/IPCOpen3.java b/src/main/java/org/perlonjava/runtime/perlmodule/IPCOpen3.java index bc0a08037..ee2327c49 100644 --- a/src/main/java/org/perlonjava/runtime/perlmodule/IPCOpen3.java +++ b/src/main/java/org/perlonjava/runtime/perlmodule/IPCOpen3.java @@ -128,7 +128,9 @@ public static RuntimeList _open3(RuntimeArray args, int ctx) { copyPerlEnvToProcessBuilder(processBuilder); // Check if stderr should be merged with stdout - boolean mergeStderr = !errRef.getDefinedBoolean() || + // errRef is "usable" if it's defined AND (if it's a reference) the inner value is also defined + boolean errIsUsable = isUsableHandle(errRef); + boolean mergeStderr = !errIsUsable || (rdrRef.type == RuntimeScalarType.REFERENCE && errRef.type == RuntimeScalarType.REFERENCE && rdrRef.value == errRef.value); @@ -145,14 +147,31 @@ public static RuntimeList _open3(RuntimeArray args, int ctx) { registerChildProcess(process); // Set up the write handle (to child's stdin) - setupWriteHandle(wtrRef, process.getOutputStream()); + // Check for redirection directive like "<&STDIN" + if (isInputRedirection(wtrRef)) { + // Input redirection - just close the process stdin + process.getOutputStream().close(); + } else { + setupWriteHandle(wtrRef, process.getOutputStream()); + } // Set up the read handle (from child's stdout) - setupReadHandle(rdrRef, process.getInputStream()); + // Check for redirection directive like ">&STDERR" + boolean rdrIsRedirection = isOutputRedirection(rdrRef); + if (rdrIsRedirection) { + // Output redirection - pipe stdout to the named handle + handleOutputRedirection(rdrRef, process.getInputStream()); + } else { + setupReadHandle(rdrRef, process.getInputStream()); + } // Set up the error handle (from child's stderr) if not merged - if (!mergeStderr && errRef.getDefinedBoolean()) { - setupReadHandle(errRef, process.getErrorStream()); + if (!mergeStderr && errIsUsable) { + if (isOutputRedirection(errRef)) { + handleOutputRedirection(errRef, process.getErrorStream()); + } else { + setupReadHandle(errRef, process.getErrorStream()); + } } return new RuntimeScalar(pid).getList(); @@ -163,6 +182,122 @@ public static RuntimeList _open3(RuntimeArray args, int ctx) { } } + /** + * Check if the handle is an output redirection directive like ">&STDERR" + */ + private static boolean isOutputRedirection(RuntimeScalar handleRef) { + // Get the actual string value (may need to dereference) + String str = getStringValue(handleRef); + return str != null && str.startsWith(">&"); + } + + /** + * Check if the handle is an input redirection directive like "<&STDIN" + */ + private static boolean isInputRedirection(RuntimeScalar handleRef) { + // Get the actual string value (may need to dereference) + String str = getStringValue(handleRef); + return str != null && str.startsWith("<&"); + } + + /** + * Check if a handle parameter is usable (not undef or a reference to undef) + */ + private static boolean isUsableHandle(RuntimeScalar handleRef) { + if (!handleRef.getDefinedBoolean()) { + return false; + } + // If it's a reference, check if the inner value is defined + if (handleRef.type == RuntimeScalarType.REFERENCE && handleRef.value instanceof RuntimeScalar) { + RuntimeScalar inner = (RuntimeScalar) handleRef.value; + return inner.getDefinedBoolean(); + } + return true; + } + + /** + * Get the string value from a scalar, dereferencing if needed + */ + private static String getStringValue(RuntimeScalar scalar) { + if (scalar == null) return null; + + // If it's a reference, dereference it + if (scalar.type == RuntimeScalarType.REFERENCE) { + if (scalar.value instanceof RuntimeScalar) { + RuntimeScalar inner = (RuntimeScalar) scalar.value; + // Check if the inner value is a string + if (inner.type == RuntimeScalarType.STRING) { + return inner.toString(); + } + // Also try getting the string directly + return inner.toString(); + } + } + + // Direct string type + if (scalar.type == RuntimeScalarType.STRING) { + return scalar.toString(); + } + + // Try toString and check if it looks like a redirect + String str = scalar.toString(); + if (str.startsWith(">&") || str.startsWith("<&")) { + return str; + } + + return null; + } + + /** + * Handle output redirection like ">&STDERR" - pipe input stream to the named handle + */ + private static void handleOutputRedirection(RuntimeScalar handleRef, InputStream in) { + String directive = handleRef.toString(); + String handleName = directive.substring(2); // Remove ">&" + + // Get the named handle + RuntimeIO targetIO = null; + if (handleName.equals("STDERR")) { + targetIO = getGlobalVariable("main::STDERR").getRuntimeIO(); + } else if (handleName.equals("STDOUT")) { + targetIO = getGlobalVariable("main::STDOUT").getRuntimeIO(); + } + + if (targetIO != null && targetIO.ioHandle != null) { + final RuntimeIO finalTargetIO = targetIO; + // Start a thread to copy data from process to target handle + Thread copier = new Thread(() -> { + try { + byte[] buffer = new byte[4096]; + int bytesRead; + while ((bytesRead = in.read(buffer)) != -1) { + String str = new String(buffer, 0, bytesRead); + finalTargetIO.ioHandle.write(str); + finalTargetIO.ioHandle.flush(); + } + } catch (Exception e) { + // Ignore - process may have terminated + } + }); + copier.setDaemon(true); + copier.start(); + } else { + // Fallback: just discard the stream + Thread discarder = new Thread(() -> { + try { + byte[] buffer = new byte[4096]; + while (in.read(buffer) != -1) { + // discard + } + } catch (Exception e) { + // Ignore + } + }); + discarder.setDaemon(true); + discarder.start(); + } + } + /** * XS implementation of open2. *

diff --git a/src/main/java/org/perlonjava/runtime/perlmodule/Utf8.java b/src/main/java/org/perlonjava/runtime/perlmodule/Utf8.java index 7c7bf7bf2..5bc5c63a4 100644 --- a/src/main/java/org/perlonjava/runtime/perlmodule/Utf8.java +++ b/src/main/java/org/perlonjava/runtime/perlmodule/Utf8.java @@ -327,6 +327,15 @@ public static RuntimeList isUtf8(RuntimeArray args, int ctx) { /** * Tests whether the string is in a consistent state regarding UTF-8. * + *

In Perl, utf8::valid() checks whether a string's internal state is consistent: + *

+ * * @param args The arguments passed to the method. * @param ctx The context in which the method is called. * @return A RuntimeList indicating if the string is valid UTF-8. @@ -337,10 +346,49 @@ public static RuntimeList valid(RuntimeArray args, int ctx) { } RuntimeScalar scalar = args.get(0); String string = scalar.toString(); - CharsetDetector detector = new CharsetDetector(); - detector.setText(string.getBytes()); - CharsetMatch match = detector.detect(); - boolean isValid = match != null && "UTF-8".equalsIgnoreCase(match.getName()); - return new RuntimeScalar(isValid).getList(); + + if (scalar.type == BYTE_STRING) { + // For byte strings, check if the bytes form valid UTF-8 + // Extract raw byte values and try to decode as UTF-8 + byte[] bytes = new byte[string.length()]; + for (int i = 0; i < string.length(); i++) { + char c = string.charAt(i); + if (c > 0xFF) { + // Byte string should not contain chars > 0xFF + // This is an inconsistent state + return RuntimeScalarCache.scalarFalse.getList(); + } + bytes[i] = (byte) c; + } + CharsetDecoder decoder = StandardCharsets.UTF_8.newDecoder() + .onMalformedInput(CodingErrorAction.REPORT) + .onUnmappableCharacter(CodingErrorAction.REPORT); + try { + decoder.decode(ByteBuffer.wrap(bytes)); + return RuntimeScalarCache.scalarTrue.getList(); + } catch (CharacterCodingException e) { + return RuntimeScalarCache.scalarFalse.getList(); + } + } else { + // For character strings (UTF-8 flag on), check if all characters are valid + // Unicode code points. Java strings contain UTF-16 code units, which + // represent valid Unicode code points (including surrogate pairs for astral + // characters). As long as surrogate pairs are properly formed, the string + // is valid. + for (int i = 0; i < string.length(); i++) { + char c = string.charAt(i); + if (Character.isHighSurrogate(c)) { + // High surrogate must be followed by low surrogate + if (i + 1 >= string.length() || !Character.isLowSurrogate(string.charAt(i + 1))) { + return RuntimeScalarCache.scalarFalse.getList(); + } + i++; // Skip the low surrogate + } else if (Character.isLowSurrogate(c)) { + // Low surrogate without preceding high surrogate is invalid + return RuntimeScalarCache.scalarFalse.getList(); + } + } + return RuntimeScalarCache.scalarTrue.getList(); + } } } diff --git a/src/main/perl/lib/Class/Struct.pm b/src/main/perl/lib/Class/Struct.pm new file mode 100644 index 000000000..a574734e5 --- /dev/null +++ b/src/main/perl/lib/Class/Struct.pm @@ -0,0 +1,637 @@ +package Class::Struct; + +## See POD after __END__ + +use 5.006_001; + +use strict; +use warnings::register; +our(@ISA, @EXPORT, $VERSION); + +use Carp; + +require Exporter; +@ISA = qw(Exporter); +@EXPORT = qw(struct); + +$VERSION = '0.68'; + +my $print = 0; +sub printem { + if (@_) { $print = shift } + else { $print++ } +} + +{ + package Class::Struct::Tie_ISA; + + sub TIEARRAY { + my $class = shift; + return bless [], $class; + } + + sub STORE { + my ($self, $index, $value) = @_; + Class::Struct::_subclass_error(); + } + + sub FETCH { + my ($self, $index) = @_; + $self->[$index]; + } + + sub FETCHSIZE { + my $self = shift; + return scalar(@$self); + } + + sub DESTROY { } +} + +sub import { + my $self = shift; + + if ( @_ == 0 ) { + $self->export_to_level( 1, $self, @EXPORT ); + } elsif ( @_ == 1 ) { + # This is admittedly a little bit silly: + # do we ever export anything else than 'struct'...? + $self->export_to_level( 1, $self, @_ ); + } else { + goto &struct; + } +} + +sub struct { + + # Determine parameter list structure, one of: + # struct( class => [ element-list ]) + # struct( class => { element-list }) + # struct( element-list ) + # Latter form assumes current package name as struct name. + + my ($class, @decls); + my $base_type = ref $_[1]; + if ( $base_type eq 'HASH' ) { + $class = shift; + @decls = %{shift()}; + _usage_error() if @_; + } + elsif ( $base_type eq 'ARRAY' ) { + $class = shift; + @decls = @{shift()}; + _usage_error() if @_; + } + else { + $base_type = 'ARRAY'; + $class = caller(); + @decls = @_; + } + + _usage_error() if @decls % 2 == 1; + + # Ensure we are not, and will not be, a subclass. + + my $isa = do { + no strict 'refs'; + \@{$class . '::ISA'}; + }; + _subclass_error() if @$isa; + tie @$isa, 'Class::Struct::Tie_ISA'; + + # Create constructor. + + croak "function 'new' already defined in package $class" + if do { no strict 'refs'; defined &{$class . "::new"} }; + + my @methods = (); + my %refs = (); + my %arrays = (); + my %hashes = (); + my %classes = (); + my $got_class = 0; + my $out = ''; + + $out = "{\n package $class;\n use Carp;\n sub new {\n"; + $out .= " my (\$class, \%init) = \@_;\n"; + $out .= " \$class = __PACKAGE__ unless \@_;\n"; + + my $cnt = 0; + my $idx = 0; + my( $cmt, $name, $type, $elem ); + + if( $base_type eq 'HASH' ){ + $out .= " my(\$r) = {};\n"; + $cmt = ''; + } + elsif( $base_type eq 'ARRAY' ){ + $out .= " my(\$r) = [];\n"; + } + + $out .= " bless \$r, \$class;\n\n"; + + while( $idx < @decls ){ + $name = $decls[$idx]; + $type = $decls[$idx+1]; + push( @methods, $name ); + if( $base_type eq 'HASH' ){ + $elem = "{'${class}::$name'}"; + } + elsif( $base_type eq 'ARRAY' ){ + $elem = "[$cnt]"; + ++$cnt; + $cmt = " # $name"; + } + if( $type =~ /^\*(.)/ ){ + $refs{$name}++; + $type = $1; + } + my $init = "defined(\$init{'$name'}) ? \$init{'$name'} :"; + if( $type eq '@' ){ + $out .= " croak 'Initializer for $name must be array reference'\n"; + $out .= " if defined(\$init{'$name'}) && ref(\$init{'$name'}) ne 'ARRAY';\n"; + $out .= " \$r->$name( $init [] );$cmt\n"; + $arrays{$name}++; + } + elsif( $type eq '%' ){ + $out .= " croak 'Initializer for $name must be hash reference'\n"; + $out .= " if defined(\$init{'$name'}) && ref(\$init{'$name'}) ne 'HASH';\n"; + $out .= " \$r->$name( $init {} );$cmt\n"; + $hashes{$name}++; + } + elsif ( $type eq '$') { + $out .= " \$r->$name( $init undef );$cmt\n"; + } + elsif( $type =~ /^\w+(?:::\w+)*$/ ){ + $out .= " if (defined(\$init{'$name'})) {\n"; + $out .= " if (ref \$init{'$name'} eq 'HASH')\n"; + $out .= " { \$r->$name( $type->new(\%{\$init{'$name'}}) ) } $cmt\n"; + $out .= " elsif (UNIVERSAL::isa(\$init{'$name'}, '$type'))\n"; + $out .= " { \$r->$name( \$init{'$name'} ) } $cmt\n"; + $out .= " else { croak 'Initializer for $name must be hash or $type reference' }\n"; + $out .= " }\n"; + $classes{$name} = $type; + $got_class = 1; + } + else{ + croak "'$type' is not a valid struct element type"; + } + $idx += 2; + } + + $out .= "\n \$r;\n}\n"; + + # Create accessor methods. + + my( $pre, $pst, $sel ); + $cnt = 0; + foreach $name (@methods){ + if ( do { no strict 'refs'; defined &{$class . "::$name"} } ) { + warnings::warnif("function '$name' already defined, overrides struct accessor method"); + } + else { + $pre = $pst = $cmt = $sel = ''; + if( defined $refs{$name} ){ + $pre = "\\("; + $pst = ")"; + $cmt = " # returns ref"; + } + $out .= " sub $name {$cmt\n my \$r = shift;\n"; + if( $base_type eq 'ARRAY' ){ + $elem = "[$cnt]"; + ++$cnt; + } + elsif( $base_type eq 'HASH' ){ + $elem = "{'${class}::$name'}"; + } + if( defined $arrays{$name} ){ + $out .= " my \$i;\n"; + $out .= " \@_ ? (\$i = shift) : return \$r->$elem;\n"; + $out .= " if (ref(\$i) eq 'ARRAY' && !\@_) { \$r->$elem = \$i; return \$r }\n"; + $sel = "->[\$i]"; + } + elsif( defined $hashes{$name} ){ + $out .= " my \$i;\n"; + $out .= " \@_ ? (\$i = shift) : return \$r->$elem;\n"; + $out .= " if (ref(\$i) eq 'HASH' && !\@_) { \$r->$elem = \$i; return \$r }\n"; + $sel = "->{\$i}"; + } + elsif( defined $classes{$name} ){ + $out .= " croak '$name argument is wrong class' if \@_ && ! UNIVERSAL::isa(\$_[0], '$classes{$name}');\n"; + } + $out .= " croak 'Too many args to $name' if \@_ > 1;\n"; + $out .= " \@_ ? ($pre\$r->$elem$sel = shift$pst) : $pre\$r->$elem$sel$pst;\n"; + $out .= " }\n"; + } + } + $out .= "}\n1;\n"; + + print $out if $print; + my $result = eval $out; + carp $@ if $@; +} + +sub _usage_error { + confess "struct usage error"; +} + +sub _subclass_error { + croak 'struct class cannot be a subclass (@ISA not allowed)'; +} + +1; # for require + + +__END__ + +=head1 NAME + +Class::Struct - declare struct-like datatypes as Perl classes + +=head1 SYNOPSIS + + use Class::Struct; + # declare struct, based on array: + struct( CLASS_NAME => [ ELEMENT_NAME => ELEMENT_TYPE, ... ]); + # declare struct, based on hash: + struct( CLASS_NAME => { ELEMENT_NAME => ELEMENT_TYPE, ... }); + + package CLASS_NAME; + use Class::Struct; + # declare struct, based on array, implicit class name: + struct( ELEMENT_NAME => ELEMENT_TYPE, ... ); + + # Declare struct at compile time + use Class::Struct CLASS_NAME => [ELEMENT_NAME => ELEMENT_TYPE, ...]; + use Class::Struct CLASS_NAME => {ELEMENT_NAME => ELEMENT_TYPE, ...}; + + # declare struct at compile time, based on array, implicit + # class name: + package CLASS_NAME; + use Class::Struct ELEMENT_NAME => ELEMENT_TYPE, ... ; + + package Myobj; + use Class::Struct; + # declare struct with four types of elements: + struct( s => '$', a => '@', h => '%', c => 'My_Other_Class' ); + + my $obj = Myobj->new; # constructor + + # scalar type accessor: + my $element_value = $obj->s; # element value + $obj->s('new value'); # assign to element + + # array type accessor: + my $ary_ref = $obj->a; # reference to whole array + my $ary_element_value = $obj->a(2); # array element value + $obj->a(2, 'new value'); # assign to array element + + # hash type accessor: + my $hash_ref = $obj->h; # reference to whole hash + my $hash_element_value = $obj->h('x'); # hash element value + $obj->h('x', 'new value'); # assign to hash element + + # class type accessor: + my $element_value = $obj->c; # object reference + $obj->c->method(...); # call method of object + $obj->c(new My_Other_Class); # assign a new object + +=head1 DESCRIPTION + +C exports a single function, C. +Given a list of element names and types, and optionally +a class name, C creates a Perl 5 class that implements +a "struct-like" data structure. + +The new class is given a constructor method, C, for creating +struct objects. + +Each element in the struct data has an accessor method, which is +used to assign to the element and to fetch its value. The +default accessor can be overridden by declaring a C of the +same name in the package. (See Example 2.) + +Each element's type can be scalar, array, hash, or class. + +=head2 The C function + +The C function has three forms of parameter-list. + + struct( CLASS_NAME => [ ELEMENT_LIST ]); + struct( CLASS_NAME => { ELEMENT_LIST }); + struct( ELEMENT_LIST ); + +The first and second forms explicitly identify the name of the +class being created. The third form assumes the current package +name as the class name. + +An object of a class created by the first and third forms is +based on an array, whereas an object of a class created by the +second form is based on a hash. The array-based forms will be +somewhat faster and smaller; the hash-based forms are more +flexible. + +The class created by C must not be a subclass of another +class other than C. + +It can, however, be used as a superclass for other classes. To facilitate +this, the generated constructor method uses a two-argument blessing. +Furthermore, if the class is hash-based, the key of each element is +prefixed with the class name (see I, Recipe 13.12). + +A function named C must not be explicitly defined in a class +created by C. + +The I has the form + + NAME => TYPE, ... + +Each name-type pair declares one element of the struct. Each +element name will be defined as an accessor method unless a +method by that name is explicitly defined; in the latter case, a +warning is issued if the warning flag (B<-w>) is set. + +=head2 Class Creation at Compile Time + +C can create your class at compile time. The main reason +for doing this is obvious, so your class acts like every other class in +Perl. Creating your class at compile time will make the order of events +similar to using any other class ( or Perl module ). + +There is no significant speed gain between compile time and run time +class creation, there is just a new, more standard order of events. + +=head2 Element Types and Accessor Methods + +The four element types -- scalar, array, hash, and class -- are +represented by strings -- C<'$'>, C<'@'>, C<'%'>, and a class name -- +optionally preceded by a C<'*'>. + +The accessor method provided by C for an element depends +on the declared type of the element. + +=over 4 + +=item Scalar (C<'$'> or C<'*$'>) + +The element is a scalar, and by default is initialized to C +(but see L). + +The accessor's argument, if any, is assigned to the element. + +If the element type is C<'$'>, the value of the element (after +assignment) is returned. If the element type is C<'*$'>, a reference +to the element is returned. + +=item Array (C<'@'> or C<'*@'>) + +The element is an array, initialized by default to C<()>. + +With no argument, the accessor returns a reference to the +element's whole array (whether or not the element was +specified as C<'@'> or C<'*@'>). + +With one or two arguments, the first argument is an index +specifying one element of the array; the second argument, if +present, is assigned to the array element. If the element type +is C<'@'>, the accessor returns the array element value. If the +element type is C<'*@'>, a reference to the array element is +returned. + +As a special case, when the accessor is called with an array reference +as the sole argument, this causes an assignment of the whole array element. +The object reference is returned. + +=item Hash (C<'%'> or C<'*%'>) + +The element is a hash, initialized by default to C<()>. + +With no argument, the accessor returns a reference to the +element's whole hash (whether or not the element was +specified as C<'%'> or C<'*%'>). + +With one or two arguments, the first argument is a key specifying +one element of the hash; the second argument, if present, is +assigned to the hash element. If the element type is C<'%'>, the +accessor returns the hash element value. If the element type is +C<'*%'>, a reference to the hash element is returned. + +As a special case, when the accessor is called with a hash reference +as the sole argument, this causes an assignment of the whole hash element. +The object reference is returned. + +=item Class (C<'Class_Name'> or C<'*Class_Name'>) + +The element's value must be a reference blessed to the named +class or to one of its subclasses. The element is not initialized +by default. + +The accessor's argument, if any, is assigned to the element. The +accessor will C if this is not an appropriate object +reference. + +If the element type does not start with a C<'*'>, the accessor +returns the element value (after assignment). If the element type +starts with a C<'*'>, a reference to the element itself is returned. + +=back + +=head2 Initializing with C + +C always creates a constructor called C. That constructor +may take a list of initializers for the various elements of the new +struct. + +Each initializer is a pair of values: IC< =E >I. +The initializer value for a scalar element is just a scalar value. The +initializer for an array element is an array reference. The initializer +for a hash is a hash reference. + +The initializer for a class element is an object of the corresponding class, +or of one of it's subclasses, or a reference to a hash containing named +arguments to be passed to the element's constructor. + +See Example 3 below for an example of initialization. + +=head1 EXAMPLES + +=over 4 + +=item Example 1 + +Giving a struct element a class type that is also a struct is how +structs are nested. Here, C represents a time (seconds and +microseconds), and C has two elements, each of which is of +type C. + + use Class::Struct; + + struct( Rusage => { + ru_utime => 'Timeval', # user time used + ru_stime => 'Timeval', # system time used + }); + + struct( Timeval => [ + tv_secs => '$', # seconds + tv_usecs => '$', # microseconds + ]); + + # create an object: + my $t = Rusage->new(ru_utime=>Timeval->new(), + ru_stime=>Timeval->new()); + + # $t->ru_utime and $t->ru_stime are objects of type Timeval. + # set $t->ru_utime to 100.0 sec and $t->ru_stime to 5.0 sec. + $t->ru_utime->tv_secs(100); + $t->ru_utime->tv_usecs(0); + $t->ru_stime->tv_secs(5); + $t->ru_stime->tv_usecs(0); + +=item Example 2 + +An accessor function can be redefined in order to provide +additional checking of values, etc. Here, we want the C +element always to be nonnegative, so we redefine the C +accessor accordingly. + + package MyObj; + use Class::Struct; + + # declare the struct + struct ( 'MyObj', { count => '$', stuff => '%' } ); + + # override the default accessor method for 'count' + sub count { + my $self = shift; + if ( @_ ) { + die 'count must be nonnegative' if $_[0] < 0; + $self->{'MyObj::count'} = shift; + warn "Too many args to count" if @_; + } + return $self->{'MyObj::count'}; + } + + package main; + $x = new MyObj; + print "\$x->count(5) = ", $x->count(5), "\n"; + # prints '$x->count(5) = 5' + + print "\$x->count = ", $x->count, "\n"; + # prints '$x->count = 5' + + print "\$x->count(-5) = ", $x->count(-5), "\n"; + # dies due to negative argument! + +=item Example 3 + +The constructor of a generated class can be passed a list +of I=>I pairs, with which to initialize the struct. +If no initializer is specified for a particular element, its default +initialization is performed instead. Initializers for non-existent +elements are silently ignored. + +Note that the initializer for a nested class may be specified as +an object of that class, or as a reference to a hash of initializers +that are passed on to the nested struct's constructor. + + use Class::Struct; + + struct Breed => + { + name => '$', + cross => '$', + }; + + struct Cat => + [ + name => '$', + kittens => '@', + markings => '%', + breed => 'Breed', + ]; + + + my $cat = Cat->new( name => 'Socks', + kittens => ['Monica', 'Kenneth'], + markings => { socks=>1, blaze=>"white" }, + breed => Breed->new(name=>'short-hair', cross=>1), + or: breed => {name=>'short-hair', cross=>1}, + ); + + print "Once a cat called ", $cat->name, "\n"; + print "(which was a ", $cat->breed->name, ")\n"; + print "had 2 kittens: ", join(' and ', @{$cat->kittens}), "\n"; + +=back + +=head1 Author and Modification History + +Modified by Damian Conway, 2001-09-10, v0.62. + + Modified implicit construction of nested objects. + Now will also take an object ref instead of requiring a hash ref. + Also default initializes nested object attributes to undef, rather + than calling object constructor without args + Original over-helpfulness was fraught with problems: + * the class's constructor might not be called 'new' + * the class might not have a hash-like-arguments constructor + * the class might not have a no-argument constructor + * "recursive" data structures didn't work well: + package Person; + struct { mother => 'Person', father => 'Person'}; + + +Modified by Casey West, 2000-11-08, v0.59. + + Added the ability for compile time class creation. + +Modified by Damian Conway, 1999-03-05, v0.58. + + Added handling of hash-like arg list to class ctor. + + Changed to two-argument blessing in ctor to support + derivation from created classes. + + Added classname prefixes to keys in hash-based classes + (refer to "Perl Cookbook", Recipe 13.12 for rationale). + + Corrected behaviour of accessors for '*@' and '*%' struct + elements. Package now implements documented behaviour when + returning a reference to an entire hash or array element. + Previously these were returned as a reference to a reference + to the element. + +Renamed to C and modified by Jim Miner, 1997-04-02. + + members() function removed. + Documentation corrected and extended. + Use of struct() in a subclass prohibited. + User definition of accessor allowed. + Treatment of '*' in element types corrected. + Treatment of classes as element types corrected. + Class name to struct() made optional. + Diagnostic checks added. + +Originally C by Dean Roehrich. + + # Template.pm --- struct/member template builder + # 12mar95 + # Dean Roehrich + # + # changes/bugs fixed since 28nov94 version: + # - podified + # changes/bugs fixed since 21nov94 version: + # - Fixed examples. + # changes/bugs fixed since 02sep94 version: + # - Moved to Class::Template. + # changes/bugs fixed since 20feb94 version: + # - Updated to be a more proper module. + # - Added "use strict". + # - Bug in build_methods, was using @var when @$var needed. + # - Now using my() rather than local(). + # + # Uses perl5 classes to create nested data types. + # This is offered as one implementation of Tom Christiansen's + # "structs.pl" idea. + +=cut diff --git a/src/main/perl/lib/ExtUtils/MakeMaker.pm b/src/main/perl/lib/ExtUtils/MakeMaker.pm index d360962c2..b206e5d75 100644 --- a/src/main/perl/lib/ExtUtils/MakeMaker.pm +++ b/src/main/perl/lib/ExtUtils/MakeMaker.pm @@ -184,6 +184,15 @@ sub _install_pure_perl { # Use explicit PM hash if provided if ($args->{PM}) { %pm = %{$args->{PM}}; + # Expand Make-style variables like $(INST_LIB) to actual paths + for my $key (keys %pm) { + my $val = $pm{$key}; + $val =~ s/\$\(INST_LIB\)/$INSTALL_BASE/g; + $val =~ s/\$\(INST_ARCHLIB\)/$INSTALL_BASE/g; # treat ARCHLIB same as LIB + $val =~ s/\$\(INST_LIBDIR\)/$INSTALL_BASE/g; + $val =~ s/\$\{INST_LIB\}/$INSTALL_BASE/g; # also handle ${VAR} form + $pm{$key} = $val; + } } else { # Default: scan lib/ directory if (-d 'lib') { @@ -251,6 +260,9 @@ sub _install_pure_perl { } } + # Install share directories (File::ShareDir::Install support) + $installed += _install_share_dirs($name, $args); + print "\n"; print "=" x 60, "\n"; print "Installation complete! ($installed files installed)\n"; @@ -265,6 +277,71 @@ sub _install_pure_perl { return PerlOnJava::MM::Installed->new($args); } +sub _install_share_dirs { + my ($name, $args) = @_; + my $installed = 0; + + # Check if File::ShareDir::Install was used + return 0 unless @File::ShareDir::Install::DIRS; + + # Convert module name to dist name (My::Module -> My-Module) + (my $dist_name = $name) =~ s/::/-/g; + + print "\nInstalling share directories:\n"; + + for my $def (@File::ShareDir::Install::DIRS) { + my $type = $def->{type} || 'dist'; + next if $type =~ /^delete/; # Skip delete directives + + # Get source directory - can be scalar or arrayref + my @src_dirs; + if (ref $def->{dir} eq 'ARRAY') { + @src_dirs = @{$def->{dir}}; + } elsif ($def->{dir}) { + @src_dirs = ($def->{dir}); + } + + # Handle directory specification (scan and copy all files) + for my $src_dir (@src_dirs) { + next unless -d $src_dir; + + my $dest_base; + if ($type eq 'dist') { + $dest_base = File::Spec->catdir($INSTALL_BASE, 'auto', 'share', 'dist', $dist_name); + } elsif ($type eq 'module' && $def->{module}) { + (my $mod_path = $def->{module}) =~ s/::/\//g; + $dest_base = File::Spec->catdir($INSTALL_BASE, 'auto', 'share', 'module', $mod_path); + } else { + next; + } + + find({ + wanted => sub { + return unless -f; + # Skip dotfiles unless requested + return if !$def->{dotfiles} && basename($_) =~ /^\./; + + my $src = $File::Find::name; + (my $rel = $src) =~ s{^\Q$src_dir\E/?}{}; + my $dest = File::Spec->catfile($dest_base, $rel); + my $dest_dir = dirname($dest); + make_path($dest_dir) unless -d $dest_dir; + + if (copy($src, $dest)) { + $installed++; + } else { + warn " Failed to copy $src: $!\n"; + } + }, + no_chdir => 1, + }, $src_dir); + } + } + + print " Installed $installed share files\n" if $installed; + return $installed; +} + sub _extract_version { my ($file) = @_; return '0' unless -f $file; @@ -347,6 +424,7 @@ sub _create_mymeta { # Create MYMETA.yml for CPAN.pm dependency resolution # This allows CPAN.pm to detect and install prerequisites + # Uses meta-spec v2 format with nested prereqs structure my $mymeta = 'MYMETA.yml'; @@ -355,55 +433,68 @@ sub _create_mymeta { return; }; - # Build prerequisites section - my $prereqs = ''; + # Build prerequisites in meta-spec v2 format (nested prereqs structure) + my $runtime_requires = ''; if ($args->{PREREQ_PM} && %{$args->{PREREQ_PM}}) { - $prereqs .= "requires:\n"; for my $mod (sort keys %{$args->{PREREQ_PM}}) { my $ver = $args->{PREREQ_PM}{$mod} || 0; - $prereqs .= " $mod: '$ver'\n"; + $runtime_requires .= " $mod: '$ver'\n"; } } + my $build_requires = ''; if ($args->{BUILD_REQUIRES} && %{$args->{BUILD_REQUIRES}}) { - $prereqs .= "build_requires:\n"; for my $mod (sort keys %{$args->{BUILD_REQUIRES}}) { my $ver = $args->{BUILD_REQUIRES}{$mod} || 0; - $prereqs .= " $mod: '$ver'\n"; + $build_requires .= " $mod: '$ver'\n"; } } + my $test_requires = ''; if ($args->{TEST_REQUIRES} && %{$args->{TEST_REQUIRES}}) { - $prereqs .= "test_requires:\n"; for my $mod (sort keys %{$args->{TEST_REQUIRES}}) { my $ver = $args->{TEST_REQUIRES}{$mod} || 0; - $prereqs .= " $mod: '$ver'\n"; + $test_requires .= " $mod: '$ver'\n"; } } + my $configure_requires = ''; if ($args->{CONFIGURE_REQUIRES} && %{$args->{CONFIGURE_REQUIRES}}) { - $prereqs .= "configure_requires:\n"; for my $mod (sort keys %{$args->{CONFIGURE_REQUIRES}}) { my $ver = $args->{CONFIGURE_REQUIRES}{$mod} || 0; - $prereqs .= " $mod: '$ver'\n"; + $configure_requires .= " $mod: '$ver'\n"; } } # Convert NAME to abstract (guess from module name) my $abstract = $args->{ABSTRACT} || "$name module"; + # Build prereqs structure only including non-empty sections + my $prereqs = "prereqs:\n"; + if ($configure_requires) { + $prereqs .= " configure:\n requires:\n$configure_requires"; + } + if ($runtime_requires) { + $prereqs .= " runtime:\n requires:\n$runtime_requires"; + } + if ($build_requires) { + $prereqs .= " build:\n requires:\n$build_requires"; + } + if ($test_requires) { + $prereqs .= " test:\n requires:\n$test_requires"; + } + print $fh <<"MYMETA"; --- abstract: '$abstract' author: - 'Unknown' -build_requires: {} dynamic_config: 0 generated_by: 'ExtUtils::MakeMaker (PerlOnJava)' license: perl meta-spec: - url: http://module-build.sourceforge.net/META-spec-v1.4.html - version: '1.4' + url: https://metacpan.org/pod/CPAN::Meta::Spec + version: '2' name: $name no_index: directory: diff --git a/src/main/perl/lib/Fcntl.pm b/src/main/perl/lib/Fcntl.pm index 6201432fa..26e202532 100644 --- a/src/main/perl/lib/Fcntl.pm +++ b/src/main/perl/lib/Fcntl.pm @@ -54,6 +54,58 @@ use constant O_WRONLY_CREAT_EXCL => O_WRONLY | O_CREAT | O_EXCL; use constant O_WRONLY_CREAT_TRUNC => O_WRONLY | O_CREAT | O_TRUNC; use constant O_RDWR_CREAT => O_RDWR | O_CREAT; +# File type masks (S_IF*) +use constant S_IFMT => 0170000; # Type of file mask +use constant S_IFSOCK => 0140000; # Socket +use constant S_IFLNK => 0120000; # Symbolic link +use constant S_IFREG => 0100000; # Regular file +use constant S_IFBLK => 0060000; # Block device +use constant S_IFDIR => 0040000; # Directory +use constant S_IFCHR => 0020000; # Character device +use constant S_IFIFO => 0010000; # FIFO (named pipe) +use constant S_IFWHT => 0160000; # Whiteout (BSD) +use constant _S_IFMT => S_IFMT; # Alias + +# Special mode bits +use constant S_ISUID => 04000; # Set user ID on execution +use constant S_ISGID => 02000; # Set group ID on execution +use constant S_ISVTX => 01000; # Sticky bit +use constant S_ISTXT => S_ISVTX; # Alias for sticky bit +use constant S_ENFMT => S_ISGID; # Alias for ISGID + +# User permissions +use constant S_IRUSR => 0400; # Owner read +use constant S_IWUSR => 0200; # Owner write +use constant S_IXUSR => 0100; # Owner execute +use constant S_IRWXU => 0700; # Owner read/write/execute +use constant S_IREAD => S_IRUSR; # Alias +use constant S_IWRITE => S_IWUSR; # Alias +use constant S_IEXEC => S_IXUSR; # Alias + +# Group permissions +use constant S_IRGRP => 040; # Group read +use constant S_IWGRP => 020; # Group write +use constant S_IXGRP => 010; # Group execute +use constant S_IRWXG => 070; # Group read/write/execute + +# Other permissions +use constant S_IROTH => 04; # Other read +use constant S_IWOTH => 02; # Other write +use constant S_IXOTH => 01; # Other execute +use constant S_IRWXO => 07; # Other read/write/execute + +# File type test macros (as subs that return 0/1) +sub S_ISREG { (($_[0] // 0) & S_IFMT) == S_IFREG } +sub S_ISDIR { (($_[0] // 0) & S_IFMT) == S_IFDIR } +sub S_ISLNK { (($_[0] // 0) & S_IFMT) == S_IFLNK } +sub S_ISSOCK { (($_[0] // 0) & S_IFMT) == S_IFSOCK } +sub S_ISBLK { (($_[0] // 0) & S_IFMT) == S_IFBLK } +sub S_ISCHR { (($_[0] // 0) & S_IFMT) == S_IFCHR } +sub S_ISFIFO { (($_[0] // 0) & S_IFMT) == S_IFIFO } +sub S_ISWHT { (($_[0] // 0) & S_IFMT) == S_IFWHT } +sub S_ISENFMT { (($_[0] // 0) & S_ENFMT) ? 1 : 0 } +sub S_IMODE { ($_[0] // 0) & 07777 } # Permission bits only + # Named groups of exports our %EXPORT_TAGS = ( diff --git a/src/main/perl/lib/File/stat.pm b/src/main/perl/lib/File/stat.pm new file mode 100644 index 000000000..9b1eeb569 --- /dev/null +++ b/src/main/perl/lib/File/stat.pm @@ -0,0 +1,370 @@ +package File::stat 1.15; +use v5.38; + +use warnings::register; +use Carp; +use constant _IS_CYGWIN => $^O eq "cygwin"; + +BEGIN { *warnif = \&warnings::warnif } + +our ( $st_dev, $st_ino, $st_mode, + $st_nlink, $st_uid, $st_gid, + $st_rdev, $st_size, + $st_atime, $st_mtime, $st_ctime, + $st_blksize, $st_blocks +); + +use Exporter 'import'; +our @EXPORT = qw(stat lstat); +our @fields = qw( $st_dev $st_ino $st_mode + $st_nlink $st_uid $st_gid + $st_rdev $st_size + $st_atime $st_mtime $st_ctime + $st_blksize $st_blocks + ); +our @EXPORT_OK = ( @fields, "stat_cando" ); +our %EXPORT_TAGS = ( FIELDS => [ @fields, @EXPORT ] ); + +use Fcntl qw(S_IRUSR S_IWUSR S_IXUSR); + +BEGIN { + # These constants will croak on use if the platform doesn't define + # them. It's important to avoid inflicting that on the user. + no strict 'refs'; + for (qw(suid sgid svtx)) { + my $val = eval { &{"Fcntl::S_I\U$_"} }; + *{"_$_"} = defined $val ? sub { $_[0] & $val ? 1 : "" } : sub { "" }; + } + for (qw(SOCK CHR BLK REG DIR LNK)) { + *{"S_IS$_"} = defined eval { &{"Fcntl::S_IF$_"} } + ? \&{"Fcntl::S_IS$_"} : sub { "" }; + } + # FIFO flag and macro don't quite follow the S_IF/S_IS pattern above + # RT #111638 + *{"S_ISFIFO"} = defined &Fcntl::S_IFIFO + ? \&Fcntl::S_ISFIFO : sub { "" }; +} + +# from doio.c +sub _ingroup { + my ($gid, $eff) = @_; + + # I am assuming that since VMS doesn't have getgroups(2), $) will + # always only contain a single entry. + $^O eq "VMS" and return $_[0] == $); + + my ($egid, @supp) = split " ", $); + my ($rgid) = split " ", $(; + + $gid == ($eff ? $egid : $rgid) and return 1; + grep $gid == $_, @supp and return 1; + + return ""; +} + +# VMS uses the Unix version of the routine, even though this is very +# suboptimal. VMS has a permissions structure that doesn't really fit +# into struct stat, and unlike on Win32 the normal -X operators respect +# that, but unfortunately by the time we get here we've already lost the +# information we need. It looks to me as though if we were to preserve +# the st_devnam entry of vmsish.h's fake struct stat (which actually +# holds the filename) it might be possible to do this right, but both +# getting that value out of the struct (perl's stat doesn't return it) +# and interpreting it later would require this module to have an XS +# component (at which point we might as well just call Perl_cando and +# have done with it). + +if (grep $^O eq $_, qw/os2 MSWin32/) { + + # from doio.c + *cando = sub { ($_[0][2] & $_[1]) ? 1 : "" }; +} +else { + + # from doio.c + *cando = sub { + my ($s, $mode, $eff) = @_; + my $uid = $eff ? $> : $<; + my ($stmode, $stuid, $stgid) = @$s[2,4,5]; + + # This code basically assumes that the rwx bits of the mode are + # the 0777 bits, but so does Perl_cando. + + if (_IS_CYGWIN ? _ingroup(544, $eff) : ($uid == 0 && $^O ne "VMS")) { + # If we're root on unix + # not testing for executable status => all file tests are true + return 1 if !($mode & 0111); + # testing for executable status => + # for a file, any x bit will do + # for a directory, always true + return 1 if $stmode & 0111 || S_ISDIR($stmode); + return ""; + } + + if ($stuid == $uid) { + $stmode & $mode and return 1; + } + elsif (_ingroup($stgid, $eff)) { + $stmode & ($mode >> 3) and return 1; + } + else { + $stmode & ($mode >> 6) and return 1; + } + return ""; + }; +} + +# alias for those who don't like objects +*stat_cando = \&cando; + +my %op = ( + r => sub { cando($_[0], S_IRUSR, 1) }, + w => sub { cando($_[0], S_IWUSR, 1) }, + x => sub { cando($_[0], S_IXUSR, 1) }, + o => sub { $_[0][4] == $> }, + + R => sub { cando($_[0], S_IRUSR, 0) }, + W => sub { cando($_[0], S_IWUSR, 0) }, + X => sub { cando($_[0], S_IXUSR, 0) }, + O => sub { $_[0][4] == $< }, + + e => sub { 1 }, + z => sub { $_[0][7] == 0 }, + s => sub { $_[0][7] }, + + f => sub { S_ISREG ($_[0][2]) }, + d => sub { S_ISDIR ($_[0][2]) }, + l => sub { S_ISLNK ($_[0][2]) }, + p => sub { S_ISFIFO($_[0][2]) }, + S => sub { S_ISSOCK($_[0][2]) }, + b => sub { S_ISBLK ($_[0][2]) }, + c => sub { S_ISCHR ($_[0][2]) }, + + u => sub { _suid($_[0][2]) }, + g => sub { _sgid($_[0][2]) }, + k => sub { _svtx($_[0][2]) }, + + M => sub { ($^T - $_[0][9] ) / 86400 }, + C => sub { ($^T - $_[0][10]) / 86400 }, + A => sub { ($^T - $_[0][8] ) / 86400 }, +); + +use constant HINT_FILETEST_ACCESS => 0x00400000; + +# we need fallback=>1 or stringifying breaks +use overload + fallback => 1, + -X => sub { + my ($s, $op) = @_; + + if (index("rwxRWX", $op) >= 0) { + (caller 0)[8] & HINT_FILETEST_ACCESS + and warnif("File::stat ignores use filetest 'access'"); + + $^O eq "VMS" and warnif("File::stat ignores VMS ACLs"); + + # It would be nice to have a warning about using -l on a + # non-lstat, but that would require an extra member in the + # object. + } + + if ($op{$op}) { + return $op{$op}->($_[0]); + } + else { + croak "-$op is not implemented on a File::stat object"; + } + }; + +use Class::Struct qw(struct); +struct 'File::stat' => [ + map { $_ => '$' } qw{ + dev ino mode nlink uid gid rdev size + atime mtime ctime blksize blocks + } +]; + +sub populate { + return undef unless @_; + my $stob = new(); + @$stob = ( + $st_dev, $st_ino, $st_mode, $st_nlink, $st_uid, $st_gid, $st_rdev, + $st_size, $st_atime, $st_mtime, $st_ctime, $st_blksize, $st_blocks ) + = @_; + return $stob; +} + +sub lstat :prototype(_) ($arg) { + populate(CORE::lstat $arg) +} + +sub stat :prototype(_) ($arg) { + my $st = populate(CORE::stat $arg); + return $st if defined $st || ref $arg; + # ... maybe $arg is the name of a bareword handle? + my $fh; + { + local $!; + no strict 'refs'; + require Symbol; + $fh = \*{ Symbol::qualify( $arg, caller() )}; + return undef unless defined fileno $fh; + } + return populate(CORE::stat $fh); +} + +__END__ + +=head1 NAME + +File::stat - by-name interface to Perl's built-in stat() functions + +=head1 SYNOPSIS + + use File::stat; + my $st = stat($file) or die "No $file: $!"; + if ( ($st->mode & 0111) && ($st->nlink > 1) ) { + print "$file is executable with lotsa links\n"; + } + + if ( -x $st ) { + print "$file is executable\n"; + } + + use Fcntl "S_IRUSR"; + if ( $st->cando(S_IRUSR, 1) ) { + print "My effective uid can read $file\n"; + } + + use File::stat qw(:FIELDS); + stat($file) or die "No $file: $!"; + if ( ($st_mode & 0111) && ($st_nlink > 1) ) { + print "$file is executable with lotsa links\n"; + } + +=head1 DESCRIPTION + +This module's default exports override the core stat() +and lstat() functions, replacing them with versions that return +"File::stat" objects. This object has methods that +return the similarly named structure field name from the +L function; namely, +dev, +ino, +mode, +nlink, +uid, +gid, +rdev, +size, +atime, +mtime, +ctime, +blksize, +and +blocks. + +As of version 1.02 (provided with perl 5.12) the object provides C<"-X"> +overloading, so you can call filetest operators (C<-f>, C<-x>, and so +on) on it. It also provides a C<< ->cando >> method, called like + + $st->cando( ACCESS, EFFECTIVE ) + +where I is one of C, C or C from the +L module, and I indicates whether to use +effective (true) or real (false) ids. The method interprets the C, +C and C fields, and returns whether or not the current process +would be allowed the specified access. + +If you don't want to use the objects, you may import the C<< ->cando >> +method into your namespace as a regular function called C. +This takes an arrayref containing the return values of C or +C as its first argument, and interprets it for you. + +You may also import all the structure fields directly into your namespace +as regular variables using the :FIELDS import tag. (Note that this still +overrides your stat() and lstat() functions.) Access these fields as +variables named with a preceding C in front their method names. +Thus, C<$stat_obj-Edev()> corresponds to $st_dev if you import +the fields. + +To access this functionality without the core overrides, pass the C +an empty import list, and then access functions with their full qualified +names: + + use File::stat (); + my $st = File::stat::stat($file); + +On the other hand, the built-ins are still available via the C +pseudo-package even if you let File::stat override them: + + use File::stat; + my ($dev, $ino, $mode) = CORE::stat($file); + +As of version 1.15 (provided with perl 5.44) C and C can be +called without arguments, in which case C<$_> is used (just like the +built-in C/C functions): + + my $st_1 = stat; # stat($_) + my $st_2 = lstat; # lstat($_) + +=head1 BUGS + +The built-in C and C functions recognize the special +filehandle C<_> (underscore) to indicate that no actual C be done; +instead the results of the last C or C or filetest operation +should be returned. This syntax does not work with File::stat, but the +same result can be achieved by passing C a reference to the C<*_> +typeglob: + + use File::stat; + my $stat_obj = stat \*_; # reuse results of last stat operation + +Alternatively, another workaround is to explicitly populate the object +using the unexported and undocumented populate() function with +CORE::stat(): + + my $stat_obj = File::stat::populate(CORE::stat(_)); + +=head1 ERRORS + +=over 4 + +=item -%s is not implemented on a File::stat object + +The filetest operators C<-t>, C<-T> and C<-B> are not implemented, as +they require more information than just a stat buffer. + +=back + +=head1 WARNINGS + +These can all be disabled with + + no warnings "File::stat"; + +=over 4 + +=item File::stat ignores use filetest 'access' + +You have tried to use one of the C<-rwxRWX> filetests with C in effect. C will ignore the pragma, and +just use the information in the C member as usual. + +=item File::stat ignores VMS ACLs + +VMS systems have a permissions structure that cannot be completely +represented in a stat buffer, and unlike on other systems the builtin +filetest operators respect this. The C overloads, however, +do not, since the information required is not available. + +=back + +=head1 NOTE + +While this class is currently implemented using the L +module to build a struct-like class, you shouldn't rely upon this. + +=head1 AUTHOR + +Tom Christiansen diff --git a/src/main/perl/lib/IPC/Open3.pm b/src/main/perl/lib/IPC/Open3.pm index 3f4d651a0..1277c4673 100644 --- a/src/main/perl/lib/IPC/Open3.pm +++ b/src/main/perl/lib/IPC/Open3.pm @@ -45,6 +45,11 @@ sub open3 { # Handle the case where a single command string needs shell interpretation # vs multiple args which are passed directly + # Check for redirection directives (read-only strings like ">&STDERR") + my $wtr_is_redirect = defined($wtr) && !ref($wtr) && $wtr =~ /^[<>]&/; + my $rdr_is_redirect = defined($rdr) && !ref($rdr) && $rdr =~ /^[<>]&/; + my $err_is_redirect = defined($err) && !ref($err) && $err =~ /^[<>]&/; + # Set up handles - create globs if needed my $wtr_ref = \$_[0]; my $rdr_ref = \$_[1]; @@ -53,13 +58,13 @@ sub open3 { # Call the XS implementation my $pid = _open3($wtr_ref, $rdr_ref, $err_ref, @cmd); - # Update the caller's variables - $_[0] = $$wtr_ref; - $_[1] = $$rdr_ref; - $_[2] = $$err_ref if defined $err; + # Update the caller's variables (but not if they were redirection directives) + $_[0] = $$wtr_ref unless $wtr_is_redirect; + $_[1] = $$rdr_ref unless $rdr_is_redirect; + $_[2] = $$err_ref if defined $err && !$err_is_redirect; # Turn on autoflush for the write handle - if (defined $_[0]) { + if (defined $_[0] && !$wtr_is_redirect) { my $old = select($_[0]); $| = 1; select($old);