diff --git a/dev/modules/type_tiny.md b/dev/modules/type_tiny.md index c04640692..6a3953f31 100644 --- a/dev/modules/type_tiny.md +++ b/dev/modules/type_tiny.md @@ -8,10 +8,10 @@ and many CPAN modules. This document tracks the work needed to make ## Current Status -**Branch:** `feature/type-tiny-support` +**Branch:** `feature/type-tiny-phase6` **Module version:** Type::Tiny 2.010001 (375 test programs) -**Pass rate:** 99.5% (2476/2488 individual tests in tests that ran, 6 files with real failures) -**Phase:** 5e complete (2026-04-09) +**Pass rate:** 99.7% (3029/3038 individual tests, 5 files with real failures) +**Phase:** 6 complete (2026-04-10) ### Baseline Results @@ -296,7 +296,7 @@ Type::Tie, _HalfOp overloading, etc.) as time permits. ## Progress Tracking -### Current Status: Phase 5 completed — 99.0% pass rate (2879/2907) +### Current Status: Phase 6 completed — 99.7% pass rate (3029/3038) ### Results History @@ -306,6 +306,7 @@ Type::Tie, _HalfOp overloading, etc.) as time permits. | Phase 4 | 186 | 57 | — | — | — | | Phase 5a | 318 | 13 | 2812 | 2869 | 98.0% | | Phase 5b | 331 | 10 | 2879 | 2907 | 99.0% | +| Phase 6 | 347 | 5 | 3029 | 3038 | 99.7% | ### Completed Phases - [x] Phase 1: `looks_like_number` string parsing (2026-04-09) @@ -454,55 +455,137 @@ Type::Tie, _HalfOp overloading, etc.) as time permits. - `Type-Params/multisig-gotonext.t` (1/6 → 8/8) — eval local restore fix - `00-begin.t` (0/0 → 1/1) — eval local restore fix -### Remaining Failing Test Files (after Phase 5e) +- [x] Phase 6: Tie infrastructure, lexical sub parsing, splice context (2026-04-10) + - **Splice list context in interpreter:** Function calls in splice replacement positions + now evaluated in LIST context (not SCALAR), matching the JVM backend behavior. The + interpreter's `executeSplice` was calling functions in SCALAR context, causing only one + value to be inserted instead of the full list. + - **Lexical sub + statement modifier:** Lexical subs (`my sub name`) now recognized as + function calls before statement modifier keywords (`if`, `unless`, `while`, `until`, + `for`, `foreach`, `when`). Previously, `quuux if 1` treated `quuux` as a bareword. + - **`tie(my(@arr), ...)` prototype parsing:** Backslash prototype `\[$@%*]` now correctly + handles parenthesized `my` declarations. `my(@bar)` produces + `OperatorNode("my", ListNode(OperatorNode("@")))` — the extra ListNode wrapper is + now unwrapped via `unwrapMyListDeclaration()` helper. + - **`return @tied_array` in eval STRING:** `materializeSpecialVarsInResult` was iterating + `arr.elements` directly (the empty ArrayList backing TieArray), bypassing FETCHSIZE/FETCH. + Now dispatches through `getList()` for tied arrays and hashes. + - Files: `CompileOperator.java`, `SubroutineParser.java`, `PrototypeArgs.java`, `RuntimeCode.java` + - Tests fixed: + - `Eval-TypeTiny/lexical-subs.t` (11/12 → 12/12) — lexical sub + statement modifier + - `Eval-TypeTiny/aliases-tie.t` (6/11 → 10/11) — tie prototype + return fix (remaining 1 is DESTROY) + - `Type-Tie/basic.t` (1/2 → 3/3) — tie on arrays now supported + - `Type-Tie/01basic.t` (15/17 → 17/17) — splice list context + - `Types-Standard/tied.t` (0/0 → 27/27) — tie on arrays now supported + - `Type-Library/exportables.t` (0/0 → 11/11) — resolved by eval require fix + - `Type-Library/exportables-duplicated.t` (0/1 → 1/1) — eval require fix + - `Type-Tiny-Enum/basic.t` (17/17 → 25/25) — unlocked more tests + - `Moo/basic.t` (4/5 → 5/5), `Moo/coercion.t` (9/19 → 19/19), + `Moo/exceptions.t` (13/15 → 15/15), `Moo/inflation.t` (9/11 → 11/11) + - `Moo/coercion-inlining-avoidance.t` (0/0 → 14/14), `v2-multi.t` (1/1 → 5/5) + +### Remaining Failing Test Files (after Phase 6) + +**Tests with actual subtest failures (5 files, 9 individual failures):** -**Tests with 0 subtests (9 files, missing features/deps):** +| Test | Result | Root Cause | +|------|--------|-----------| +| `Error-TypeTiny-Assertion/basic.t` | 28/29 | B::Deparse output differs (known limitation) | +| `Eval-TypeTiny/basic.t` | 11/12 | DESTROY not implemented (JVM GC) | +| `Eval-TypeTiny/aliases-tie.t` | 10/11 | DESTROY not implemented (JVM GC) | +| `Type-Tie/06clone.t` | 3/6 | Clone::PP doesn't preserve tie magic | +| `Type-Tie/06storable.t` | 3/6 | Storable::dclone doesn't preserve tie magic | + +**Tests with 0 subtests / skipped (23 `!` in runner, mostly CWD or missing deps):** | Test | Issue | |------|-------| | `Eval-TypeTiny/aliases-native.t` | `\$var = \$other` ref aliasing not supported | -| `Eval-TypeTiny/aliases-tie.t` | TIESCALAR not found (class loading issue) | -| `Type-Library/exportables.t` | `+Rainbow` sub not found (exporter edge case) | | `Type-Registry/lexical.t` | `builtin::export_lexically` not implemented | | `Type-Tiny-Enum/exporter_lexical.t` | `builtin::export_lexically` not implemented | | `Types-Standard/strmatch-allow-callbacks.t` | `(?{...})` code blocks in regex | | `Types-Standard/strmatch-avoid-callbacks.t` | `(?{...})` code blocks in regex | -| `Types-Standard/tied.t` | Unsupported variable type for `tie()` | -| `gh1.t` | Dies early | - -**Tests with actual subtest failures (6 files, 12 failures):** - -| Test | Result | Root Cause | -|------|--------|-----------| -| `Error-TypeTiny-Assertion/basic.t` | 28/29 | B::Deparse output differs | -| `Eval-TypeTiny/lexical-subs.t` | 11/12 | Lexical sub without parens returns bareword | -| `Type-Tie/01basic.t` | 15/17 | Tied array edge cases | -| `Type-Tie/06clone.t` | 3/6 | Clone::PP doesn't preserve tie magic | -| `Type-Tie/06storable.t` | 3/6 | Storable::dclone doesn't preserve tie magic | -| `Type-Tie/basic.t` | 1/2 | Unsupported tie on arrays | - -**Tests with runner flakiness (varies per run, ~5 Moo tests):** - -| Test | Best Result | Issue | -|------|-------------|-------| -| `Type-Library/exportables-duplicated.t` | 0/1 | `caller()` corruption after eval require | -| `Moo/basic.t` | 4/5 | Moo isa coercion | -| `Moo/coercion.t` | 9/19 | Moo coercion inlining | -| `Moo/exceptions.t` | 13/15 | Exception `->value` metadata | -| `Moo/inflation.t` | 9/11 | Moo → Moose inflation | -| `gh14.t` | 0/1 | Deep coercion edge case | +| `gh1.t` | Missing `Math::BigFloat` dependency | +| Various Type-Library/*, Type-Tiny-*/basic.t | Test runner CWD issue — pass when run from Type-Tiny dir | + +- [x] Phase 6b: Fix sprintf warnings, `local` restoration on `last`, spurious sprintf warning (2026-04-10) + - **sprintf/printf warnings fired unconditionally:** All sprintf/printf warnings + ("Invalid conversion", "Missing argument", "Redundant argument") used plain + `WarnDie.warn()` which always emits warnings. Changed to `WarnDie.warnWithCategory()` + with the `"printf"` category, matching Perl 5 behavior where these warnings only + fire under `use warnings` or `use warnings "printf"`. + - **`local` variable restoration on `last` exit (3 fixes):** + - JVM backend (EmitStatement.java): Added `Local.localSetup/localTeardown` wrapping + For3Node (while/for loops, bare blocks) so `last` exits that bypass the body block's + own cleanup still restore `local` variables. + - JVM backend (EmitControlFlow.java): Non-local `last`/`next`/`redo` now routes + through `returnLabel` instead of direct `ARETURN`, ensuring the subroutine's + `popToLocalLevel()` cleanup runs when `last LABEL` crosses subroutine boundaries + (e.g., test.pl's `sub skip { local $^W=0; last SKIP }`). + - Bytecode interpreter (BytecodeCompiler.java): Added `GET_LOCAL_LEVEL/POP_LOCAL_LEVEL` + wrapping For3Node for both bare blocks and while/for loops, matching the JVM backend. + - **Spurious sprintf "isn't numeric" warning:** `SprintfOperator.java` was calling + `getDouble()` on arbitrary string arguments when checking for Inf/NaN on invalid format + specifiers. Now only checks DOUBLE type values and known Inf/NaN string literals, + avoiding the spurious warning. + - Files: `SprintfOperator.java`, `WarnDie.java`, `EmitStatement.java`, + `EmitControlFlow.java`, `BytecodeCompiler.java` + - Test impact: `op/sprintf2.t` recovers 1 test (1651 → 1652), restoring baseline. + +### Remaining Issues from `./jcpan --jobs 8 -t Type::Tiny` + +| Issue | Impact | Details | +|-------|--------|---------| +| `builtin::export_lexically` | 2 tests | PerlOnJava reports `$]=5.042` so `Exporter::Tiny` takes the native lexical sub path, but `builtin::export_lexically` is not implemented. Affects `Type-Registry/lexical.t`, `Type-Tiny-Enum/exporter_lexical.t`. | +| `sprintf "%{"` warning | Cosmetic | Fixed in Phase 6b — warning now properly gated by `use warnings "printf"`. Not a test failure; `Types::Standard::Tied` has `use warnings` so the warning is correct but was previously also firing in no-warnings contexts. | +| `Math::BigFloat` missing | 1 test | Core Perl module not bundled with PerlOnJava. Only `t/40-bugs/gh1.t` requires it. Would need porting `Math::BigInt` + `Math::BigFloat` (large effort). | + +### Phase 7: Clone/Storable tie preservation (completed 2026-04-10) + +**Goal:** Fix `Type-Tie/06clone.t` (3/6 → 6/6) and `Type-Tie/06storable.t` (3/6 → 6/6). + +Both tests create tied variables via `Type::Tie`, clone them, and verify the clone +still enforces type constraints. Tests 2/4/6 failed because the clone lost tie magic. + +**7a. Replace custom Clone::PP with CPAN Clone::PP 1.08:** +- Replaced our custom 77-line `Clone/PP.pm` with CPAN Clone::PP 1.08. +- CPAN version handles ties, `clone_self` / `clone_init` hooks, depth limiting, and + circular reference detection. +- However, Clone::PP's tie handling is too simplistic for Type::Tie (it calls + `tie %$copy, ref $tied` without constructor arguments), so we also needed 7c. + +**7b. Fix Storable::dclone to handle tied variables:** +- `Storable.java` `deepClone()` now detects `TieHash`, `TieArray`, `TieScalar` backing. +- For tied hashes/arrays: deep-clones the handler object, creates a new Tie* wrapper, + and copies data through the tied interface (FETCH/STORE). +- For tied scalars: adds `TIED_SCALAR` case to clone the handler and re-tie. +- Fixed STORABLE_freeze/thaw hook to create the correct reference type (ARRAY vs HASH) + for the thaw object — Type::Tie::BASE is array-based, not hash-based. +- Files: `Storable.java` + +**7c. Create Java-based Clone module:** +- Created `Clone.java` as a proper Java XS implementation of `Clone::clone`. +- Handles tied hashes, tied arrays, tied scalars, blessed objects, circular references, + and depth limiting — equivalent to the XS Clone module. +- `Clone.pm` loads it via XSLoader (falls back to Clone::PP if unavailable). +- Files: `Clone.java` + +**Bundled tests added:** +- `src/test/resources/module/Clone-PP/t/` — 7 test files from CPAN Clone::PP 1.08 +- Type-Tie tests are run via `./jcpan -t Type::Tiny` (not bundled; Type::Tie is part of Type-Tiny CPAN dist) ### Next Steps -1. Address Tie-related failures (4 files, requires deeper tie infrastructure work) -2. Investigate `caller()` corruption after `eval require` (exportables-duplicated.t) -3. Investigate Moo coercion failures (5 test files) -4. Consider B::Deparse output compatibility (1 test) +1. Consider implementing scope-exit hooks for DESTROY (2 test files) +2. Consider B::Deparse output compatibility (1 test) +3. Fix test runner CWD handling for tests that reference `./lib`, `./t/lib` +4. Consider bundling `Math::BigFloat` / `Math::BigInt` (low priority, 1 test) +5. Consider implementing `builtin::export_lexically` (low priority, 2 tests) ### Open Questions -- `ArrayRef[Int] | HashRef` triggers `Can't call method "isa" on unblessed reference` - at Type/Tiny/Union.pm line 60 — separate runtime issue, not parser-related -- Test runner shows variable error counts (29-66 `!` errors) due to parallel JVM startup - contention — actual failures are consistent across runs +- The 23 `!` errors in the test runner are mostly CWD-related: tests use `./lib` and `./t/lib` + which require running from the Type-Tiny distribution directory +- All 5 Moo tests pass when run from the correct CWD +- `builtin::export_lexically` would require lexical scoping machinery — complex to implement properly --- diff --git a/src/main/java/org/perlonjava/backend/bytecode/BytecodeCompiler.java b/src/main/java/org/perlonjava/backend/bytecode/BytecodeCompiler.java index f8222e5a0..c87d64325 100644 --- a/src/main/java/org/perlonjava/backend/bytecode/BytecodeCompiler.java +++ b/src/main/java/org/perlonjava/backend/bytecode/BytecodeCompiler.java @@ -5326,6 +5326,17 @@ public void visit(For3Node node) { emitInt(0); } + // Save local variable level so that `last` exits restore `local` variables. + // The body's BlockNode has its own GET_LOCAL_LEVEL/POP_LOCAL_LEVEL, but `last` + // bypasses the body's POP_LOCAL_LEVEL. This outer pair catches that case. + // On normal exit, the body already restored locals, so this is a no-op. + int blockLocalLevelReg = -1; + if (FindDeclarationVisitor.containsLocalOrDefer(node)) { + blockLocalLevelReg = allocateRegister(); + emit(Opcodes.GET_LOCAL_LEVEL); + emitReg(blockLocalLevelReg); + } + // Push loop info so that redo/next/last inside bare blocks work // (Perl 5 allows redo/next/last in bare blocks) // Unlabeled bare blocks are targets for unlabeled redo/next/last; @@ -5372,8 +5383,14 @@ public void visit(For3Node node) { patchJump(exitPcPlaceholder, exitPc); } - // Patch last (break) PCs to jump past the block + // Patch last (break) PCs to jump to local cleanup (or past the block if no locals). + // POP_LOCAL_LEVEL must be at endPc so `last` runs it. + // On normal exit this is a no-op since the body's POP_LOCAL_LEVEL already ran. int endPc = bytecode.size(); + if (blockLocalLevelReg >= 0) { + emit(Opcodes.POP_LOCAL_LEVEL); + emitReg(blockLocalLevelReg); + } for (int pc2 : loopInfo.breakPcs) { patchJump(pc2, endPc); } @@ -5394,6 +5411,17 @@ public void visit(For3Node node) { node.initialization.accept(this); } + // Save local variable level so that `last` exits restore `local` variables. + // The body's BlockNode has its own GET_LOCAL_LEVEL/POP_LOCAL_LEVEL, but `last` + // bypasses the body's POP_LOCAL_LEVEL. This outer pair catches that case. + // On normal exit, the body already restored locals, so POP_LOCAL_LEVEL is a no-op. + int for3LocalLevelReg = -1; + if (FindDeclarationVisitor.containsLocalOrDefer(node)) { + for3LocalLevelReg = allocateRegister(); + emit(Opcodes.GET_LOCAL_LEVEL); + emitReg(for3LocalLevelReg); + } + // Step 2: Push loop info onto stack for last/next/redo int loopStartPc = bytecode.size(); // do-while is NOT a true loop (can't use last/next/redo); while/for are true loops @@ -5497,8 +5525,14 @@ public void visit(For3Node node) { emitInt(loopStartPc); } - // Step 10: Loop end - patch the forward jump (last jumps here) + // Step 10: Loop end - restore local variables and patch jumps. + // POP_LOCAL_LEVEL must be at loopEndPc so `last` runs it. + // On normal exit (condition false) this is a no-op since the body already cleaned up. int loopEndPc = bytecode.size(); + if (for3LocalLevelReg >= 0) { + emit(Opcodes.POP_LOCAL_LEVEL); + emitReg(for3LocalLevelReg); + } if (loopEndJumpPc != -1) { patchJump(loopEndJumpPc, loopEndPc); } diff --git a/src/main/java/org/perlonjava/backend/bytecode/CompileOperator.java b/src/main/java/org/perlonjava/backend/bytecode/CompileOperator.java index b93ead591..5e16193d4 100644 --- a/src/main/java/org/perlonjava/backend/bytecode/CompileOperator.java +++ b/src/main/java/org/perlonjava/backend/bytecode/CompileOperator.java @@ -1174,12 +1174,17 @@ private static void visitSplice(BytecodeCompiler bc, OperatorNode node) { if (!arrayOp.operator.equals("@")) bc.throwCompilerException("splice requires array variable: splice @array, ..."); int arrayReg = resolveArrayOperand(bc, new OperatorNode("splice", arrayOp, node.tokenIndex), "splice"); List argRegs = new ArrayList<>(); + // Compile splice arguments in LIST context so replacement values + // (after offset and length) are properly flattened. + int savedCtx = bc.currentCallContext; + bc.currentCallContext = RuntimeContextType.LIST; for (int i = 1; i < list.elements.size(); i++) { list.elements.get(i).accept(bc); argRegs.add(bc.lastResultReg); } + bc.currentCallContext = savedCtx; int argsListReg = bc.allocateRegister(); bc.emit(Opcodes.CREATE_LIST); bc.emitReg(argsListReg); bc.emit(argRegs.size()); for (int argReg : argRegs) bc.emitReg(argReg); int rd = bc.allocateOutputRegister(); - bc.emit(Opcodes.SPLICE); bc.emitReg(rd); bc.emitReg(arrayReg); bc.emitReg(argsListReg); bc.emit(bc.currentCallContext); + bc.emit(Opcodes.SPLICE); bc.emitReg(rd); bc.emitReg(arrayReg); bc.emitReg(argsListReg); bc.emit(savedCtx); bc.lastResultReg = rd; } diff --git a/src/main/java/org/perlonjava/backend/bytecode/OpcodeHandlerExtended.java b/src/main/java/org/perlonjava/backend/bytecode/OpcodeHandlerExtended.java index 91e81e872..63ecd1094 100644 --- a/src/main/java/org/perlonjava/backend/bytecode/OpcodeHandlerExtended.java +++ b/src/main/java/org/perlonjava/backend/bytecode/OpcodeHandlerExtended.java @@ -299,18 +299,18 @@ public static int executeStringConcatAssign(int[] bytecode, int pc, RuntimeBase[ } RuntimeScalar target = (RuntimeScalar) registers[rd]; // Remember if target was BYTE_STRING before concatenation. - // In PerlOnJava, "upgrading" from BYTE_STRING to STRING doesn't change bytes - // (unlike Perl where bytes > 127 get re-encoded), so we preserve BYTE_STRING - // in .= to prevent false UTF-8 flag contamination of binary buffers. + // Only preserve BYTE_STRING when the concat result itself is BYTE_STRING + // (both operands were non-UTF-8). When concat produces STRING (at least + // one operand was UTF-8), preserve the UTF-8 flag per Perl semantics. boolean wasByteString = (target.type == RuntimeScalarType.BYTE_STRING); RuntimeScalar result = StringOperators.stringConcat( target, (RuntimeScalar) registers[rs] ); target.set(result); - // Preserve BYTE_STRING type when the target was byte string and the result - // still fits in Latin-1 (all chars <= 255) - if (wasByteString && target.type == RuntimeScalarType.STRING) { + // Preserve BYTE_STRING type only when both the target was byte string AND + // the concat result was also byte string (meaning the RHS was also non-UTF-8) + if (wasByteString && result.type == RuntimeScalarType.BYTE_STRING && target.type == RuntimeScalarType.STRING) { String s = target.toString(); boolean fits = true; for (int i = 0; i < s.length(); i++) { diff --git a/src/main/java/org/perlonjava/backend/jvm/EmitControlFlow.java b/src/main/java/org/perlonjava/backend/jvm/EmitControlFlow.java index 3bb64fe4d..85f6103e1 100644 --- a/src/main/java/org/perlonjava/backend/jvm/EmitControlFlow.java +++ b/src/main/java/org/perlonjava/backend/jvm/EmitControlFlow.java @@ -126,8 +126,15 @@ static void handleNextOperator(EmitterContext ctx, OperatorNode node) { "(Lorg/perlonjava/runtime/runtimetypes/ControlFlowType;Ljava/lang/String;Ljava/lang/String;I)V", false); - // Return the tagged list (will be detected at subroutine return boundary) - ctx.mv.visitInsn(Opcodes.ARETURN); + // Return the tagged list via returnLabel so that local variable teardown + // (popToLocalLevel) runs before the method exits. A direct ARETURN would + // bypass the cleanup at returnLabel, leaving `local` variables un-restored. + if (ctx.javaClassInfo.returnLabel != null) { + ctx.mv.visitVarInsn(Opcodes.ASTORE, ctx.javaClassInfo.returnValueSlot); + ctx.mv.visitJumpInsn(Opcodes.GOTO, ctx.javaClassInfo.returnLabel); + } else { + ctx.mv.visitInsn(Opcodes.ARETURN); + } return; } diff --git a/src/main/java/org/perlonjava/backend/jvm/EmitStatement.java b/src/main/java/org/perlonjava/backend/jvm/EmitStatement.java index 0d7a78937..42c8b058c 100644 --- a/src/main/java/org/perlonjava/backend/jvm/EmitStatement.java +++ b/src/main/java/org/perlonjava/backend/jvm/EmitStatement.java @@ -277,6 +277,13 @@ public static void emitFor3(EmitterVisitor emitterVisitor, For3Node node) { node.initialization.accept(voidVisitor); } + // Set up local variable cleanup for the loop/block scope. + // This ensures that `local` variables are restored when exiting via `last`, + // which jumps to endLabel and bypasses the body block's own localTeardown. + // This mirrors EmitForeach.emitFor1() which has an outer localSetup/localTeardown + // wrapping the loop body with teardown AFTER the loopEnd label. + Local.localRecord for3LocalRecord = Local.localSetup(emitterVisitor.ctx, node, mv, true); + // For while/for loops in non-void context, allocate a register to save // the condition value so the false condition is returned on normal exit. boolean needWhileConditionResult = !node.isSimpleBlock @@ -408,6 +415,10 @@ public static void emitFor3(EmitterVisitor emitterVisitor, For3Node node) { "org/perlonjava/runtime/runtimetypes/RegexState", "restore", "()V", false); } + // Restore local variables that were saved before the loop/block. + // This catches `last` exits which bypass the body block's own localTeardown. + Local.localTeardown(for3LocalRecord, mv); + // Exit the scope in the symbol table if (node.useNewScope) { emitScopeExitNullStores(emitterVisitor.ctx, scopeIndex); diff --git a/src/main/java/org/perlonjava/core/Configuration.java b/src/main/java/org/perlonjava/core/Configuration.java index c4c76eb5a..2befd81f4 100644 --- a/src/main/java/org/perlonjava/core/Configuration.java +++ b/src/main/java/org/perlonjava/core/Configuration.java @@ -33,7 +33,7 @@ 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 = "c6ee04074"; + public static final String gitCommitId = "ab863e968"; /** * Git commit date of the build (ISO format: YYYY-MM-DD). @@ -48,7 +48,7 @@ public final class Configuration { * Parsed by App::perlbrew and other tools via: perl -V | grep "Compiled at" * DO NOT EDIT MANUALLY - this value is replaced at build time. */ - public static final String buildTimestamp = "Apr 10 2026 13:40:40"; + public static final String buildTimestamp = "Apr 10 2026 18:40:15"; // Prevent instantiation private Configuration() { diff --git a/src/main/java/org/perlonjava/frontend/parser/PrototypeArgs.java b/src/main/java/org/perlonjava/frontend/parser/PrototypeArgs.java index d553256d6..152b69c4d 100644 --- a/src/main/java/org/perlonjava/frontend/parser/PrototypeArgs.java +++ b/src/main/java/org/perlonjava/frontend/parser/PrototypeArgs.java @@ -723,6 +723,35 @@ private static void handlePlusArgument(Parser parser, ListNode args, boolean isO } } + /** + * Unwraps my(@array) and my(%hash) declarations for backslash prototypes. + * + *

When Perl parses {@code tie(my(@bar), "Class")}, the {@code my(@bar)} produces + * an AST like {@code OperatorNode("my", ListNode(OperatorNode("@")))}. + * For the backslash prototype {@code \[$@%*]}, we need the same result as + * {@code tie(my @bar, "Class")} which produces {@code OperatorNode("my", OperatorNode("@"))}. + * This method unwraps the extra ListNode so the {@code \} operator correctly creates + * an ARRAYREFERENCE or HASHREFERENCE.

+ * + * @param arg The argument node to potentially unwrap + * @return The unwrapped node if applicable, or the original node + */ + private static Node unwrapMyListDeclaration(Node arg) { + // Check if arg is my/our/local with a ListNode operand containing a single array/hash + if (!(arg instanceof OperatorNode myOp)) return arg; + if (!myOp.operator.equals("my") && !myOp.operator.equals("our") && !myOp.operator.equals("local")) return arg; + if (!(myOp.operand instanceof ListNode listNode)) return arg; + if (listNode.elements.size() != 1) return arg; + + Node element = listNode.elements.get(0); + if (element instanceof OperatorNode varOp && + (varOp.operator.equals("@") || varOp.operator.equals("%") || varOp.operator.equals("*"))) { + // Unwrap: my(ListNode(@bar)) → my(@bar) + myOp.operand = element; + } + return arg; + } + /** * Unwraps unary plus from expressions like +(%hash) or +(@array) for backslash prototypes. * In Perl, +() is used for disambiguation but should be transparent for \% and \@ prototypes. @@ -817,6 +846,12 @@ private static int handleBackslashArgument(Parser parser, ListNode args, String // Handle +(%hash) and +(@array) constructs for \% and \@ prototypes // The unary + is used for disambiguation but should be transparent for prototypes referenceArg = unwrapUnaryPlus(referenceArg, refType); + + // Handle my(@array) and my(%hash) for backslash prototypes. + // When my(@bar) is parsed, it creates OperatorNode("my", ListNode(OperatorNode("@"))) + // but \my(@bar) should produce an ARRAYREFERENCE, same as \my @bar. + // Unwrap the ListNode so we get OperatorNode("my", OperatorNode("@")). + referenceArg = unwrapMyListDeclaration(referenceArg); // For \& prototype, check for invalid forms like &foo(), foo(), or bareword foo if (refType == '&') { String subName = parser.ctx.symbolTable.getCurrentSubroutine(); diff --git a/src/main/java/org/perlonjava/frontend/parser/SubroutineParser.java b/src/main/java/org/perlonjava/frontend/parser/SubroutineParser.java index a785ca051..4afb66386 100644 --- a/src/main/java/org/perlonjava/frontend/parser/SubroutineParser.java +++ b/src/main/java/org/perlonjava/frontend/parser/SubroutineParser.java @@ -88,12 +88,14 @@ static Node parseSubroutineCall(Parser parser, boolean isMethod) { // 1. There are explicit parentheses, OR // 2. There's a prototype, OR // 3. The next token isn't a bareword identifier (to avoid indirect method call confusion), OR - // 4. We're parsing a code reference for sort/map/grep (parsingForLoopVariable is true) + // 4. We're parsing a code reference for sort/map/grep (parsingForLoopVariable is true), OR + // 5. The next token is a statement modifier keyword (if/unless/while/until/for/foreach/when) boolean useExplicitParen = nextToken.text.equals("("); boolean hasPrototype = lexicalPrototype != null; boolean nextIsIdentifier = nextToken.type == LexerTokenType.IDENTIFIER; + boolean nextIsStatementModifier = nextIsIdentifier && isStatementModifierKeyword(nextToken.text); - if (useExplicitParen || hasPrototype || !nextIsIdentifier || parser.parsingForLoopVariable) { + if (useExplicitParen || hasPrototype || !nextIsIdentifier || nextIsStatementModifier || parser.parsingForLoopVariable) { // This is a lexical sub/method - use the hidden variable instead of package lookup // The varNode is the "my $name__lexsub_123" or "my $name__lexmethod_123" variable @@ -238,15 +240,17 @@ static Node parseSubroutineCall(Parser parser, boolean isMethod) { // 1. Explicitly marked as non-package (false in cache), OR // 2. Unknown package (null) AND unknown subroutine (!isKnownSub) AND followed by '(' // AND name is not package-qualified (no ::) - this is a function call like mycan(...) + // 3. Calling sub exists AND qualified name with '()' AND NOT a known package + // — then it's a function call like: is MojoMonkeyTest::bar(), "bar" + // But if the qualified name IS a known package (isPackage==true), treat as + // indirect object: new LWP::UserAgent() → LWP::UserAgent->new() // Allow if: // - Marked as package (true), OR // - Unknown (null) but NOT followed by '(' - like 'new NonExistentClass' - // - Name contains '::' (qualified names are always treated as packages in indirect syntax) - // UNLESS the calling sub exists and it's followed by '(' — then it's a function call - // like: is MojoMonkeyTest::bar(), "bar" (per perlobj: declared functions take precedence) if ((isPackage != null && !isPackage) || (isPackage == null && !isKnownSub && token.text.equals("(") && !packageName.contains("::")) - || (subExists && packageName.contains("::") && token.text.equals("("))) { + || (subExists && packageName.contains("::") && token.text.equals("(") + && !(isPackage != null && isPackage))) { parser.tokenIndex = currentIndex2; } else { // Not a known subroutine, check if it's valid indirect object syntax @@ -1486,4 +1490,16 @@ static void emitIllegalProtoWarning(Parser parser, String proto, String subDispl Warnings.warnWithCategory("illegalproto", msg, loc); } } + + /** + * Checks if a token text is a statement modifier keyword. + * These keywords cannot start an indirect method call, so a lexical sub + * followed by one of these should be treated as a function call. + */ + private static boolean isStatementModifierKeyword(String text) { + return switch (text) { + case "if", "unless", "while", "until", "for", "foreach", "when" -> true; + default -> false; + }; + } } diff --git a/src/main/java/org/perlonjava/runtime/operators/Operator.java b/src/main/java/org/perlonjava/runtime/operators/Operator.java index 50d17bf1e..75fd8c159 100644 --- a/src/main/java/org/perlonjava/runtime/operators/Operator.java +++ b/src/main/java/org/perlonjava/runtime/operators/Operator.java @@ -231,8 +231,11 @@ public static RuntimeList split(RuntimeScalar quotedRegex, RuntimeList args, int } } - // Preserve BYTE_STRING type: if input was BYTE_STRING, all split results should be too - if (string.type == RuntimeScalarType.BYTE_STRING) { + // Preserve UTF-8 flag semantics: split results should only have the UTF-8 flag + // (STRING type) if the input string had it. When input is BYTE_STRING, INTEGER, + // DOUBLE, UNDEF, etc., the results should be BYTE_STRING (no UTF-8 flag). + // This matches Perl's behavior where split doesn't spontaneously add UTF-8 flag. + if (string.type != RuntimeScalarType.STRING) { for (RuntimeBase element : splitElements) { if (element instanceof RuntimeScalar rs && rs.type == RuntimeScalarType.STRING) { rs.type = RuntimeScalarType.BYTE_STRING; diff --git a/src/main/java/org/perlonjava/runtime/operators/SprintfOperator.java b/src/main/java/org/perlonjava/runtime/operators/SprintfOperator.java index 7a628a987..b6d0dcd17 100644 --- a/src/main/java/org/perlonjava/runtime/operators/SprintfOperator.java +++ b/src/main/java/org/perlonjava/runtime/operators/SprintfOperator.java @@ -108,8 +108,21 @@ private static RuntimeScalar sprintfInternal(RuntimeScalar runtimeScalar, Runtim // even though %lld is invalid on 32-bit Perl. if (argIndex < list.size()) { RuntimeScalar value = (RuntimeScalar) list.elements.get(argIndex); - double doubleValue = value.getDouble(); - if (Double.isInfinite(doubleValue) || Double.isNaN(doubleValue)) { + // Only check for Inf/NaN on numeric types or known Inf/NaN strings. + // Calling getDouble() on arbitrary strings would trigger a spurious + // "Argument isn't numeric" warning. + boolean isInfNan = false; + if (value.type == RuntimeScalarType.DOUBLE) { + double d = (double) value.value; + isInfNan = Double.isInfinite(d) || Double.isNaN(d); + } else if (value.type == RuntimeScalarType.STRING || value.type == RuntimeScalarType.BYTE_STRING) { + String s = ((String) value.value).trim(); + isInfNan = s.equalsIgnoreCase("inf") || s.equalsIgnoreCase("infinity") + || s.equalsIgnoreCase("-inf") || s.equalsIgnoreCase("-infinity") + || s.equalsIgnoreCase("nan"); + } + if (isInfNan) { + double doubleValue = value.getDouble(); SprintfNumericFormatter numFmt = new SprintfNumericFormatter(); String formatted = numFmt.formatSpecialValue(doubleValue, spec.flags, spec.width != null ? spec.width : 0, spec.conversionChar); @@ -201,7 +214,7 @@ private static RuntimeScalar sprintfInternal(RuntimeScalar runtimeScalar, Runtim if (!hasPositionalParameter && !hasInvalidSpecifier && list.size() > 0 && ((hasValidSpecifier && maxArgIndexUsed >= 0 && maxArgIndexUsed + 1 < list.size()) || (!hasValidSpecifier && maxArgIndexUsed == -1))) { - WarnDie.warn(new RuntimeScalar("Redundant argument in sprintf"), new RuntimeScalar("")); + WarnDie.warnWithCategory(new RuntimeScalar("Redundant argument in sprintf"), new RuntimeScalar(""), "printf"); } RuntimeScalar res = new RuntimeScalar(result.toString()); @@ -542,8 +555,8 @@ private static FormatArguments extractFormatArguments( throw new PerlCompilerException("Integer overflow in format string for sprintf "); } } else { - WarnDie.warn(new RuntimeScalar("Missing argument in sprintf"), - new RuntimeScalar("")); + WarnDie.warnWithCategory(new RuntimeScalar("Missing argument in sprintf"), + new RuntimeScalar(""), "printf"); } } else if (spec.width != null) { args.width = spec.width; @@ -587,8 +600,8 @@ private static FormatArguments extractFormatArguments( throw new PerlCompilerException("Integer overflow in format string for sprintf "); } } else { - WarnDie.warn(new RuntimeScalar("Missing argument in sprintf"), - new RuntimeScalar("")); + WarnDie.warnWithCategory(new RuntimeScalar("Missing argument in sprintf"), + new RuntimeScalar(""), "printf"); } } else if (spec.precision != null) { args.precision = spec.precision; @@ -669,7 +682,7 @@ private static String handleInvalidSpecifier(FormatSpecifier spec) { String warningMessage = "Invalid conversion in sprintf: \"" + formatForWarning + "\""; // - WarnDie.warn(new RuntimeScalar(warningMessage), new RuntimeScalar("")); + WarnDie.warnWithCategory(new RuntimeScalar(warningMessage), new RuntimeScalar(""), "printf"); } // Don't consume any arguments for invalid specifiers @@ -683,7 +696,7 @@ private static String handleInvalidSpecifier(FormatSpecifier spec) { private static String handleMissingArgument(FormatSpecifier spec, FormatArguments args) { // Generate warning - WarnDie.warn(new RuntimeScalar("Missing argument in sprintf"), new RuntimeScalar("")); + WarnDie.warnWithCategory(new RuntimeScalar("Missing argument in sprintf"), new RuntimeScalar(""), "printf"); // Special handling for vector formats if (spec.vectorFlag) { diff --git a/src/main/java/org/perlonjava/runtime/operators/WarnDie.java b/src/main/java/org/perlonjava/runtime/operators/WarnDie.java index 8a75e7c1e..c18df58fd 100644 --- a/src/main/java/org/perlonjava/runtime/operators/WarnDie.java +++ b/src/main/java/org/perlonjava/runtime/operators/WarnDie.java @@ -241,6 +241,7 @@ public static RuntimeBase warnWithCategory(RuntimeBase message, RuntimeScalar wh if (warningBits == null) { warningBits = org.perlonjava.runtime.WarningBitsRegistry.getCurrent(); } + // If warning bits are available, check if this category is enabled if (warningBits != null) { diff --git a/src/main/java/org/perlonjava/runtime/perlmodule/Clone.java b/src/main/java/org/perlonjava/runtime/perlmodule/Clone.java new file mode 100644 index 000000000..9af638bf7 --- /dev/null +++ b/src/main/java/org/perlonjava/runtime/perlmodule/Clone.java @@ -0,0 +1,174 @@ +package org.perlonjava.runtime.perlmodule; + +import org.perlonjava.runtime.operators.ReferenceOperators; +import org.perlonjava.runtime.runtimetypes.*; + +import java.util.IdentityHashMap; + +/** + * Java implementation of Clone module for PerlOnJava. + *

+ * Provides deep cloning that properly handles tied variables, blessed objects, + * and circular references — equivalent to the XS Clone module's behavior. + */ +public class Clone extends PerlModuleBase { + + public Clone() { + super("Clone", false); + } + + public static void initialize() { + Clone module = new Clone(); + try { + module.registerMethod("clone", null); + } catch (NoSuchMethodException e) { + System.err.println("Warning: Missing Clone method: " + e.getMessage()); + } + module.defineExport("EXPORT_OK", "clone"); + } + + /** + * Deep clone a Perl data structure. + *

+ * clone($ref) - deep clone + * clone($ref, $depth) - clone with depth limit (0 = shallow) + */ + public static RuntimeList clone(RuntimeArray args, int ctx) { + if (args.isEmpty()) { + return new RuntimeScalar().getList(); + } + + RuntimeScalar source = args.get(0); + int depth = args.size() > 1 ? args.get(1).getInt() : -1; // -1 = unlimited + + if (source == null || source.type == RuntimeScalarType.UNDEF) { + return new RuntimeScalar().getList(); + } + + IdentityHashMap cloned = new IdentityHashMap<>(); + RuntimeScalar result = deepClone(source, cloned, depth); + return result.getList(); + } + + /** + * Recursively deep-clones a RuntimeScalar, handling circular references, + * tied variables, and blessed objects. + */ + private static RuntimeScalar deepClone(RuntimeScalar scalar, IdentityHashMap cloned, int depth) { + if (scalar == null) return new RuntimeScalar(); + + // Depth limit: 0 means return as-is (shared) + if (depth == 0) return scalar; + int nextDepth = depth > 0 ? depth - 1 : depth; + + // Check for already-cloned references (circular reference handling) + if (scalar.value != null && cloned.containsKey(scalar.value)) { + return cloned.get(scalar.value); + } + + int blessId = RuntimeScalarType.blessedId(scalar); + + return switch (scalar.type) { + case RuntimeScalarType.HASHREFERENCE -> { + RuntimeHash origHash = (RuntimeHash) scalar.value; + RuntimeHash newHash = new RuntimeHash(); + RuntimeScalar newRef = newHash.createReference(); + cloned.put(scalar.value, newRef); + + // Preserve blessing + if (blessId != 0) { + String className = NameNormalizer.getBlessStr(blessId); + ReferenceOperators.bless(newRef, new RuntimeScalar(className)); + } + + // Check for tied hash — preserve tie magic + if (origHash.type == RuntimeHash.TIED_HASH && origHash.elements instanceof TieHash tieHash) { + RuntimeScalar clonedSelf = deepClone(tieHash.getSelf(), cloned, nextDepth); + RuntimeHash previousValue = new RuntimeHash(); + newHash.type = RuntimeHash.TIED_HASH; + newHash.elements = new TieHash(tieHash.getTiedPackage(), previousValue, clonedSelf); + // Copy data through the tied interface + RuntimeScalar firstKey = TieHash.tiedFirstKey(origHash); + while (firstKey.type != RuntimeScalarType.UNDEF) { + RuntimeScalar val = TieHash.tiedFetch(origHash, firstKey); + TieHash.tiedStore(newHash, firstKey, deepClone(val, cloned, nextDepth)); + firstKey = TieHash.tiedNextKey(origHash, firstKey); + } + } else { + origHash.elements.forEach((key, value) -> + newHash.put(key, deepClone(value, cloned, nextDepth))); + } + yield newRef; + } + case RuntimeScalarType.ARRAYREFERENCE -> { + RuntimeArray origArray = (RuntimeArray) scalar.value; + RuntimeArray newArray = new RuntimeArray(); + RuntimeScalar newRef = newArray.createReference(); + cloned.put(scalar.value, newRef); + + // Preserve blessing + if (blessId != 0) { + String className = NameNormalizer.getBlessStr(blessId); + ReferenceOperators.bless(newRef, new RuntimeScalar(className)); + } + + // Check for tied array — preserve tie magic + if (origArray.type == RuntimeArray.TIED_ARRAY && origArray.elements instanceof TieArray tieArray) { + RuntimeScalar clonedSelf = deepClone(tieArray.getSelf(), cloned, nextDepth); + RuntimeArray previousValue = new RuntimeArray(); + newArray.type = RuntimeArray.TIED_ARRAY; + newArray.elements = new TieArray(tieArray.getTiedPackage(), previousValue, clonedSelf, newArray); + int size = TieArray.tiedFetchSize(origArray).getInt(); + for (int i = 0; i < size; i++) { + RuntimeScalar val = TieArray.tiedFetch(origArray, new RuntimeScalar(i)); + TieArray.tiedStore(newArray, new RuntimeScalar(i), deepClone(val, cloned, nextDepth)); + } + } else { + for (RuntimeScalar element : origArray.elements) { + newArray.elements.add(deepClone(element, cloned, nextDepth)); + } + } + yield newRef; + } + case RuntimeScalarType.REFERENCE -> { + RuntimeScalar origValue = (RuntimeScalar) scalar.value; + RuntimeScalar newValue = deepClone(origValue, cloned, nextDepth); + RuntimeScalar newRef = newValue.createReference(); + cloned.put(scalar.value, newRef); + + if (blessId != 0) { + String className = NameNormalizer.getBlessStr(blessId); + ReferenceOperators.bless(newRef, new RuntimeScalar(className)); + } + yield newRef; + } + case RuntimeScalarType.CODE -> { + // CODE refs are shared, not cloned + yield scalar; + } + case RuntimeScalarType.READONLY_SCALAR -> deepClone((RuntimeScalar) scalar.value, cloned, nextDepth); + case RuntimeScalarType.TIED_SCALAR -> { + if (scalar.value instanceof TieScalar tieScalar) { + RuntimeScalar clonedSelf = deepClone(tieScalar.getSelf(), cloned, nextDepth); + RuntimeScalar prevValue = new RuntimeScalar(); + prevValue.set(tieScalar.tiedFetch()); + RuntimeScalar copy = new RuntimeScalar(); + copy.type = RuntimeScalarType.TIED_SCALAR; + copy.value = new TieScalar(tieScalar.getTiedPackage(), prevValue, clonedSelf); + yield copy; + } else { + RuntimeScalar copy = new RuntimeScalar(); + copy.set(scalar); + yield copy; + } + } + default -> { + // Scalar values (int, double, string, undef) — just copy + RuntimeScalar copy = new RuntimeScalar(); + copy.type = scalar.type; + copy.value = scalar.value; + yield copy; + } + }; + } +} diff --git a/src/main/java/org/perlonjava/runtime/perlmodule/Storable.java b/src/main/java/org/perlonjava/runtime/perlmodule/Storable.java index 7b4d10202..fce85952e 100644 --- a/src/main/java/org/perlonjava/runtime/perlmodule/Storable.java +++ b/src/main/java/org/perlonjava/runtime/perlmodule/Storable.java @@ -535,9 +535,16 @@ private static RuntimeScalar deepClone(RuntimeScalar scalar, IdentityHashMap 0) { - // Create a new empty blessed object of the same class - RuntimeHash newHash = new RuntimeHash(); - RuntimeScalar newObj = newHash.createReference(); + // Create a new empty blessed object of the same reference type as the original + RuntimeScalar newObj; + if (scalar.type == RuntimeScalarType.ARRAYREFERENCE) { + newObj = new RuntimeArray().createReference(); + } else if (scalar.type == RuntimeScalarType.REFERENCE) { + newObj = new RuntimeScalar().createReference(); + } else { + // Default to hash reference (most common case) + newObj = new RuntimeHash().createReference(); + } ReferenceOperators.bless(newObj, new RuntimeScalar(className)); cloned.put(scalar.value, newObj); @@ -578,9 +585,28 @@ private static RuntimeScalar deepClone(RuntimeScalar scalar, IdentityHashMap - newHash.put(key, deepClone(value, cloned))); + // Check for tied hash — preserve tie magic + if (origHash.type == RuntimeHash.TIED_HASH && origHash.elements instanceof TieHash tieHash) { + // Deep-clone the tie handler object + RuntimeScalar clonedSelf = deepClone(tieHash.getSelf(), cloned); + // Deep-clone the underlying data via FETCH iteration + RuntimeHash previousValue = new RuntimeHash(); + // Create new TieHash with cloned handler + newHash.type = RuntimeHash.TIED_HASH; + newHash.elements = new TieHash(tieHash.getTiedPackage(), previousValue, clonedSelf); + // Copy the data through the tied interface (STORE calls) + // Iterate original hash via FIRSTKEY/NEXTKEY and FETCH each value + RuntimeScalar firstKey = TieHash.tiedFirstKey(origHash); + while (firstKey.type != RuntimeScalarType.UNDEF) { + RuntimeScalar val = TieHash.tiedFetch(origHash, firstKey); + TieHash.tiedStore(newHash, firstKey, deepClone(val, cloned)); + firstKey = TieHash.tiedNextKey(origHash, firstKey); + } + } else { + // Regular (untied) hash: deep-clone each value + origHash.elements.forEach((key, value) -> + newHash.put(key, deepClone(value, cloned))); + } yield newRef; } case RuntimeScalarType.ARRAYREFERENCE -> { @@ -595,9 +621,25 @@ private static RuntimeScalar deepClone(RuntimeScalar scalar, IdentityHashMap deepClone((RuntimeScalar) scalar.value, cloned); + case RuntimeScalarType.TIED_SCALAR -> { + // Tied scalar: deep-clone the handler and re-tie + if (scalar.value instanceof TieScalar tieScalar) { + RuntimeScalar clonedSelf = deepClone(tieScalar.getSelf(), cloned); + // Fetch the current value through the tie to initialize the previous value + RuntimeScalar prevValue = new RuntimeScalar(); + prevValue.set(tieScalar.tiedFetch()); + // Create a new tied scalar with the cloned handler + RuntimeScalar copy = new RuntimeScalar(); + copy.type = RuntimeScalarType.TIED_SCALAR; + copy.value = new TieScalar(tieScalar.getTiedPackage(), prevValue, clonedSelf); + yield copy; + } else { + // Fallback: just copy the fetched value + RuntimeScalar copy = new RuntimeScalar(); + copy.set(scalar); + yield copy; + } + } default -> { // Scalar values (int, double, string, undef) — just copy RuntimeScalar copy = new RuntimeScalar(); diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeArrayProxyEntry.java b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeArrayProxyEntry.java index 8969080e0..28b9cb214 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeArrayProxyEntry.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeArrayProxyEntry.java @@ -30,6 +30,26 @@ public RuntimeArrayProxyEntry(RuntimeArray parent, int key) { // Note: this.type is RuntimeScalarType.UNDEF } + /** + * Creates a reference to the underlying lvalue, vivifying it first. + * In Perl, \$arr[$i] auto-vivifies the array element so that the reference + * points to the actual array element, not a temporary. + * Checks for existing elements first to avoid overwriting tied or special elements. + */ + @Override + public RuntimeScalar createReference() { + if (lvalue == null) { + // Check if the element already exists (e.g., a tied scalar) + List elements = parent.elements; + if (key >= 0 && key < elements.size() && elements.get(key) != null) { + lvalue = elements.get(key); + } else { + vivify(); + } + } + return lvalue.createReference(); + } + /** * Vivifies (initializes) the element in the parent array if it does not exist. * If the element at the specified index is not present, it creates new diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeCode.java b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeCode.java index bf34c2905..58b08ee7d 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeCode.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeCode.java @@ -2787,19 +2787,32 @@ public static void materializeSpecialVarsInResult(RuntimeList result) { elems.set(i, concrete); } else if (elem instanceof RuntimeArray arr) { // Copy array elements to ensure independence from local restoration. - // Replace the RuntimeArray reference with a new RuntimeArray containing copies. - RuntimeArray copy = new RuntimeArray(); - for (RuntimeScalar arrElem : arr.elements) { - copy.elements.add(arrElem == null ? null : new RuntimeScalar(arrElem)); + // For tied arrays, use getList() which dispatches through FETCHSIZE/FETCH, + // since TieArray.elements (the ArrayList) is empty — data lives in the tied object. + // For regular arrays, copy elements directly. + if (arr.type == RuntimeArray.TIED_ARRAY) { + RuntimeList arrList = arr.getList(); + elems.set(i, arrList); + } else { + RuntimeArray copy = new RuntimeArray(); + for (RuntimeScalar arrElem : arr.elements) { + copy.elements.add(arrElem == null ? null : new RuntimeScalar(arrElem)); + } + elems.set(i, copy); } - elems.set(i, copy); } else if (elem instanceof RuntimeHash hash) { - // Copy hash elements for the same reason as arrays - RuntimeHash copy = new RuntimeHash(); - for (var entry : hash.elements.entrySet()) { - copy.elements.put(entry.getKey(), new RuntimeScalar(entry.getValue())); + // Copy hash elements for the same reason as arrays. + // For tied hashes, use getList() which dispatches through FIRSTKEY/NEXTKEY/FETCH. + if (hash.type == RuntimeHash.TIED_HASH) { + RuntimeList hashList = hash.getList(); + elems.set(i, hashList); + } else { + RuntimeHash copy = new RuntimeHash(); + for (var entry : hash.elements.entrySet()) { + copy.elements.put(entry.getKey(), new RuntimeScalar(entry.getValue())); + } + elems.set(i, copy); } - elems.set(i, copy); } } } diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeHashProxyEntry.java b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeHashProxyEntry.java index b41d21184..4c8be3c12 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeHashProxyEntry.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeHashProxyEntry.java @@ -42,6 +42,17 @@ public RuntimeHashProxyEntry(RuntimeHash parent, String key, boolean byteKey) { // Note: this.type is RuntimeScalarType.UNDEF } + /** + * Creates a reference to the underlying lvalue, vivifying it first. + * In Perl, \$hash{key} auto-vivifies the hash entry so that the reference + * points to the actual hash element, not a temporary. + */ + @Override + public RuntimeScalar createReference() { + vivify(); + return lvalue.createReference(); + } + /** * Vivifies (initializes) the element in the parent hash if it does not exist. * If the element associated with the key is not present, it creates a new diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeScalar.java b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeScalar.java index 548c52610..27b6df234 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeScalar.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeScalar.java @@ -771,14 +771,18 @@ public RuntimeScalar set(RuntimeScalar value) { /** * Set value while preserving BYTE_STRING type when possible. * Used by .= (string concat-assign) to prevent UTF-8 flag contamination - * of binary buffers. In PerlOnJava, upgrading from BYTE_STRING to STRING - * doesn't change the underlying chars (unlike Perl where bytes > 127 get - * re-encoded), so preserving BYTE_STRING is safe when all chars fit in Latin-1. + * of binary buffers. Only preserves BYTE_STRING when the concat result + * itself is BYTE_STRING (both operands were non-UTF-8). When the concat + * result is STRING (at least one operand was UTF-8), the UTF-8 flag is + * preserved, matching Perl's behavior where concatenation with a UTF-8 + * string upgrades the result. */ public RuntimeScalar setPreservingByteString(RuntimeScalar value) { boolean wasByteString = (this.type == BYTE_STRING); this.set(value); - if (wasByteString && this.type == STRING) { + // Only preserve BYTE_STRING when the concat result was also BYTE_STRING. + // If concat produced STRING (because an operand was UTF-8), don't downgrade. + if (wasByteString && value.type == BYTE_STRING && this.type == STRING) { // Check if all chars fit in Latin-1 (single byte) String s = this.toString(); boolean allLatin1 = true; @@ -1269,8 +1273,17 @@ public RuntimeArray arrayDeref() { } case JAVAOBJECT -> // 8 throw new PerlCompilerException("Not an ARRAY reference"); - case TIED_SCALAR -> // 9 - tiedFetch().arrayDeref(); + case TIED_SCALAR -> { // 9 + RuntimeScalar fetched = tiedFetch(); + if (fetched.type == RuntimeScalarType.UNDEF) { + // Autovivify: create array ref, store back to tied var, re-fetch + RuntimeArray arr = new RuntimeArray(); + arr.strictAutovivify = true; + tiedStore(arr.createReference()); + yield arr; + } + yield fetched.arrayDeref(); + } case DUALVAR -> // 10 throw new PerlCompilerException("Not an ARRAY reference"); case FORMAT -> // 11 @@ -1354,10 +1367,16 @@ public RuntimeHash hashDeref() { } case JAVAOBJECT -> // 8 throw new PerlCompilerException("Not a HASH reference"); - case TIED_SCALAR -> // 9 - tiedFetch().hashDeref(); - case DUALVAR -> // 10 - throw new PerlCompilerException("Not a HASH reference"); + case TIED_SCALAR -> { // 9 + RuntimeScalar fetched = tiedFetch(); + if (fetched.type == RuntimeScalarType.UNDEF) { + // Autovivify: create hash ref, store back to tied var + RuntimeHash hash = new RuntimeHash(); + tiedStore(hash.createReference()); + yield hash; + } + yield fetched.hashDeref(); + } case FORMAT -> // 11 throw new PerlCompilerException("Not a HASH reference"); case READONLY_SCALAR -> // 12 @@ -1534,8 +1553,15 @@ public RuntimeHash hashDerefNonStrict(String packageName) { } case JAVAOBJECT -> // 8 throw new PerlCompilerException("Not a HASH reference"); - case TIED_SCALAR -> // 9 - tiedFetch().hashDerefNonStrict(packageName); + case TIED_SCALAR -> { // 9 + RuntimeScalar fetched = tiedFetch(); + if (fetched.type == RuntimeScalarType.UNDEF) { + RuntimeHash hash = new RuntimeHash(); + tiedStore(hash.createReference()); + yield hash; + } + yield fetched.hashDerefNonStrict(packageName); + } case FORMAT -> // 11 throw new PerlCompilerException("Not a HASH reference"); case READONLY_SCALAR -> // 12 @@ -1601,10 +1627,16 @@ public RuntimeArray arrayDerefNonStrict(String packageName) { } case JAVAOBJECT -> // 8 throw new PerlCompilerException("Not an ARRAY reference"); - case TIED_SCALAR -> // 9 - tiedFetch().arrayDerefNonStrict(packageName); - case FORMAT -> // 11 - throw new PerlCompilerException("Not an ARRAY reference"); + case TIED_SCALAR -> { // 9 + RuntimeScalar fetched = tiedFetch(); + if (fetched.type == RuntimeScalarType.UNDEF) { + RuntimeArray arr = new RuntimeArray(); + arr.strictAutovivify = true; + tiedStore(arr.createReference()); + yield arr; + } + yield fetched.arrayDerefNonStrict(packageName); + } case READONLY_SCALAR -> // 12 ((RuntimeScalar) this.value).arrayDerefNonStrict(packageName); default -> throw new PerlCompilerException("Not an ARRAY reference"); diff --git a/src/main/perl/lib/Clone/PP.pm b/src/main/perl/lib/Clone/PP.pm index c65179205..e6e757419 100644 --- a/src/main/perl/lib/Clone/PP.pm +++ b/src/main/perl/lib/Clone/PP.pm @@ -1,77 +1,120 @@ package Clone::PP; +use 5.006; use strict; use warnings; +use vars qw($VERSION @EXPORT_OK); +use Exporter; -our $VERSION = '1.09'; +$VERSION = 1.08; -use Scalar::Util qw(reftype blessed refaddr); -use Exporter 'import'; -our @EXPORT_OK = qw(clone); +@EXPORT_OK = qw( clone ); +sub import { goto &Exporter::import } # lazy Exporter -sub clone { - return _clone_data($_[0], {}); -} +# These methods can be temporarily overridden to work with a given class. +use vars qw( $CloneSelfMethod $CloneInitMethod ); +$CloneSelfMethod ||= 'clone_self'; +$CloneInitMethod ||= 'clone_init'; + +# Used to detect looped networks and avoid infinite recursion. +use vars qw( %CloneCache ); -sub _clone_data { - my ($data, $seen) = @_; - - return $data unless ref($data); - - # Handle circular references - my $addr = refaddr($data); - return $seen->{$addr} if exists $seen->{$addr}; - - my $rtype = reftype($data); - my $class = blessed($data); - - if ($rtype eq 'HASH') { - my $clone = {}; - $seen->{$addr} = $clone; - for my $key (keys %$data) { - $clone->{$key} = _clone_data($data->{$key}, $seen); - } - bless $clone, $class if defined $class; - return $clone; - } - - if ($rtype eq 'ARRAY') { - my $clone = []; - $seen->{$addr} = $clone; - for my $item (@$data) { - push @$clone, _clone_data($item, $seen); - } - bless $clone, $class if defined $class; - return $clone; - } - - if ($rtype eq 'SCALAR' || $rtype eq 'REF') { - my $clone = \(my $copy = $$data); - $seen->{$addr} = $clone; - bless $clone, $class if defined $class; - return $clone; - } - - # CODE, GLOB, IO, Regexp - return as-is (immutable or not deep-cloneable) - return $data; +# Generic cloning function +sub clone { + my $source = shift; + + return undef if not defined($source); + + # Optional depth limit: after a given number of levels, do shallow copy. + my $depth = shift; + return $source if ( defined $depth and $depth -- < 1 ); + + # Maintain a shared cache during recursive calls, then clear it at the end. + local %CloneCache = ( undef => undef ) unless ( exists $CloneCache{undef} ); + + return $CloneCache{ $source } if ( defined $CloneCache{ $source } ); + + # Non-reference values are copied shallowly + my $ref_type = ref $source or return $source; + + # Extract both the structure type and the class name of referent + my $class_name; + if ( "$source" =~ /^\Q$ref_type\E\=([A-Z]+)\(0x[0-9a-f]+\)$/ ) { + $class_name = $ref_type; + $ref_type = $1; + # Some objects would prefer to clone themselves; check for clone_self(). + return $CloneCache{ $source } = $source->$CloneSelfMethod() + if $source->can($CloneSelfMethod); + } + + # To make a copy: + # - Prepare a reference to the same type of structure; + # - Store it in the cache, to avoid looping if it refers to itself; + # - Tie in to the same class as the original, if it was tied; + # - Assign a value to the reference by cloning each item in the original; + + my $copy; + if ($ref_type eq 'HASH') { + $CloneCache{ $source } = $copy = {}; + if ( my $tied = tied( %$source ) ) { tie %$copy, ref $tied } + %$copy = map { ! ref($_) ? $_ : clone($_, $depth) } %$source; + } elsif ($ref_type eq 'ARRAY') { + $CloneCache{ $source } = $copy = []; + if ( my $tied = tied( @$source ) ) { tie @$copy, ref $tied } + @$copy = map { ! ref($_) ? $_ : clone($_, $depth) } @$source; + } elsif ($ref_type eq 'REF' or $ref_type eq 'SCALAR') { + $CloneCache{ $source } = $copy = \( my $var = "" ); + if ( my $tied = tied( $$source ) ) { tie $$copy, ref $tied } + $$copy = clone($$source, $depth); + } else { + # Shallow copy anything else; this handles a reference to code, glob, regex + $CloneCache{ $source } = $copy = $source; + } + + # - Bless it into the same class as the original, if it was blessed; + # - If it has a post-cloning initialization method, call it. + if ( $class_name ) { + bless $copy, $class_name; + $copy->$CloneInitMethod() if $copy->can($CloneInitMethod); + } + + return $copy; } 1; + __END__ =head1 NAME -Clone::PP - Recursively copy Perl datatypes (pure Perl) +Clone::PP - Recursively copy Perl datatypes =head1 SYNOPSIS - use Clone::PP 'clone'; - my $copy = clone($data); + use Clone::PP qw(clone); + + $item = { 'foo' => 'bar', 'move' => [ 'zig', 'zag' ] }; + $copy = clone( $item ); + + $item = [ 'alpha', 'beta', { 'gamma' => 'vlissides' } ]; + $copy = clone( $item ); + + $item = Foo->new(); + $copy = clone( $item ); + +Or as an object method: + + require Clone::PP; + push @Foo::ISA, 'Clone::PP'; + + $item = Foo->new(); + $copy = $item->clone(); =head1 DESCRIPTION -Pure Perl deep clone implementation. Handles hashes, arrays, scalar refs, -and circular references. Code refs, globs, and regexps are returned as-is -(shared, not copied) since they are immutable or not safely cloneable. +This module provides a general-purpose clone function to make deep +copies of Perl data structures. It calls itself recursively to copy +nested hash, array, scalar and reference types, including tied +variables and objects. =cut diff --git a/src/test/resources/module/Clone-PP/t/01array.t b/src/test/resources/module/Clone-PP/t/01array.t new file mode 100644 index 000000000..1927ff2f9 --- /dev/null +++ b/src/test/resources/module/Clone-PP/t/01array.t @@ -0,0 +1,68 @@ +# Before `make install' is performed this script should be runnable with +# `make test'. After `make install' it should work as `perl test.pl' + +######################### We start with some black magic to print on failure. + +# Change 1..1 below to 1..last_test_to_print . +# (It may become useful if the test is moved to ./t subdirectory.) + +BEGIN { $| = 1; print "1..6\n"; } +END {print "not ok 1\n" unless $loaded;} +use Clone::PP qw( clone ); +use Data::Dumper; +$loaded = 1; +print "ok 1\n"; + +######################### End of black magic. + +# Insert your test code below (better if it prints "ok 13" +# (correspondingly "not ok 13") depending on the success of chunk 13 +# of the test code): + +package Test::Array; + +use vars @ISA; + +@ISA = qw(Clone::PP); + +sub new + { + my $class = shift; + my @self = @_; + bless \@self, $class; + } + +package main; + +sub ok { print "ok $test\n"; $test++ } +sub not_ok { print "not ok $test\n"; $test++ } + +$^W = 0; +$test = 2; +my $a = Test::Array->new( + 1, + [ 'two', + [ 3, + ['four'] + ], + ], + ); +my $b = $a->clone(0); +my $c = $a->clone(2); + +# TEST 2 +$b->[1][0] eq 'two' ? ok : not_ok; + +# TEST 3 +$b->[1] == $a->[1] ? ok : not_ok; + +# TEST 4 +$c->[1] != $a->[1] ? ok : not_ok; + +# TEST 5 +$c->[1][1][1] == $a->[1][1][1] ? ok : not_ok; + +my @circ = (); +$circ[0] = \@circ; +$aref = clone(\@circ); +Dumper(\@circ) eq Dumper($aref) ? ok : not_ok; diff --git a/src/test/resources/module/Clone-PP/t/02hash.t b/src/test/resources/module/Clone-PP/t/02hash.t new file mode 100644 index 000000000..0c53b0d99 --- /dev/null +++ b/src/test/resources/module/Clone-PP/t/02hash.t @@ -0,0 +1,84 @@ +# Before `make install' is performed this script should be runnable with +# `make test'. After `make install' it should work as `perl test.pl' + +######################### We start with some black magic to print on failure. + +# Change 1..1 below to 1..last_test_to_print . +# (It may become useful if the test is moved to ./t subdirectory.) + +BEGIN { $| = 1; print "1..11\n"; } +END {print "not ok 1\n" unless $loaded;} +use Clone::PP qw( clone ); +use Data::Dumper; +$loaded = 1; +print "ok 1\n"; + +######################### End of black magic. + +# Insert your test code below (better if it prints "ok 13" +# (correspondingly "not ok 13") depending on the success of chunk 13 +# of the test code): + +package Test::Hash; + +use vars @ISA; + +@ISA = qw(Clone::PP); + +sub new + { + my $class = shift; + my %self = @_; + bless \%self, $class; + } + +sub DESTROY + { + my $self = shift; + # warn "DESTROYING $self"; + } + +package main; + +sub ok { print "ok $test\n"; $test++ } +sub not_ok { print "not ok $test\n"; $test++ } + +$^W = 0; +$test = 2; + +my $a = Test::Hash->new( + level => 1, + href => { + level => 2, + href => { + level => 3, + href => { + level => 4, + }, + }, + }, + ); + +$a->{a} = $a; + +my $b = $a->clone(0); +my $c = $a->clone(3); + +$a->{level} == $b->{level} ? ok : not_ok; + +$b->{href} == $a->{href} ? ok : not_ok; +$c->{href} != $a->{href} ? ok : not_ok; + +$b->{href}{href} == $a->{href}{href} ? ok : not_ok; +$c->{href}{href} != $a->{href}{href} ? ok : not_ok; + +$c->{href}{href}{level} == 3 ? ok : not_ok; +$c->{href}{href}{href}{level} == 4 ? ok : not_ok; + +$b->{href}{href}{href} == $a->{href}{href}{href} ? ok : not_ok; +$c->{href}{href}{href} == $a->{href}{href}{href} ? ok : not_ok; + +my %circ = (); +$circ{c} = \%circ; +my $cref = clone(\%circ); +Dumper(\%circ) eq Dumper($cref) ? ok : not_ok; diff --git a/src/test/resources/module/Clone-PP/t/03scalar.t b/src/test/resources/module/Clone-PP/t/03scalar.t new file mode 100644 index 000000000..4f621a8de --- /dev/null +++ b/src/test/resources/module/Clone-PP/t/03scalar.t @@ -0,0 +1,64 @@ +# Before `make install' is performed this script should be runnable with +# `make test'. After `make install' it should work as `perl test.pl' + +######################### We start with some black magic to print on failure. + +# Change 1..1 below to 1..last_test_to_print . +# (It may become useful if the test is moved to ./t subdirectory.) + +BEGIN { $| = 1; print "1..6\n"; } +END {print "not ok 1\n" unless $loaded;} +use Clone::PP qw( clone ); +use Data::Dumper; +$loaded = 1; +print "ok 1\n"; + +######################### End of black magic. + +# Insert your test code below (better if it prints "ok 13" +# (correspondingly "not ok 13") depending on the success of chunk 13 +# of the test code): + +package Test::Scalar; + +use vars @ISA; + +@ISA = qw(Clone::PP); + +sub new + { + my $class = shift; + my $self = shift; + bless \$self, $class; + } + +sub DESTROY + { + my $self = shift; + # warn "DESTROYING $self"; + } + +package main; + +sub ok { print "ok $test\n"; $test++ } +sub not_ok { print "not ok $test\n"; $test++ } + +$^W = 0; +$test = 2; + +my $a = Test::Scalar->new(1.0); +my $b = $a->clone(1); + +$$a == $$b ? ok : not_ok; +$a != $b ? ok : not_ok; + +my $c = \"test 2 scalar"; +my $d = Clone::PP::clone($c, 2); + +$$c == $$d ? ok : not_ok; +$c != $d ? ok : not_ok; + +my $circ = undef; +$circ = \$circ; +$aref = clone($circ); +Dumper($circ) eq Dumper($aref) ? ok : not_ok; diff --git a/src/test/resources/module/Clone-PP/t/04tie.t b/src/test/resources/module/Clone-PP/t/04tie.t new file mode 100644 index 000000000..ccb9b47fc --- /dev/null +++ b/src/test/resources/module/Clone-PP/t/04tie.t @@ -0,0 +1,65 @@ +# Before `make install' is performed this script should be runnable with +# `make test'. After `make install' it should work as `perl test.pl' + +######################### We start with some black magic to print on failure. + +# Change 1..1 below to 1..last_test_to_print . +# (It may become useful if the test is moved to ./t subdirectory.) + +BEGIN { $| = 1; print "1..5\n"; } +END {print "not ok 1\n" unless $loaded;} +use Clone::PP qw( clone ); +$loaded = 1; +print "ok 1\n"; + +######################### End of black magic. + +my $test = 2; + +require './t/dump.pl'; +require './t/tied.pl'; + +my ($a, @a, %a); +tie $a, TIED_SCALAR; +tie %a, TIED_HASH; +tie @a, TIED_ARRAY; +$a{a} = 0; +$a{b} = 1; + +my $b = [\%a, \@a, \$a]; + +my $c = clone($b); + +my $d1 = &dump($b); +my $d2 = &dump($c); + +print "not" unless $d1 eq $d2; +print "ok ", $test++, "\n"; + +my $t1 = tied(%{$b->[0]}); +my $t2 = tied(%{$c->[0]}); + +$d1 = &dump($t1); +$d2 = &dump($t2); + +print "not" unless $d1 eq $d2; +print "ok ", $test++, "\n"; + +$t1 = tied(@{$b->[1]}); +$t2 = tied(@{$c->[1]}); + +$d1 = &dump($t1); +$d2 = &dump($t2); + +print "not" unless $d1 eq $d2; +print "ok ", $test++, "\n"; + +$t1 = tied(${$b->[2]}); +$t2 = tied(${$c->[2]}); + +$d1 = &dump($t1); +$d2 = &dump($t2); + +print "not" unless $d1 eq $d2; +print "ok ", $test++, "\n"; + diff --git a/src/test/resources/module/Clone-PP/t/05dtype.t b/src/test/resources/module/Clone-PP/t/05dtype.t new file mode 100644 index 000000000..43600c66c --- /dev/null +++ b/src/test/resources/module/Clone-PP/t/05dtype.t @@ -0,0 +1,62 @@ +# Before `make install' is performed this script should be runnable with +# `make test'. After `make install' it should work as `perl test.pl' + +######################### We start with some black magic to print on failure. + +# Change 1..1 below to 1..last_test_to_print . +# (It may become useful if the test is moved to ./t subdirectory.) + +BEGIN { $| = 1; print "1..2\n"; } +END {print "not ok 1\n" unless $loaded;} +use Clone::PP; +$loaded = 1; +print "ok 1\n"; + +######################### End of black magic. + +# Insert your test code below (better if it prints "ok 13" +# (correspondingly "not ok 13") depending on the success of chunk 13 +# of the test code): + +use Data::Dumper; +eval 'use Storable qw( dclone )'; +if ($@) +{ + print "ok 2 # skipping Storable not found\n"; + exit; +} +# use Storable qw( dclone ); + +$^W = 0; +$test = 2; + +sub ok { printf("ok %d\n", $test++); } +sub not_ok { printf("not ok %d\n", $test++); } + +use strict; + +package Test::Hash; + +@Test::Hash::ISA = qw( Clone::PP ); + +sub new() +{ + my ($class) = @_; + my $self = {}; + $self->{x} = 0; + $self->{x} = {value => 1}; + bless $self, $class; +} + +package main; + +my ($master, $clone1); + +my $a = Test::Hash->new(); + +my $b = $a->clone; +my $c = dclone($a); + +Dumper($a, $b) eq Dumper($a, $c) ? ok() : not_ok; +# print Dumper($a, $b); +# print Dumper($a, $c); diff --git a/src/test/resources/module/Clone-PP/t/06refcnt.t b/src/test/resources/module/Clone-PP/t/06refcnt.t new file mode 100644 index 000000000..870f1989b --- /dev/null +++ b/src/test/resources/module/Clone-PP/t/06refcnt.t @@ -0,0 +1,84 @@ +# Before `make install' is performed this script should be runnable with +# `make test'. After `make install' it should work as `perl test.pl' + +######################### We start with some black magic to print on failure. + +# Change 1..1 below to 1..last_test_to_print . +# (It may become useful if the test is moved to ./t subdirectory.) + +BEGIN { $| = 1; print "1..9\n"; } +END {print "not ok 1\n" unless $loaded;} +use Clone::PP qw( clone ); +$loaded = 1; +print "ok 1\n"; + +######################### End of black magic. + +# Insert your test code below (better if it prints "ok 13" +# (correspondingly "not ok 13") depending on the success of chunk 13 +# of the test code): + +# code to test for memory leaks + +use Benchmark; +use Data::Dumper; +# use Storable qw( dclone ); + +$^W = 0; +$test = 2; + +sub ok { printf("ok %d\n", $test++); } +sub not_ok { printf("not ok %d\n", $test++); } + +use strict; + +package Test::Hash; + +@Test::Hash::ISA = qw( Clone::PP ); + +sub new() +{ + my ($class) = @_; + my $self = {}; + bless $self, $class; +} + +my $ok = 0; +END { $ok = 1; }; +sub DESTROY +{ + my $self = shift; + printf("not ") if $ok; + printf("ok %d\n", $::test++); +} + +package main; + +{ + my $a = Test::Hash->new(); + my $b = $a->clone; + # my $c = dclone($a); +} + +# benchmarking bug +{ + my $a = Test::Hash->new(); + my $sref = sub { my $b = clone($a) }; + $sref->(); +} + +# test for cloning unblessed ref +{ + my $a = {}; + my $b = clone($a); + bless $a, 'Test::Hash'; + bless $b, 'Test::Hash'; +} + +# test for cloning unblessed ref +{ + my $a = []; + my $b = clone($a); + bless $a, 'Test::Hash'; + bless $b, 'Test::Hash'; +} diff --git a/src/test/resources/module/Clone-PP/t/dclone.t b/src/test/resources/module/Clone-PP/t/dclone.t new file mode 100644 index 000000000..db3889313 --- /dev/null +++ b/src/test/resources/module/Clone-PP/t/dclone.t @@ -0,0 +1,111 @@ +#!./perl + +# $Id: dclone.t,v 0.11 2001/07/29 19:31:05 ray Exp $ +# +# Id: dclone.t,v 0.6.1.1 2000/03/02 22:21:05 ram Exp +# +# Copyright (c) 1995-1998, Raphael Manfredi +# +# You may redistribute this file under the same terms as Perl 5 itself. +# +# $Log: dclone.t,v $ +# Revision 0.11 2001/07/29 19:31:05 ray +# VERSION 0.11 +# +# Revision 0.10.2.1 2001/07/28 21:47:49 ray +# commented out print statements. +# +# Revision 0.10 2001/04/29 21:56:10 ray +# VERSION 0.10 +# +# Revision 0.9 2001/03/05 00:11:49 ray +# version 0.9 +# +# Revision 0.9 2000/08/21 23:06:34 ray +# added support for code refs +# +# Revision 0.8 2000/08/11 17:08:36 ray +# Release 0.08. +# +# Revision 0.7 2000/08/01 00:31:42 ray +# release 0.07 +# +# Revision 0.6 2000/07/28 21:37:20 ray +# "borrowed" code from Storable +# +# Revision 0.6.1.1 2000/03/02 22:21:05 ram +# patch9: added test case for "undef" bug in hashes +# +# Revision 0.6 1998/06/04 16:08:25 ram +# Baseline for first beta release. +# + +require './t/dump.pl'; + +# use Storable qw(dclone); +use Clone::PP qw(clone); + +print "1..9\n"; + +$a = 'toto'; +$b = \$a; +$c = bless {}, CLASS; +$c->{attribute} = 'attrval'; +%a = ('key', 'value', 1, 0, $a, $b, 'cvar', \$c); +@a = ('first', undef, 3, -4, -3.14159, 456, 4.5, + $b, \$a, $a, $c, \$c, \%a); + +print "not " unless defined ($aref = clone(\@a)); +print "ok 1\n"; + +$dumped = &dump(\@a); +print "ok 2\n"; + +$got = &dump($aref); +print "ok 3\n"; + +# print $got; +# print $dumped; +# print $_, "\n" for (@a); +# print $_, "\n" foreach (@$aref); +print "not " unless $got eq $dumped; +print "ok 4\n"; + +package FOO; @ISA = qw(Clone::PP); + +sub make { + my $self = bless {}; + $self->{key} = \%main::a; + return $self; +}; + +package main; + +$foo = FOO->make; +print "not " unless defined($r = $foo->clone); +print "ok 5\n"; + +# print &dump($foo); +# print &dump($r); +print "not " unless &dump($foo) eq &dump($r); +print "ok 6\n"; + +# Ensure refs to "undef" values are properly shared during cloning +my $hash; +push @{$$hash{''}}, \$$hash{a}; +print "not " unless $$hash{''}[0] == \$$hash{a}; +print "ok 7\n"; + +my $cloned = clone(clone($hash)); +require Data::Dumper; + +# warn "Hash: " . ( $$hash{''}[0] ) . " : " . ( \$$hash{a} ) . "\n"; +# warn "Copy: " . ( $$cloned{''}[0] ) . " : " . ( \$$cloned{a} ) . "\n"; + +warn "This test is todo " unless $$cloned{''}[0] == \$$cloned{a}; +print "ok 8\n"; + +$$cloned{a} = "blah"; +warn "This test is todo " unless $$cloned{''}[0] == \$$cloned{a}; +print "ok 9\n"; + diff --git a/src/test/resources/module/Clone-PP/t/dump.pl b/src/test/resources/module/Clone-PP/t/dump.pl new file mode 100644 index 000000000..55860056b --- /dev/null +++ b/src/test/resources/module/Clone-PP/t/dump.pl @@ -0,0 +1,153 @@ +;# Id: dump.pl,v 0.7 2000/08/03 22:04:45 ram Exp +;# +;# Copyright (c) 1995-2000, Raphael Manfredi +;# +;# You may redistribute this file under the same terms as Perl 5 itself. +;# +;# Log: dump.pl,v +;# Revision 0.7 2000/08/03 22:04:45 ram +;# Baseline for second beta release. +;# + +sub ok { + my ($num, $ok) = @_; + print "not " unless $ok; + print "ok $num\n"; +} + +package dump; +use Carp; + +%dump = ( + 'SCALAR' => 'dump_scalar', + 'ARRAY' => 'dump_array', + 'HASH' => 'dump_hash', + 'REF' => 'dump_ref', + 'CODE' => 'dump_code', +); + +# Given an object, dump its transitive data closure +sub main::dump { + my ($object) = @_; + croak "Not a reference!" unless ref($object); + local %dumped; + local %object; + local $count = 0; + local $dumped = ''; + &recursive_dump($object, 1); + return $dumped; +} + +# This is the root recursive dumping routine that may indirectly be +# called by one of the routine it calls... +# The link parameter is set to false when the reference passed to +# the routine is an internal temporay variable, implying the object's +# address is not to be dumped in the %dumped table since it's not a +# user-visible object. +sub recursive_dump { + my ($object, $link) = @_; + + # Get something like SCALAR(0x...) or TYPE=SCALAR(0x...). + # Then extract the bless, ref and address parts of that string. + + my $what = "$object"; # Stringify + my ($bless, $ref, $addr) = $what =~ /^(\w+)=(\w+)\((0x.*)\)$/; + ($ref, $addr) = $what =~ /^(\w+)\((0x.*)\)$/ unless $bless; + + # Special case for references to references. When stringified, + # they appear as being scalars. However, ref() correctly pinpoints + # them as being references indirections. And that's it. + + $ref = 'REF' if ref($object) eq 'REF'; + + # Make sure the object has not been already dumped before. + # We don't want to duplicate data. Retrieval will know how to + # relink from the previously seen object. + + if ($link && $dumped{$addr}++) { + my $num = $object{$addr}; + $dumped .= "OBJECT #$num seen\n"; + return; + } + + my $objcount = $count++; + $object{$addr} = $objcount; + + # Call the appropriate dumping routine based on the reference type. + # If the referenced was blessed, we bless it once the object is dumped. + # The retrieval code will perform the same on the last object retrieved. + + croak "Unknown simple type '$ref'" unless defined $dump{$ref}; + + &{$dump{$ref}}($object); # Dump object + &bless($bless) if $bless; # Mark it as blessed, if necessary + + $dumped .= "OBJECT $objcount\n"; +} + +# Indicate that current object is blessed +sub bless { + my ($class) = @_; + $dumped .= "BLESS $class\n"; +} + +# Dump single scalar +sub dump_scalar { + my ($sref) = @_; + my $scalar = $$sref; + unless (defined $scalar) { + $dumped .= "UNDEF\n"; + return; + } + my $len = length($scalar); + $dumped .= "SCALAR len=$len $scalar\n"; +} + +# Dump array +sub dump_array { + my ($aref) = @_; + my $items = 0 + @{$aref}; + $dumped .= "ARRAY items=$items\n"; + foreach $item (@{$aref}) { + unless (defined $item) { + $dumped .= 'ITEM_UNDEF' . "\n"; + next; + } + $dumped .= 'ITEM '; + &recursive_dump(\$item, 1); + } +} + +# Dump hash table +sub dump_hash { + my ($href) = @_; + my $items = scalar(keys %{$href}); + $dumped .= "HASH items=$items\n"; + foreach $key (sort keys %{$href}) { + $dumped .= 'KEY '; + &recursive_dump(\$key, undef); + unless (defined $href->{$key}) { + $dumped .= 'VALUE_UNDEF' . "\n"; + next; + } + $dumped .= 'VALUE '; + &recursive_dump(\$href->{$key}, 1); + } +} + +# Dump reference to reference +sub dump_ref { + my ($rref) = @_; + my $deref = $$rref; # Follow reference to reference + $dumped .= 'REF '; + &recursive_dump($deref, 1); # $dref is a reference +} + + +# Dump code +sub dump_code { + my ($sref) = @_; + $dumped .= "CODE\n"; +} + +1; diff --git a/src/test/resources/module/Clone-PP/t/tied.pl b/src/test/resources/module/Clone-PP/t/tied.pl new file mode 100644 index 000000000..ff0e85ad9 --- /dev/null +++ b/src/test/resources/module/Clone-PP/t/tied.pl @@ -0,0 +1,130 @@ +#!./perl + +# $Id: tied.pl,v 0.11 2001/07/29 19:31:05 ray Exp $ +# +# Copyright (c) 1995-1998, Raphael Manfredi +# +# You may redistribute this file under the same terms as Perl 5 itself. +# +# $Log: tied.pl,v $ +# Revision 0.11 2001/07/29 19:31:05 ray +# VERSION 0.11 +# +# Revision 0.10 2001/04/29 21:56:10 ray +# VERSION 0.10 +# +# Revision 0.9 2001/03/05 00:11:49 ray +# version 0.9 +# +# Revision 0.9 2000/08/21 23:06:34 ray +# added support for code refs +# +# Revision 0.8 2000/08/11 17:08:36 ray +# Release 0.08. +# +# Revision 0.7 2000/08/01 00:43:48 ray +# release 0.07. +# +# Revision 0.6.2.1 2000/08/01 00:42:53 ray +# modified to use as a require statement. +# +# Revision 0.6 2000/08/01 01:38:38 ray +# "borrowed" code from Storable +# +# Revision 0.6 1998/06/04 16:08:40 ram +# Baseline for first beta release. +# + +require './t/dump.pl'; + +package TIED_HASH; + +sub TIEHASH { + my $self = bless {}, shift; + return $self; +} + +sub FETCH { + my $self = shift; + my ($key) = @_; + $main::hash_fetch++; + return $self->{$key}; +} + +sub STORE { + my $self = shift; + my ($key, $value) = @_; + $self->{$key} = $value; +} + +sub FIRSTKEY { + my $self = shift; + scalar keys %{$self}; + return each %{$self}; +} + +sub NEXTKEY { + my $self = shift; + return each %{$self}; +} + +sub CLEAR { + %$self = (); +} + +package TIED_ARRAY; + +sub TIEARRAY { + my $self = bless [], shift; + return $self; +} + +sub FETCH { + my $self = shift; + my ($idx) = @_; + $main::array_fetch++; + return $self->[$idx]; +} + +sub STORE { + my $self = shift; + my ($idx, $value) = @_; + $self->[$idx] = $value; +} + +sub FETCHSIZE { + my $self = shift; + return @{$self}; +} + +sub CLEAR { + @$self = (); +} + +sub EXTEND { } + +package TIED_SCALAR; + +sub TIESCALAR { + my $scalar; + my $self = bless \$scalar, shift; + return $self; +} + +sub FETCH { + my $self = shift; + $main::scalar_fetch++; + return $$self; +} + +sub STORE { + my $self = shift; + my ($value) = @_; + $$self = $value; +} + +sub CLEAR { + $$self = (); +} + +1;