From 79be1c2e6dc71acf98125a93e9f1536a3cf15de0 Mon Sep 17 00:00:00 2001 From: "Flavio S. Glock" Date: Sat, 13 Jun 2026 16:46:12 +0200 Subject: [PATCH] fix: stabilize bundled CPAN module tests Fix remaining bundled CPAN module failures for Class::DBI and XML::TreePP, and repair weak-reference lifetime handling exposed by DBIx::Class. Defer automatic weak sweeps while temporary roots protect return-value handoff so live object graphs are not destroyed before caller assignment completes. Add regression coverage for weak cache cleanup after failed construction and returned object handoff assignment. Generated with OpenAI Codex Co-Authored-By: OpenAI Codex --- .../backend/bytecode/BytecodeCompiler.java | 12 +- .../backend/bytecode/BytecodeInterpreter.java | 1 + .../backend/bytecode/CompileAssignment.java | 32 +- .../backend/bytecode/InterpretedCode.java | 16 + .../backend/jvm/EmitterMethodCreator.java | 5 + .../frontend/parser/StringParser.java | 24 + .../runtime/runtimetypes/MortalList.java | 29 +- .../runtimetypes/MyVarCleanupStack.java | 5 + .../runtimetypes/ReachabilityWalker.java | 48 +- .../runtime/runtimetypes/RuntimeBase.java | 6 +- .../runtime/runtimetypes/WeakRefRegistry.java | 1 + src/main/perl/lib/CPAN/Config.pm | 6 + src/main/perl/lib/DBD/ExampleP.pm | 436 +++++++++++ src/main/perl/lib/DBD/Sponge.pm | 306 ++++++++ src/main/perl/lib/DBI.pm | 51 +- src/main/perl/lib/Data/UUID.pm | 20 + .../PerlOnJava/CpanDistroprefs/Class-DBI.yml | 12 + .../PerlOnJava/CpanDistroprefs/XML-TreePP.yml | 19 + .../Class-DBI-v3.0.17/Class-DBI.pm.patch | 12 + .../XML-TreePP-0.43/TreePP.pm.patch | 147 ++++ src/main/perl/lib/Text/CSV_PP.pm | 16 +- src/main/perl/lib/YAML/Loader.pm | 90 ++- .../perlonjava/ModuleTestExecutionTest.java | 6 +- src/test/resources/module/YAML/t/Spiffy.pm | 534 ++++++++++++++ .../resources/module/YAML/t/Spiffy/mixin.pm | 2 + src/test/resources/module/YAML/t/Test/Base.pm | 695 ++++++++++++++++++ .../module/YAML/t/Test/Base/Filter.pm | 338 +++++++++ src/test/resources/module/YAML/t/Test/YAML.pm | 233 ++++++ .../refcount/weak_cache_failed_constructor.t | 81 ++ .../refcount/weak_return_handoff_assignment.t | 51 ++ src/test/resources/unit/slice_context.t | 24 + 31 files changed, 3195 insertions(+), 63 deletions(-) create mode 100644 src/main/perl/lib/DBD/ExampleP.pm create mode 100644 src/main/perl/lib/DBD/Sponge.pm create mode 100644 src/main/perl/lib/Data/UUID.pm create mode 100644 src/main/perl/lib/PerlOnJava/CpanDistroprefs/Class-DBI.yml create mode 100644 src/main/perl/lib/PerlOnJava/CpanDistroprefs/XML-TreePP.yml create mode 100644 src/main/perl/lib/PerlOnJava/CpanPatches/Class-DBI-v3.0.17/Class-DBI.pm.patch create mode 100644 src/main/perl/lib/PerlOnJava/CpanPatches/XML-TreePP-0.43/TreePP.pm.patch create mode 100644 src/test/resources/module/YAML/t/Spiffy.pm create mode 100644 src/test/resources/module/YAML/t/Spiffy/mixin.pm create mode 100644 src/test/resources/module/YAML/t/Test/Base.pm create mode 100644 src/test/resources/module/YAML/t/Test/Base/Filter.pm create mode 100644 src/test/resources/module/YAML/t/Test/YAML.pm create mode 100644 src/test/resources/unit/refcount/weak_cache_failed_constructor.t create mode 100644 src/test/resources/unit/refcount/weak_return_handoff_assignment.t create mode 100644 src/test/resources/unit/slice_context.t diff --git a/src/main/java/org/perlonjava/backend/bytecode/BytecodeCompiler.java b/src/main/java/org/perlonjava/backend/bytecode/BytecodeCompiler.java index 98ccd6686..9fea76a56 100644 --- a/src/main/java/org/perlonjava/backend/bytecode/BytecodeCompiler.java +++ b/src/main/java/org/perlonjava/backend/bytecode/BytecodeCompiler.java @@ -1899,8 +1899,8 @@ void handleArraySlice(BinaryOperatorNode node, OperatorNode leftOp) { // The ArrayLiteralNode might contain a range operator (..) or multiple elements List indexRegs = new ArrayList<>(); for (Node indexExpr : indicesNode.elements) { - // Each element could be a simple value or a range expression - indexExpr.accept(this); + // Each element could be a simple value, an expanding array, or a range expression. + compileNode(indexExpr, -1, RuntimeContextType.LIST); indexRegs.add(lastResultReg); } @@ -2113,8 +2113,8 @@ void handleHashSlice(BinaryOperatorNode node, OperatorNode leftOp) { emit(keyIdx); keyRegs.add(keyReg); } else { - // Expression key - use default context to allow arrays to expand - keyElement.accept(this); + // Expression key - list context lets @keys and list-returning subs expand. + compileNode(keyElement, -1, RuntimeContextType.LIST); keyRegs.add(lastResultReg); } } @@ -2221,8 +2221,8 @@ void handleHashKeyValueSlice(BinaryOperatorNode node, OperatorNode leftOp) { emit(keyIdx); keyRegs.add(keyReg); } else { - // Expression key - use default context to allow arrays to expand - keyElement.accept(this); + // Expression key - list context lets @keys and list-returning subs expand. + compileNode(keyElement, -1, RuntimeContextType.LIST); keyRegs.add(lastResultReg); } } diff --git a/src/main/java/org/perlonjava/backend/bytecode/BytecodeInterpreter.java b/src/main/java/org/perlonjava/backend/bytecode/BytecodeInterpreter.java index 361ed3f54..739196a25 100644 --- a/src/main/java/org/perlonjava/backend/bytecode/BytecodeInterpreter.java +++ b/src/main/java/org/perlonjava/backend/bytecode/BytecodeInterpreter.java @@ -2609,6 +2609,7 @@ public static RuntimeList execute(InterpretedCode code, RuntimeArray args, int c MortalList.scopeExitCleanupArray(ra); needsFlush = true; } + MyVarCleanupStack.unregister(reg); registers[i] = null; } if (needsFlush) { diff --git a/src/main/java/org/perlonjava/backend/bytecode/CompileAssignment.java b/src/main/java/org/perlonjava/backend/bytecode/CompileAssignment.java index 7393cf601..2332a216d 100644 --- a/src/main/java/org/perlonjava/backend/bytecode/CompileAssignment.java +++ b/src/main/java/org/perlonjava/backend/bytecode/CompileAssignment.java @@ -1433,7 +1433,7 @@ public static void compileAssignmentOperator(BytecodeCompiler bytecodeCompiler, ArrayLiteralNode indicesNode = (ArrayLiteralNode) leftBin.right; List indexRegs = new ArrayList<>(); for (Node indexNode : indicesNode.elements) { - bytecodeCompiler.compileNode(indexNode, -1, rhsContext); + bytecodeCompiler.compileNode(indexNode, -1, RuntimeContextType.LIST); indexRegs.add(bytecodeCompiler.lastResultReg); } @@ -1446,13 +1446,20 @@ public static void compileAssignmentOperator(BytecodeCompiler bytecodeCompiler, bytecodeCompiler.emitReg(indexReg); } - // Emit direct opcode ARRAY_SLICE_SET (use valueReg from line 729) + int sliceValuesReg = bytecodeCompiler.allocateRegister(); + bytecodeCompiler.emit(Opcodes.NEW_ARRAY); + bytecodeCompiler.emitReg(sliceValuesReg); + bytecodeCompiler.emit(Opcodes.ARRAY_SET_FROM_LIST); + bytecodeCompiler.emitReg(sliceValuesReg); + bytecodeCompiler.emitReg(valueReg); + + // Emit direct opcode ARRAY_SLICE_SET using the materialized RHS values. bytecodeCompiler.emit(Opcodes.ARRAY_SLICE_SET); bytecodeCompiler.emitReg(arrayReg); bytecodeCompiler.emitReg(indicesReg); - bytecodeCompiler.emitReg(valueReg); + bytecodeCompiler.emitReg(sliceValuesReg); - bytecodeCompiler.lastResultReg = arrayReg; + bytecodeCompiler.lastResultReg = sliceValuesReg; return; } @@ -1628,8 +1635,8 @@ public static void compileAssignmentOperator(BytecodeCompiler bytecodeCompiler, bytecodeCompiler.emit(keyIdx); keyRegs.add(keyReg); } else { - // Expression key - use default context to allow arrays to expand - keyElement.accept(bytecodeCompiler); + // Expression key - list context lets @keys and list-returning subs expand. + bytecodeCompiler.compileNode(keyElement, -1, RuntimeContextType.LIST); keyRegs.add(bytecodeCompiler.lastResultReg); } } @@ -1643,13 +1650,20 @@ public static void compileAssignmentOperator(BytecodeCompiler bytecodeCompiler, bytecodeCompiler.emitReg(keyReg); } - // Emit direct opcode HASH_SLICE_SET (use valueReg from line 729) + int sliceValuesReg = bytecodeCompiler.allocateRegister(); + bytecodeCompiler.emit(Opcodes.NEW_ARRAY); + bytecodeCompiler.emitReg(sliceValuesReg); + bytecodeCompiler.emit(Opcodes.ARRAY_SET_FROM_LIST); + bytecodeCompiler.emitReg(sliceValuesReg); + bytecodeCompiler.emitReg(valueReg); + + // Emit direct opcode HASH_SLICE_SET using the materialized RHS values. bytecodeCompiler.emit(Opcodes.HASH_SLICE_SET); bytecodeCompiler.emitReg(hashReg); bytecodeCompiler.emitReg(keysListReg); - bytecodeCompiler.emitReg(valueReg); + bytecodeCompiler.emitReg(sliceValuesReg); - bytecodeCompiler.lastResultReg = valueReg; + bytecodeCompiler.lastResultReg = sliceValuesReg; return; } else if (hashOp.operator.equals("$")) { diff --git a/src/main/java/org/perlonjava/backend/bytecode/InterpretedCode.java b/src/main/java/org/perlonjava/backend/bytecode/InterpretedCode.java index 940d1c79a..f6a1a3490 100644 --- a/src/main/java/org/perlonjava/backend/bytecode/InterpretedCode.java +++ b/src/main/java/org/perlonjava/backend/bytecode/InterpretedCode.java @@ -337,10 +337,18 @@ public RuntimeList apply(RuntimeArray args, int callContext) { if (warningBitsString != null) { WarningBitsRegistry.pushCurrent(warningBitsString); } + int cleanupMark = MyVarCleanupStack.pushMark(); try { return RuntimeCode.coerceScalarCallResult( BytecodeInterpreter.execute(this, args, effectiveContext), effectiveContext, callContext); + } catch (RuntimeException e) { + if (!(e instanceof PerlExitException)) { + MyVarCleanupStack.unwindTo(cleanupMark); + MortalList.flush(); + } + throw e; } finally { + MyVarCleanupStack.popMark(cleanupMark); if (warningBitsString != null) { WarningBitsRegistry.popCurrent(); } @@ -365,11 +373,19 @@ public RuntimeList apply(String subroutineName, RuntimeArray args, int callConte if (warningBitsString != null) { WarningBitsRegistry.pushCurrent(warningBitsString); } + int cleanupMark = MyVarCleanupStack.pushMark(); try { return RuntimeCode.coerceScalarCallResult( BytecodeInterpreter.execute(this, args, effectiveContext, subroutineName), effectiveContext, callContext); + } catch (RuntimeException e) { + if (!(e instanceof PerlExitException)) { + MyVarCleanupStack.unwindTo(cleanupMark); + MortalList.flush(); + } + throw e; } finally { + MyVarCleanupStack.popMark(cleanupMark); if (warningBitsString != null) { WarningBitsRegistry.popCurrent(); } diff --git a/src/main/java/org/perlonjava/backend/jvm/EmitterMethodCreator.java b/src/main/java/org/perlonjava/backend/jvm/EmitterMethodCreator.java index c0f6e53fd..abd6831cd 100644 --- a/src/main/java/org/perlonjava/backend/jvm/EmitterMethodCreator.java +++ b/src/main/java/org/perlonjava/backend/jvm/EmitterMethodCreator.java @@ -959,6 +959,11 @@ private static byte[] getBytecodeInternal(EmitterContext ctx, Node ast, boolean "org/perlonjava/runtime/runtimetypes/MortalList", "evalExceptionScopeCleanup", "(Ljava/lang/Object;)V", false); + mv.visitVarInsn(Opcodes.ALOAD, localIdx); + mv.visitMethodInsn(Opcodes.INVOKESTATIC, + "org/perlonjava/runtime/runtimetypes/MyVarCleanupStack", + "unregister", + "(Ljava/lang/Object;)V", false); mv.visitInsn(Opcodes.ACONST_NULL); mv.visitVarInsn(Opcodes.ASTORE, localIdx); } diff --git a/src/main/java/org/perlonjava/frontend/parser/StringParser.java b/src/main/java/org/perlonjava/frontend/parser/StringParser.java index 4203e8a23..41fabd1d9 100644 --- a/src/main/java/org/perlonjava/frontend/parser/StringParser.java +++ b/src/main/java/org/perlonjava/frontend/parser/StringParser.java @@ -8,6 +8,8 @@ import org.perlonjava.frontend.lexer.LexerToken; import org.perlonjava.frontend.lexer.LexerTokenType; import org.perlonjava.runtime.runtimetypes.PerlCompilerException; +import org.perlonjava.runtime.runtimetypes.GlobalVariable; +import org.perlonjava.runtime.runtimetypes.RuntimeScalar; import java.util.ArrayList; import java.util.List; @@ -17,6 +19,7 @@ import static org.perlonjava.runtime.perlmodule.Strict.HINT_RE_ASCII; import static org.perlonjava.runtime.perlmodule.Strict.HINT_RE_EVAL; import static org.perlonjava.runtime.perlmodule.Strict.HINT_RE_UNICODE; +import static org.perlonjava.runtime.runtimetypes.NameNormalizer.normalizeVariableName; import static org.perlonjava.runtime.runtimetypes.ScalarUtils.printable; /* @@ -712,6 +715,16 @@ public static Node parseRawString(Parser parser, String operator) { // before passing to glob(). This ensures variables are interpolated. Node interpolated = StringDoubleQuoted.parseDoubleQuotedString( parser.ctx, rawStr, true, true, false, parser.getHeredocNodes(), parser); + RuntimeScalar globOverride = findGlobOverride(parser); + if (globOverride != null) { + OperatorNode codeRefNode = new OperatorNode("&", + new IdentifierNode("glob", rawStr.index), + rawStr.index); + codeRefNode.setAnnotation("parseTimeCodeRef", globOverride); + ListNode arguments = new ListNode(rawStr.index); + arguments.elements.add(interpolated); + return new BinaryOperatorNode("(", codeRefNode, arguments, rawStr.index); + } ListNode diamondList = new ListNode(rawStr.index); diamondList.elements.add(interpolated); return new OperatorNode("<>", diamondList, rawStr.index); @@ -726,6 +739,17 @@ public static Node parseRawString(Parser parser, String operator) { return new OperatorNode(operator, list, rawStr.index); } + private static RuntimeScalar findGlobOverride(Parser parser) { + String currentGlob = normalizeVariableName("glob", parser.ctx.symbolTable.getCurrentPackage()); + if (GlobalVariable.existsGlobalCodeRef(currentGlob)) { + return GlobalVariable.getGlobalCodeRef(currentGlob); + } + if (GlobalVariable.existsGlobalCodeRef("CORE::GLOBAL::glob")) { + return GlobalVariable.getGlobalCodeRef("CORE::GLOBAL::glob"); + } + return null; + } + static StringNode parseVstring(Parser parser, String vStringPart, int currentIndex) { // Start constructing the v-string StringBuilder vStringBuilder = new StringBuilder(); diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/MortalList.java b/src/main/java/org/perlonjava/runtime/runtimetypes/MortalList.java index 8c5479177..4c967d09d 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/MortalList.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/MortalList.java @@ -74,6 +74,10 @@ public static java.util.List snapshotTemporaryRoots() { return new java.util.ArrayList<>(temporaryRoots.get()); } + public static boolean hasTemporaryRoots() { + return !temporaryRoots.get().isEmpty(); + } + /** * Phase I: O(1) check whether the given scalar is in * {@link #deferredCaptures}. Used by the reachability walker to @@ -245,9 +249,10 @@ public static void deferDecrementIfTracked(RuntimeScalar scalar) { * Release a scope-exited closure capture. This is normally the same as * {@link #deferDecrementIfTracked}, but DBIC's leak tracer can wrap * Try::Tiny blocks with {@code goto} and weak refs, making a captured - * temporary consume the counted owner of an outer lexical that is still - * live. In that case, transfer the counted owner to the still-live scalar - * by clearing this capture's ownership without decrementing the referent. + * temporary consume the counted owner of package-global metadata. In that + * case, transfer ownership only when the referent is still reachable from a + * non-lexical root; stack-local temporaries must release normally so + * DESTROY fires at lexical scope exit. */ public static void releaseCapturedDecrement(RuntimeScalar scalar) { if (!active || scalar == null) return; @@ -256,7 +261,7 @@ public static void releaseCapturedDecrement(RuntimeScalar scalar) { && scalar.value instanceof RuntimeBase base && base.blessId != 0 && WeakRefRegistry.hasWeakRefsTo(base) - && isReachableFromLiveRootForCaptureRelease(base)) { + && isReachableFromNonLexicalRootForCaptureRelease(base)) { scalar.refCountOwned = false; if (base.refCountTrace) { base.traceRefCount(0, "MortalList.releaseCapturedDecrement (transferred to live scalar)"); @@ -942,17 +947,14 @@ private static void invalidateDrainReachabilityCaches() { invalidateLiveRootSnapshot(); } - private static boolean isReachableFromLiveRootForCaptureRelease(RuntimeBase base) { - if (liveRootSnapshot == null) { - liveRootSnapshot = new ReachabilityWalker.LiveRootSnapshot(); - } - if (liveRootSnapshot.isReachable(base)) { + private static boolean isReachableFromNonLexicalRootForCaptureRelease(RuntimeBase base) { + if (ReachabilityWalker.isReachableFromTemporaryRoots(base)) { return true; } - // Compatibility fallback for uncommon non-flush callers. The hot - // releaseCaptures path runs while MortalList is flushing and must not - // force a JVM GC for every captured scalar. - return !flushing && ReachabilityWalker.isReachableFromLiveScalarRegistry(base); + if (externalRootSnapshot == null) { + externalRootSnapshot = new ReachabilityWalker.ExternalRootSnapshot(); + } + return externalRootSnapshot.isReachableFromNonLexicalRoot(base); } private static void processDeferredBase(RuntimeBase base, boolean clearWeakRefsForLocalBinding) { @@ -1069,6 +1071,7 @@ private static void maybeAutoSweep() { // defined until the init completes. if (ModuleInitGuard.inModuleInit()) return; if (RuntimeCode.argsStackDepth() > 1) return; + if (hasTemporaryRoots()) return; if (!FORCE_SWEEP_EVERY_FLUSH && !immediateSweep) { long now = System.nanoTime(); if (now - lastAutoSweepNanos < AUTO_SWEEP_MIN_INTERVAL_NS) return; diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/MyVarCleanupStack.java b/src/main/java/org/perlonjava/runtime/runtimetypes/MyVarCleanupStack.java index e7b53d4c8..26d571c3a 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/MyVarCleanupStack.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/MyVarCleanupStack.java @@ -170,6 +170,11 @@ private static void decLiveCount(Object var) { private static void noteVarLeftScope(Object var) { if (var instanceof RuntimeBase base && WeakRefRegistry.hasWeakRefsTo(base)) { MortalList.requestImmediateWeakSweep(); + } else if (var instanceof RuntimeScalar scalar + && (scalar.type & RuntimeScalarType.REFERENCE_BIT) != 0 + && scalar.value instanceof RuntimeBase base + && WeakRefRegistry.hasWeakRefsTo(base)) { + MortalList.requestImmediateWeakSweep(); } } diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/ReachabilityWalker.java b/src/main/java/org/perlonjava/runtime/runtimetypes/ReachabilityWalker.java index faa4add62..07fae75e6 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/ReachabilityWalker.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/ReachabilityWalker.java @@ -63,6 +63,13 @@ public ReachabilityWalker withLexicalSeeds(boolean v) { return this; } + private static boolean isNonOwningDebugArgsArray(String name) { + // @DB::args aliases caller arguments for debugger/Carp introspection. + // It is not an owning root after the source frame has unwound; live + // frames are already represented by RuntimeCode.snapshotArgsStack(). + return "DB::args".equals(name); + } + /** * Walk from Perl-visible roots and mark reachable objects. *

@@ -100,6 +107,7 @@ public Set walk() { visitScalar(e.getValue(), todo); } for (Map.Entry e : GlobalVariable.globalArrays.entrySet()) { + if (isNonOwningDebugArgsArray(e.getKey())) continue; addReachable(e.getValue(), todo); } for (Map.Entry e : GlobalVariable.globalHashes.entrySet()) { @@ -259,6 +267,7 @@ public static java.util.List findPathTo(RuntimeBase target, boolean skip seedPath(e.getValue(), "$" + e.getKey(), howReached, todo); } for (Map.Entry e : GlobalVariable.globalArrays.entrySet()) { + if (isNonOwningDebugArgsArray(e.getKey())) continue; if (howReached.putIfAbsent(e.getValue(), "@" + e.getKey()) == null) todo.add(e.getValue()); } for (Map.Entry e : GlobalVariable.globalHashes.entrySet()) { @@ -293,6 +302,8 @@ public static java.util.List findPathTo(RuntimeBase target, boolean skip if (sc == null) continue; if (sc.captureCount > 0) continue; if (WeakRefRegistry.isweak(sc)) continue; + if (MortalList.isDeferredCapture(sc)) continue; + if (!MyVarCleanupStack.isLive(sc)) continue; if ((sc.type & RuntimeScalarType.REFERENCE_BIT) != 0 && sc.value instanceof RuntimeBase b) { String label = " findPathTo(RuntimeBase target, boolean skip } } } + int liveVarIdx = 0; + for (Object liveVar : MyVarCleanupStack.snapshotLiveVars()) { + String label = ""; + if (liveVar instanceof RuntimeScalar sc) { + seedPath(sc, label, howReached, todo); + } else if (liveVar instanceof RuntimeBase rb) { + if (howReached.putIfAbsent(rb, label) == null) todo.add(rb); + } + } + int argsIdx = 0; + for (RuntimeArray args : RuntimeCode.snapshotArgsStack()) { + if (howReached.putIfAbsent(args, "") == null) { + todo.add(args); + } + } + int tempIdx = 0; + for (RuntimeBase tempRoot : MortalList.snapshotTemporaryRoots()) { + if (howReached.putIfAbsent(tempRoot, "") == null) { + todo.add(tempRoot); + } + } } while (!todo.isEmpty()) { RuntimeBase cur = todo.removeFirst(); @@ -654,6 +688,7 @@ public static boolean isScalarReachable(RuntimeScalar target) { if (e.getValue() != null && seen.add(e.getValue())) todo.addLast(e.getValue()); } for (Map.Entry e : GlobalVariable.globalArrays.entrySet()) { + if (isNonOwningDebugArgsArray(e.getKey())) continue; if (seen.add(e.getValue())) todo.addLast(e.getValue()); } for (Map.Entry e : GlobalVariable.globalHashes.entrySet()) { @@ -761,6 +796,7 @@ public static boolean isReachableFromRoots(RuntimeBase target, boolean globalOnl if (seen.contains(target)) return true; } for (Map.Entry e : GlobalVariable.globalArrays.entrySet()) { + if (isNonOwningDebugArgsArray(e.getKey())) continue; if (e.getValue() == target) return true; if (seen.add(e.getValue())) todo.addLast(e.getValue()); } @@ -991,6 +1027,7 @@ private void buildNonLexicalRoots(boolean includeRescued) { seedNonLexicalScalar(e.getValue(), todo); } for (Map.Entry e : GlobalVariable.globalArrays.entrySet()) { + if (isNonOwningDebugArgsArray(e.getKey())) continue; addNonLexical(e.getValue(), todo); } for (Map.Entry e : GlobalVariable.globalHashes.entrySet()) { @@ -1334,7 +1371,11 @@ public static int sweepWeakRefs(boolean quiet, boolean forceJvmGc) { ? collectStrongCycleProtected() : Collections.emptySet(); for (RuntimeBase referent : WeakRefRegistry.snapshotWeakRefReferents()) { - if (!live.contains(referent)) { + boolean liveReferent = live.contains(referent); + boolean localBinding = (referent instanceof RuntimeHash || referent instanceof RuntimeArray) + && referent.localBindingExists; + boolean cycleProtected = quiet && strongCycleProtected.contains(referent); + if (!liveReferent) { // A named hash/array lexical (`my %h`, `my @a`) is NOT a // walker root — the walker only seeds from globals and // ScalarRefRegistry (scalars). If `\%h` was weakened, @@ -1346,8 +1387,7 @@ public static int sweepWeakRefs(boolean quiet, boolean forceJvmGc) { // Scope exit (scopeExitCleanupHash/Array) will clear // the flag and let a later sweep reap it if truly dead. // Fixes op/hashassign.t 218 (bug #76716). - if ((referent instanceof RuntimeHash || referent instanceof RuntimeArray) - && referent.localBindingExists) { + if (localBinding) { continue; } // Phase I (52leaks/60core): skip clearing weak refs to @@ -1388,7 +1428,7 @@ && isCapturedByWeakBackrefCode(referent)) { // Perl's refcounting keeps such cycle islands alive. This // covers callback-retained futures where the outer future is // cyclic and inner sequence futures are strong children. - if (quiet && strongCycleProtected.contains(referent)) { + if (cycleProtected) { continue; } toClear.add(referent); diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeBase.java b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeBase.java index e74562394..aa23da9ac 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeBase.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeBase.java @@ -163,10 +163,14 @@ public int activeOwnerCount() { public int reachableOwnerCount() { if (activeOwners == null) return 0; int count = 0; - for (RuntimeScalar sc : activeOwners) { + java.util.Iterator it = activeOwners.iterator(); + while (it.hasNext()) { + RuntimeScalar sc = it.next(); if (sc != null && sc.refCountOwned && sc.value == this && ReachabilityWalker.isScalarReachable(sc)) { count++; + } else if (sc == null || !sc.refCountOwned || sc.value != this) { + it.remove(); } } return count; diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/WeakRefRegistry.java b/src/main/java/org/perlonjava/runtime/runtimetypes/WeakRefRegistry.java index b3b9d3418..a19ee4c85 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/WeakRefRegistry.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/WeakRefRegistry.java @@ -96,6 +96,7 @@ public static void weaken(RuntimeScalar ref) { referentToWeakRefs .computeIfAbsent(base, k -> Collections.newSetFromMap(new IdentityHashMap<>())) .add(ref); + base.activateOwnerTracking(); ref.releaseClosureCaptureReferentsForWeaken(base); if (System.getenv("PJ_WEAKCLEAR_TRACE") != null) { System.err.println("[WEAKEN] ref=" + System.identityHashCode(ref) diff --git a/src/main/perl/lib/CPAN/Config.pm b/src/main/perl/lib/CPAN/Config.pm index 1265b3707..87421774a 100644 --- a/src/main/perl/lib/CPAN/Config.pm +++ b/src/main/perl/lib/CPAN/Config.pm @@ -94,7 +94,9 @@ sub _bootstrap_prefs { 'HTML-Parser.yml' => 'PerlOnJava/CpanDistroprefs/HTML-Parser.yml', 'Graph.yml' => 'PerlOnJava/CpanDistroprefs/Graph.yml', 'Set-Object.yml' => 'PerlOnJava/CpanDistroprefs/Set-Object.yml', + 'Class-DBI.yml' => 'PerlOnJava/CpanDistroprefs/Class-DBI.yml', 'XML-Filter-GenericChunk.yml' => 'PerlOnJava/CpanDistroprefs/XML-Filter-GenericChunk.yml', + 'XML-TreePP.yml' => 'PerlOnJava/CpanDistroprefs/XML-TreePP.yml', 'HTTP-Message.yml' => 'PerlOnJava/CpanDistroprefs/HTTP-Message.yml', 'HTTP-Response-Encoding.yml' => 'PerlOnJava/CpanDistroprefs/HTTP-Response-Encoding.yml', 'HTTP-Daemon.yml' => 'PerlOnJava/CpanDistroprefs/HTTP-Daemon.yml', @@ -245,6 +247,10 @@ sub _bootstrap_patches { 'PerlOnJava/CpanPatches/Parse-RecDescent-1.967015/SkipReproducibleStandalone.patch' ], [ 'XML-FromPerl-0.01/Makefile.PL.patch', 'PerlOnJava/CpanPatches/XML-FromPerl-0.01/Makefile.PL.patch' ], + [ 'Class-DBI-v3.0.17/Class-DBI.pm.patch', + 'PerlOnJava/CpanPatches/Class-DBI-v3.0.17/Class-DBI.pm.patch' ], + [ 'XML-TreePP-0.43/TreePP.pm.patch', + 'PerlOnJava/CpanPatches/XML-TreePP-0.43/TreePP.pm.patch' ], [ 'Graph-0.9735/Graph.pm.patch', 'PerlOnJava/CpanPatches/Graph-0.9735/Graph.pm.patch' ], [ 'Graph-0.9735/AdjacencyMap.pm.patch', diff --git a/src/main/perl/lib/DBD/ExampleP.pm b/src/main/perl/lib/DBD/ExampleP.pm new file mode 100644 index 000000000..786140b48 --- /dev/null +++ b/src/main/perl/lib/DBD/ExampleP.pm @@ -0,0 +1,436 @@ +{ + package DBD::ExampleP; + + use strict; + use warnings; + use Symbol; + + use DBI qw(:sql_types); + + require File::Spec; + + our (@EXPORT,$VERSION,@statnames,%statnames,@stattypes,%stattypes, + @statprec,%statprec,$drh,); + + @EXPORT = qw(); # Do NOT @EXPORT anything. + $VERSION = "12.014311"; + +# $Id: ExampleP.pm 14310 2010-08-02 06:35:25Z Jens $ +# +# Copyright (c) 1994,1997,1998 Tim Bunce +# +# You may distribute under the terms of either the GNU General Public +# License or the Artistic License, as specified in the Perl README file. + + @statnames = qw(dev ino mode nlink + uid gid rdev size + atime mtime ctime + blksize blocks name); + @statnames{@statnames} = (0 .. @statnames-1); + + @stattypes = (SQL_INTEGER, SQL_INTEGER, SQL_INTEGER, SQL_INTEGER, + SQL_INTEGER, SQL_INTEGER, SQL_INTEGER, SQL_INTEGER, + SQL_INTEGER, SQL_INTEGER, SQL_INTEGER, + SQL_INTEGER, SQL_INTEGER, SQL_VARCHAR); + @stattypes{@statnames} = @stattypes; + @statprec = ((10) x (@statnames-1), 1024); + @statprec{@statnames} = @statprec; + die unless @statnames == @stattypes; + die unless @statprec == @stattypes; + + $drh = undef; # holds driver handle once initialised + #$gensym = "SYM000"; # used by st::execute() for filehandles + + sub driver{ + return $drh if $drh; + my($class, $attr) = @_; + $class .= "::dr"; + ($drh) = DBI::_new_drh($class, { + 'Name' => 'ExampleP', + 'Version' => $VERSION, + 'Attribution' => 'DBD Example Perl stub by Tim Bunce', + }, ['example implementors private data '.__PACKAGE__]); + $drh; + } + + sub CLONE { + undef $drh; + } +} + + +{ package DBD::ExampleP::dr; # ====== DRIVER ====== + $imp_data_size = 0; + use strict; + + sub connect { # normally overridden, but a handy default + my($drh, $dbname, $user, $auth)= @_; + my ($outer, $dbh) = DBI::_new_dbh($drh, { + Name => $dbname, + examplep_private_dbh_attrib => 42, # an example, for testing + }); + $dbh->{examplep_get_info} = { + 29 => '"', # SQL_IDENTIFIER_QUOTE_CHAR + 41 => '.', # SQL_CATALOG_NAME_SEPARATOR + 114 => 1, # SQL_CATALOG_LOCATION + }; + #$dbh->{Name} = $dbname; + $dbh->STORE('Active', 1); + return $outer; + } + + sub data_sources { + return ("dbi:ExampleP:dir=."); # possibly usefully meaningless + } + +} + + +{ package DBD::ExampleP::db; # ====== DATABASE ====== + $imp_data_size = 0; + use strict; + + sub prepare { + my($dbh, $statement)= @_; + my @fields; + my($fields, $dir) = $statement =~ m/^\s*select\s+(.*?)\s+from\s+(\S*)/i; + + if (defined $fields and defined $dir) { + @fields = ($fields eq '*') + ? keys %DBD::ExampleP::statnames + : split(/\s*,\s*/, $fields); + } + else { + return $dbh->set_err($DBI::stderr, "Syntax error in select statement (\"$statement\")") + unless $statement =~ m/^\s*set\s+/; + # the SET syntax is just a hack so the ExampleP driver can + # be used to test non-select statements. + # Now we have DBI::DBM etc., ExampleP should be deprecated + } + + my ($outer, $sth) = DBI::_new_sth($dbh, { + 'Statement' => $statement, + examplep_private_sth_attrib => 24, # an example, for testing + }, ['example implementors private data '.__PACKAGE__]); + + my @bad = map { + defined $DBD::ExampleP::statnames{$_} ? () : $_ + } @fields; + return $dbh->set_err($DBI::stderr, "Unknown field names: @bad") + if @bad; + + $outer->STORE('NUM_OF_FIELDS' => scalar(@fields)); + + $sth->{examplep_ex_dir} = $dir if defined($dir) && $dir !~ /\?/; + $outer->STORE('NUM_OF_PARAMS' => ($dir) ? $dir =~ tr/?/?/ : 0); + + if (@fields) { + $outer->STORE('NAME' => \@fields); + $outer->STORE('NULLABLE' => [ (0) x @fields ]); + $outer->STORE('SCALE' => [ (0) x @fields ]); + } + + $outer; + } + + + sub table_info { + my $dbh = shift; + my ($catalog, $schema, $table, $type) = @_; + + my @types = split(/["']*,["']/, $type || 'TABLE'); + my %types = map { $_=>$_ } @types; + + # Return a list of all subdirectories + my $dh = Symbol::gensym(); # "DBD::ExampleP::".++$DBD::ExampleP::gensym; + my $dir = $catalog || File::Spec->curdir(); + my @list; + if ($types{VIEW}) { # for use by test harness + push @list, [ undef, "schema", "table", 'VIEW', undef ]; + push @list, [ undef, "sch-ema", "table", 'VIEW', undef ]; + push @list, [ undef, "schema", "ta-ble", 'VIEW', undef ]; + push @list, [ undef, "sch ema", "table", 'VIEW', undef ]; + push @list, [ undef, "schema", "ta ble", 'VIEW', undef ]; + } + if ($types{TABLE}) { + no strict 'refs'; + opendir($dh, $dir) + or return $dbh->set_err(int($!), "Failed to open directory $dir: $!"); + while (defined(my $item = readdir($dh))) { + if ($^O eq 'VMS') { + # if on VMS then avoid warnings from catdir if you use a file + # (not a dir) as the item below + next if $item !~ /\.dir$/oi; + } + my $file = File::Spec->catdir($dir,$item); + next unless -d $file; + my($dev, $ino, $mode, $nlink, $uid) = lstat($file); + my $pwnam = undef; # eval { scalar(getpwnam($uid)) } || $uid; + push @list, [ $dir, $pwnam, $item, 'TABLE', undef ]; + } + close($dh); + } + # We would like to simply do a DBI->connect() here. However, + # this is wrong if we are in a subclass like DBI::ProxyServer. + $dbh->{'dbd_sponge_dbh'} ||= DBI->connect("DBI:Sponge:", '','') + or return $dbh->set_err($DBI::err, + "Failed to connect to DBI::Sponge: $DBI::errstr"); + + my $attr = { + 'rows' => \@list, + 'NUM_OF_FIELDS' => 5, + 'NAME' => ['TABLE_CAT', 'TABLE_SCHEM', 'TABLE_NAME', + 'TABLE_TYPE', 'REMARKS'], + 'TYPE' => [DBI::SQL_VARCHAR(), DBI::SQL_VARCHAR(), + DBI::SQL_VARCHAR(), DBI::SQL_VARCHAR(), DBI::SQL_VARCHAR() ], + 'NULLABLE' => [1, 1, 1, 1, 1] + }; + my $sdbh = $dbh->{'dbd_sponge_dbh'}; + my $sth = $sdbh->prepare("SHOW TABLES FROM $dir", $attr) + or return $dbh->set_err($sdbh->err(), $sdbh->errstr()); + $sth; + } + + + sub type_info_all { + my ($dbh) = @_; + my $ti = [ + { TYPE_NAME => 0, + DATA_TYPE => 1, + COLUMN_SIZE => 2, + LITERAL_PREFIX => 3, + LITERAL_SUFFIX => 4, + CREATE_PARAMS => 5, + NULLABLE => 6, + CASE_SENSITIVE => 7, + SEARCHABLE => 8, + UNSIGNED_ATTRIBUTE=> 9, + FIXED_PREC_SCALE=> 10, + AUTO_UNIQUE_VALUE => 11, + LOCAL_TYPE_NAME => 12, + MINIMUM_SCALE => 13, + MAXIMUM_SCALE => 14, + }, + [ 'VARCHAR', DBI::SQL_VARCHAR, 1024, "'","'", undef, 0, 1, 1, 0, 0,0,undef,0,0 ], + [ 'INTEGER', DBI::SQL_INTEGER, 10, "","", undef, 0, 0, 1, 0, 0,0,undef,0,0 ], + ]; + return $ti; + } + + + sub ping { + (shift->FETCH('Active')) ? 2 : 0; # the value 2 is checked for by t/80proxy.t + } + + + sub disconnect { + shift->STORE(Active => 0); + return 1; + } + + + sub get_info { + my ($dbh, $info_type) = @_; + return $dbh->{examplep_get_info}->{$info_type}; + } + + + sub FETCH { + my ($dbh, $attrib) = @_; + # In reality this would interrogate the database engine to + # either return dynamic values that cannot be precomputed + # or fetch and cache attribute values too expensive to prefetch. + # else pass up to DBI to handle + return $INC{"DBD/ExampleP.pm"} if $attrib eq 'example_driver_path'; + return $dbh->SUPER::FETCH($attrib); + } + + + sub STORE { + my ($dbh, $attrib, $value) = @_; + # store only known attributes else pass up to DBI to handle + if ($attrib eq 'examplep_set_err') { + # a fake attribute to enable a test case where STORE issues a warning + $dbh->set_err($value, $value); + return; + } + if ($attrib eq 'AutoCommit') { + # convert AutoCommit values to magic ones to let DBI + # know that the driver has 'handled' the AutoCommit attribute + $value = ($value) ? -901 : -900; + } + return $dbh->{$attrib} = $value if $attrib =~ /^examplep_/; + return $dbh->SUPER::STORE($attrib, $value); + } + + sub DESTROY { + my $dbh = shift; + $dbh->disconnect if $dbh->FETCH('Active'); + undef + } + + + # This is an example to demonstrate the use of driver-specific + # methods via $dbh->func(). + # Use it as follows: + # my @tables = $dbh->func($re, 'examplep_tables'); + # + # Returns all the tables that match the regular expression $re. + sub examplep_tables { + my $dbh = shift; my $re = shift; + grep { $_ =~ /$re/ } $dbh->tables(); + } + + sub parse_trace_flag { + my ($h, $name) = @_; + return 0x01000000 if $name eq 'foo'; + return 0x02000000 if $name eq 'bar'; + return 0x04000000 if $name eq 'baz'; + return 0x08000000 if $name eq 'boo'; + return 0x10000000 if $name eq 'bop'; + return $h->SUPER::parse_trace_flag($name); + } + + sub private_attribute_info { + return { example_driver_path => undef }; + } +} + + +{ package DBD::ExampleP::st; # ====== STATEMENT ====== + $imp_data_size = 0; + use strict; no strict 'refs'; # cause problems with filehandles + + sub bind_param { + my($sth, $param, $value, $attribs) = @_; + $sth->{'dbd_param'}->[$param-1] = $value; + return 1; + } + + + sub execute { + my($sth, @dir) = @_; + my $dir; + + if (@dir) { + $sth->bind_param($_, $dir[$_-1]) or return + foreach (1..@dir); + } + + my $dbd_param = $sth->{'dbd_param'} || []; + return $sth->set_err(2, @$dbd_param." values bound when $sth->{NUM_OF_PARAMS} expected") + unless @$dbd_param == $sth->{NUM_OF_PARAMS}; + + return 0 unless $sth->{NUM_OF_FIELDS}; # not a select + + $dir = $dbd_param->[0] || $sth->{examplep_ex_dir}; + return $sth->set_err(2, "No bind parameter supplied") + unless defined $dir; + + $sth->finish; + + # + # If the users asks for directory "long_list_4532", then we fake a + # directory with files "file4351", "file4350", ..., "file0". + # This is a special case used for testing, especially DBD::Proxy. + # + if ($dir =~ /^long_list_(\d+)$/) { + $sth->{dbd_dir} = [ $1 ]; # array ref indicates special mode + $sth->{dbd_datahandle} = undef; + } + else { + $sth->{dbd_dir} = $dir; + my $sym = Symbol::gensym(); # "DBD::ExampleP::".++$DBD::ExampleP::gensym; + opendir($sym, $dir) + or return $sth->set_err(2, "opendir($dir): $!"); + $sth->{dbd_datahandle} = $sym; + } + $sth->STORE(Active => 1); + return 1; + } + + + sub fetch { + my $sth = shift; + my $dir = $sth->{dbd_dir}; + my %s; + + if (ref $dir) { # special fake-data test mode + my $num = $dir->[0]--; + unless ($num > 0) { + $sth->finish(); + return; + } + my $time = time; + @s{@DBD::ExampleP::statnames} = + ( 2051, 1000+$num, 0644, 2, $>, $), 0, 1024, + $time, $time, $time, 512, 2, "file$num") + } + else { # normal mode + my $dh = $sth->{dbd_datahandle} + or return $sth->set_err($DBI::stderr, "fetch without successful execute"); + my $f = readdir($dh); + unless ($f) { + $sth->finish; + return; + } + # untaint $f so that we can use this for DBI taint tests + ($f) = ($f =~ m/^(.*)$/); + my $file = File::Spec->catfile($dir, $f); + # put in all the data fields + @s{ @DBD::ExampleP::statnames } = (lstat($file), $f); + } + + # return just what fields the query asks for + my @new = @s{ @{$sth->{NAME}} }; + + return $sth->_set_fbav(\@new); + } + *fetchrow_arrayref = \&fetch; + + + sub finish { + my $sth = shift; + closedir($sth->{dbd_datahandle}) if $sth->{dbd_datahandle}; + $sth->{dbd_datahandle} = undef; + $sth->{dbd_dir} = undef; + $sth->SUPER::finish(); + return 1; + } + + + sub FETCH { + my ($sth, $attrib) = @_; + # In reality this would interrogate the database engine to + # either return dynamic values that cannot be precomputed + # or fetch and cache attribute values too expensive to prefetch. + if ($attrib eq 'TYPE'){ + return [ @DBD::ExampleP::stattypes{ @{ $sth->FETCH(q{NAME_lc}) } } ]; + } + elsif ($attrib eq 'PRECISION'){ + return [ @DBD::ExampleP::statprec{ @{ $sth->FETCH(q{NAME_lc}) } } ]; + } + elsif ($attrib eq 'ParamValues') { + my $dbd_param = $sth->{dbd_param} || []; + my %pv = map { $_ => $dbd_param->[$_-1] } 1..@$dbd_param; + return \%pv; + } + # else pass up to DBI to handle + return $sth->SUPER::FETCH($attrib); + } + + + sub STORE { + my ($sth, $attrib, $value) = @_; + # would normally validate and only store known attributes + # else pass up to DBI to handle + return $sth->{$attrib} = $value + if $attrib eq 'NAME' or $attrib eq 'NULLABLE' or $attrib eq 'SCALE' or $attrib eq 'PRECISION'; + return $sth->SUPER::STORE($attrib, $value); + } + + *parse_trace_flag = \&DBD::ExampleP::db::parse_trace_flag; +} + +1; +# vim: sw=4:ts=8 diff --git a/src/main/perl/lib/DBD/Sponge.pm b/src/main/perl/lib/DBD/Sponge.pm new file mode 100644 index 000000000..b8e22ea27 --- /dev/null +++ b/src/main/perl/lib/DBD/Sponge.pm @@ -0,0 +1,306 @@ +use strict; +use warnings; +{ + package DBD::Sponge; + + require DBI; + require Carp; + + our @EXPORT = qw(); # Do NOT @EXPORT anything. + our $VERSION = "12.010003"; + +# $Id: Sponge.pm 10002 2007-09-26 21:03:25Z Tim $ +# +# Copyright (c) 1994-2003 Tim Bunce Ireland +# +# You may distribute under the terms of either the GNU General Public +# License or the Artistic License, as specified in the Perl README file. + + our $drh = undef; # holds driver handle once initialised + my $methods_already_installed; + + sub driver{ + return $drh if $drh; + + DBD::Sponge::db->install_method("sponge_test_installed_method") + unless $methods_already_installed++; + + my($class, $attr) = @_; + $class .= "::dr"; + ($drh) = DBI::_new_drh($class, { + 'Name' => 'Sponge', + 'Version' => $VERSION, + 'Attribution' => "DBD::Sponge $VERSION (fake cursor driver) by Tim Bunce", + }); + $drh; + } + + sub CLONE { + undef $drh; + } +} + + +{ package DBD::Sponge::dr; # ====== DRIVER ====== + our $imp_data_size = 0; + # we use default (dummy) connect method +} + + +{ package DBD::Sponge::db; # ====== DATABASE ====== + our $imp_data_size = 0; + use strict; + + sub prepare { + my($dbh, $statement, $attribs) = @_; + my $rows = delete $attribs->{'rows'} + or return $dbh->set_err($DBI::stderr,"No rows attribute supplied to prepare"); + my ($outer, $sth) = DBI::_new_sth($dbh, { + 'Statement' => $statement, + 'rows' => $rows, + (map { exists $attribs->{$_} ? ($_=>$attribs->{$_}) : () } + qw(execute_hook) + ), + }); + if (my $behave_like = $attribs->{behave_like}) { + $outer->{$_} = $behave_like->{$_} + foreach (qw(RaiseError PrintError HandleError ShowErrorStatement)); + } + + if ($statement =~ /^\s*insert\b/) { # very basic, just for testing execute_array() + $sth->{is_insert} = 1; + my $NUM_OF_PARAMS = $attribs->{NUM_OF_PARAMS} + or return $dbh->set_err($DBI::stderr,"NUM_OF_PARAMS not specified for INSERT statement"); + $sth->STORE('NUM_OF_PARAMS' => $attribs->{NUM_OF_PARAMS} ); + } + else { #assume select + + # we need to set NUM_OF_FIELDS + my $numFields; + if ($attribs->{'NUM_OF_FIELDS'}) { + $numFields = $attribs->{'NUM_OF_FIELDS'}; + } elsif ($attribs->{'NAME'}) { + $numFields = @{$attribs->{NAME}}; + } elsif ($attribs->{'TYPE'}) { + $numFields = @{$attribs->{TYPE}}; + } elsif (my $firstrow = $rows->[0]) { + $numFields = scalar @$firstrow; + } else { + return $dbh->set_err($DBI::stderr, 'Cannot determine NUM_OF_FIELDS'); + } + $sth->STORE('NUM_OF_FIELDS' => $numFields); + $sth->{NAME} = $attribs->{NAME} + || [ map { "col$_" } 1..$numFields ]; + $sth->{TYPE} = $attribs->{TYPE} + || [ (DBI::SQL_VARCHAR()) x $numFields ]; + $sth->{PRECISION} = $attribs->{PRECISION} + || [ map { length($sth->{NAME}->[$_]) } 0..$numFields -1 ]; + $sth->{SCALE} = $attribs->{SCALE} + || [ (0) x $numFields ]; + $sth->{NULLABLE} = $attribs->{NULLABLE} + || [ (2) x $numFields ]; + } + + $outer; + } + + sub type_info_all { + my ($dbh) = @_; + my $ti = [ + { TYPE_NAME => 0, + DATA_TYPE => 1, + PRECISION => 2, + LITERAL_PREFIX => 3, + LITERAL_SUFFIX => 4, + CREATE_PARAMS => 5, + NULLABLE => 6, + CASE_SENSITIVE => 7, + SEARCHABLE => 8, + UNSIGNED_ATTRIBUTE=> 9, + MONEY => 10, + AUTO_INCREMENT => 11, + LOCAL_TYPE_NAME => 12, + MINIMUM_SCALE => 13, + MAXIMUM_SCALE => 14, + }, + [ 'VARCHAR', DBI::SQL_VARCHAR(), undef, "'","'", undef, 0, 1, 1, 0, 0,0,undef,0,0 ], + ]; + return $ti; + } + + sub FETCH { + my ($dbh, $attrib) = @_; + # In reality this would interrogate the database engine to + # either return dynamic values that cannot be precomputed + # or fetch and cache attribute values too expensive to prefetch. + return 1 if $attrib eq 'AutoCommit'; + # else pass up to DBI to handle + return $dbh->SUPER::FETCH($attrib); + } + + sub STORE { + my ($dbh, $attrib, $value) = @_; + # would normally validate and only store known attributes + # else pass up to DBI to handle + if ($attrib eq 'AutoCommit') { + return 1 if $value; # is already set + Carp::croak("Can't disable AutoCommit"); + } + return $dbh->SUPER::STORE($attrib, $value); + } + + sub sponge_test_installed_method { + my ($dbh, @args) = @_; + return $dbh->set_err(42, "not enough parameters") unless @args >= 2; + return \@args; + } +} + + +{ package DBD::Sponge::st; # ====== STATEMENT ====== + our $imp_data_size = 0; + use strict; + + sub execute { + my $sth = shift; + + # hack to support ParamValues (when not using bind_param) + $sth->{ParamValues} = (@_) ? { map { $_ => $_[$_-1] } 1..@_ } : undef; + + if (my $hook = $sth->{execute_hook}) { + &$hook($sth, @_) or return; + } + + if ($sth->{is_insert}) { + my $row; + $row = (@_) ? [ @_ ] : die "bind_param not supported yet" ; + my $NUM_OF_PARAMS = $sth->{NUM_OF_PARAMS}; + return $sth->set_err($DBI::stderr, @$row." values bound (@$row) but $NUM_OF_PARAMS expected") + if @$row != $NUM_OF_PARAMS; + { no warnings; $sth->trace_msg("inserting (@$row)\n"); } + push @{ $sth->{rows} }, $row; + } + else { # mark select sth as Active + $sth->STORE(Active => 1); + } + # else do nothing for select as data is already in $sth->{rows} + return 1; + } + + sub fetch { + my ($sth) = @_; + my $row = shift @{$sth->{'rows'}}; + unless ($row) { + $sth->STORE(Active => 0); + return undef; + } + return $sth->_set_fbav($row); + } + *fetchrow_arrayref = \&fetch; + + sub FETCH { + my ($sth, $attrib) = @_; + # would normally validate and only fetch known attributes + # else pass up to DBI to handle + return $sth->SUPER::FETCH($attrib); + } + + sub STORE { + my ($sth, $attrib, $value) = @_; + # would normally validate and only store known attributes + # else pass up to DBI to handle + return $sth->SUPER::STORE($attrib, $value); + } +} + +1; + +__END__ + +=pod + +=head1 NAME + +DBD::Sponge - Create a DBI statement handle from Perl data + +=head1 SYNOPSIS + + my $sponge = DBI->connect("dbi:Sponge:","","",{ RaiseError => 1 }); + my $sth = $sponge->prepare($statement, { + rows => $data, + NAME => $names, + %attr + } + ); + +=head1 DESCRIPTION + +DBD::Sponge is useful for making a Perl data structure accessible through a +standard DBI statement handle. This may be useful to DBD module authors who +need to transform data in this way. + +=head1 METHODS + +=head2 connect() + + my $sponge = DBI->connect("dbi:Sponge:","","",{ RaiseError => 1 }); + +Here's a sample syntax for creating a database handle for the Sponge driver. +No username and password are needed. + +=head2 prepare() + + my $sth = $sponge->prepare($statement, { + rows => $data, + NAME => $names, + %attr + } + ); + +=over 4 + +=item * + +The C<$statement> here is an arbitrary statement or name you want +to provide as identity of your data. If you're using DBI::Profile +it will appear in the profile data. + +Generally it's expected that you are preparing a statement handle +as if a C