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