diff --git a/dev/modules/dbi_test_parity.md b/dev/modules/dbi_test_parity.md index 3e214fc0c..e70428a64 100644 --- a/dev/modules/dbi_test_parity.md +++ b/dev/modules/dbi_test_parity.md @@ -471,7 +471,7 @@ Triage these once Phase 1 & 2 are done and we have clean output. ## Progress Tracking -### Current Status: Phases 1–6 landed on `fix/dbi-test-parity` (PR #546). Callbacks, HandleSetErr, and errstr accumulation landed in Phase 6. +### Current Status: Phases 1–7 landed on `fix/dbi-test-parity` (PR #546, merged). Phase 8 (RootClass), Phase 9 (upstream DBI.pm switch), and Phase 9b (JDBC restoration) landed on `feature/dbi-phase8-and-arch-switch`. ### Completed @@ -663,6 +663,142 @@ Triage these once Phase 1 & 2 are done and we have clean output. by removing the `!exists` guard in the connect-attr re-application path) +- [x] **2026-04-23 — Phase 8: RootClass subclassing.** + - `DBI->connect` detects `RootClass` (explicit attr or invocant + class ≠ DBI), eagerly `require`s it, and reblesses the outer + dbh/drh/sth into `${RootClass}::db` / `::dr` / `::st`. Failed + `require` dies unconditionally so `eval { connect(...) }` leaves + `$@` set for inspection (real DBI's behaviour). + - RootClass is stashed on the inner dbh so prepared sths inherit + it via `_new_sth`. + - `_new_sth` now inherits the error-handling attributes + (`RaiseError`, `PrintError`, `PrintWarn`, `RaiseWarn`, + `HandleError`, `HandleSetErr`, `ShowErrorStatement`, `Warn`) + from the parent dbh — without this, `set_err` on an sth + couldn't fire `RaiseError` because it looks them up on the + inner hash. + - `DBI::_::OuterHandle::_dispatch_packages` detects the + dr/db/st suffix via `isa()` for subclass-reblessed handles. + - `DBD::_::db::clone` propagates `RootClass` (plus `CompatMode`, + `RaiseError`, `PrintError`) to the cloned handle. + - **Per-test deltas:** + - `t/30subclass.t`: 19/43 → **43/43** + - `t/06attrs.t`: 142/166 → 145/166 + +### Phase 9 (in progress): architectural switch to upstream DBI.pm + +**Status: Phase 9 + 9b landed (2026-04-23).** + +A spike confirmed that **upstream DBI.pm 1.647 + DBI::PurePerl load +and run under PerlOnJava with only a 3-line shim**. This led to a +two-commit architectural switch: + +#### Phase 9 — replace our DBI.pm + _Handles.pm with upstream + +- `src/main/perl/lib/DBI.pm` — upstream DBI 1.647 DBI.pm unchanged + except for a 4-line PerlOnJava patch: force + `$ENV{DBI_PUREPERL} = 2` before the XSLoader-vs-PurePerl decision + block so DBI::PurePerl is always used and XSLoader::load is never + attempted (PerlOnJava has no XS). +- `src/main/perl/lib/DBI/PurePerl.pm` — upstream DBI::PurePerl 1.47 + unchanged. +- Deleted `src/main/perl/lib/DBI/_Handles.pm` (~1500 lines) and + `src/main/perl/lib/DBI/_Utils.pm` — PurePerl provides the same + functionality. +- Bug prerequisite: PerlOnJava now walks `@Pkg::ISA` on qualified + method calls (`$obj->Pkg::method()`). DBI.pm:1345 relies on + `$drh->DBD::_::dr::STORE($k, $v)` routing via + `@DBD::_::dr::ISA = qw(DBD::_::common)` to + `DBD::_::common::STORE`. Fixed in RuntimeCode.java. + +#### Phase 9b — restore JDBC path via DBD::JDBC base driver + +Phase 9 disabled JDBC-backed DBDs because our Java-registered +methods were under `package DBI` and got shadowed by upstream's +`sub connect` / `sub prepare` / etc. This re-plumbs them as a +proper upstream-style DBD: + +- New `PerlModuleBase.registerMethodInPackage(pkg, perlName, + javaName)` helper for arbitrary-package registration. +- `DBI.initialize()` now registers Java methods under + `DBD::JDBC::{dr,db,st}::*` instead of under `DBI::`. `connect` + lives on `::dr`, `prepare`/`do`/`disconnect`/transactions/`*info` + live on `::db`, `execute`/`fetchrow_*`/`rows`/`bind_*` on `::st`. +- All `bless` targets in `DBI.java` retargeted from `DBI::db` / + `DBI::st` / `DBI::dr` to the `DBD::JDBC` equivalents. +- `DBI.initialize()` is now called from `GlobalContext` at + startup (no longer via XSLoader, which doesn't fire with + `DBI_PUREPERL=2`). +- New `src/main/perl/lib/DBD/JDBC.pm` base driver: provides + `driver()` factory, `DBD::JDBC::dr/db/st` classes that inherit + from `DBD::_::{dr,db,st}` and wire the Java methods in. + `DBD::JDBC::st` aliases `fetch` and `fetchrow` to + `fetchrow_arrayref` so Perl's MRO doesn't fall through to + DBD::_::st's recursive defaults. +- `src/main/perl/lib/DBD/SQLite.pm` rewritten to inherit from + `DBD::JDBC`. Its `::dr::connect` translates DSN via + `_dsn_to_jdbc` before delegating to `DBD::JDBC::dr::connect`. +- `src/main/perl/lib/DBD/Mem.pm` deleted — the bundled upstream + DBI ships a real pure-Perl DBD::Mem (built on SQL::Statement) + which our shim was shadowing. Removing the shim lets the real + upstream driver run under PerlOnJava, which matters for + `t/54_dbd_mem.t`. + +#### Per-test deltas after Phase 9 + 9b + +| Test | Phase 8 (pre-switch) | Phase 9+9b | +|---|---|---| +| 01basics.t | 100/130 (halts) | **130/130** | +| 03handle.t | 94/137 | 134/137 | +| 06attrs.t | 145/166 | 164/166 | +| 08keeperr.t | 84/91 | 88/91 | +| 12quote.t | 5/10 | 10/10 | +| 14utf8.t | 10/16 | 15/16 | +| 15array.t | 16/55 | **50/55** | +| 17handle_error.t | 84/84 | 84/84 | +| 20meta.t | 3/8 | 8/8 | +| 30subclass.t | 43/43 | 43/43 | +| 31methcache.t | 24/49 | **49/49** | +| 09trace.t | 99/99 | **99/99** (kept after defensive SCOPE_EXIT_CLEANUP fix) | +| 40/41/42/43 (profile) | 13/84 | SKIP (legit PurePerl skip) | +| 70callbacks.t | 65/81 | SKIP (legit PurePerl skip) | + +8 files go from partial-fail to full-pass; 4 more go from badly +broken to ≥95%. Profile/Callbacks/Kids/swap_inner_handle are +legitimately SKIPped by PurePerl — these are the XS-only features +upcoming Phase 10 will reimplement in Java. + +#### Known issues for follow-up + +1. **t/09trace.t** previously regressed 99→1 due to a PerlOnJava + interpreter bug. **Fixed in this branch** with a defensive + guard in `BytecodeInterpreter.SCOPE_EXIT_CLEANUP` that tolerates + non-scalar values in a my-scalar slot (root cause is a compiler + bug leaving a `RuntimeList` in a scalar register after + `my $x = { ternary-returning-list }`; the guard is the + minimal-risk fix, the proper emitter fix is tracked separately). + Now 99/99. +2. **Full `jcpan -t DBI` baseline not yet re-run.** Per-test numbers + extrapolate to ~5800–6300 passing subtests (from the 4940/6570 + Phase 7 baseline), but a full run would confirm. + +### Phase 10 (planned): reimplement XS-only features in Java + +Upstream DBI::PurePerl explicitly skips some XS features with +warnings like `"$h->{Profile} attribute not supported for DBI::PurePerl"`. +These are the roadmap for the next round of Java work: + +- **Profile dispatch hook** — single biggest block (91 tests in + t/40..43_prof_*.t). Upstream XS wraps every dispatched method in + a timing frame that bumps `$h->{Profile}{Data}{$path...}`. We'd + hook `DBI::dispatch` (via method wrapping in the Java shim) to + do the same. +- **Callbacks** — 65-test block (t/70callbacks.t). Fire + `$h->{Callbacks}{$method}` (or `*`) before/around dispatch. +- **Kids/ActiveKids/CachedKids** auto-bookkeeping on parent handles. +- **swap_inner_handle**, **take_imp_data** round-trip. +- **XS-level trace formatter** (per-handle trace fh + PerlIO layers). + ### Next Steps Remaining high-signal individual-test failures (running diff --git a/src/main/java/org/perlonjava/backend/bytecode/BytecodeInterpreter.java b/src/main/java/org/perlonjava/backend/bytecode/BytecodeInterpreter.java index 1604956e6..1e81c7be4 100644 --- a/src/main/java/org/perlonjava/backend/bytecode/BytecodeInterpreter.java +++ b/src/main/java/org/perlonjava/backend/bytecode/BytecodeInterpreter.java @@ -172,9 +172,36 @@ public static RuntimeList execute(InterpretedCode code, RuntimeArray args, int c } case Opcodes.SCOPE_EXIT_CLEANUP -> { - // Scope-exit cleanup for a my-scalar register + // Scope-exit cleanup for a my-scalar register. + // + // Root cause for the defensive `instanceof` check + // below: a my-scalar declared inside a + // short-circuiting expression + // if (COND_A and COND_B and defined((my $x = ...)->{k})) {...} + // may never run its MY_SCALAR initialisation if + // COND_A or COND_B short-circuits. The compiler + // has already allocated a register for `$x`, but + // that register may be holding a temp value left + // over from an earlier statement (e.g. a + // CREATE_LIST result from an unrelated block + // whose register was later recycled). When the + // enclosing scope exits, SCOPE_EXIT_CLEANUP runs + // on `$x`'s register and finds a non-scalar. + // + // This is safe to ignore because the user never + // observes `$x` in that short-circuit path (their + // code is inside the same block and also skipped). + // `scopeExitCleanup` only has work to do on real + // RuntimeScalars (IO-owner fd recycling, + // refCount decrement for blessed refs with + // DESTROY, and captureCount tracking for + // closures); a non-scalar slot simply has no + // cleanup obligation. int reg = bytecode[pc++]; - RuntimeScalar.scopeExitCleanup((RuntimeScalar) registers[reg]); + RuntimeBase slot = registers[reg]; + if (slot instanceof RuntimeScalar rs) { + RuntimeScalar.scopeExitCleanup(rs); + } registers[reg] = null; } @@ -317,6 +344,9 @@ public static RuntimeList execute(InterpretedCode code, RuntimeArray args, int c int dest = bytecode[pc++]; int src = bytecode[pc++]; RuntimeBase srcVal = registers[src]; + if (dest == 51 && srcVal instanceof RuntimeList) { + new RuntimeException("TRACE ALIAS dest=51 src=" + src + " putting list in reg 51, srcVal=" + srcVal).printStackTrace(); + } registers[dest] = isImmutableProxy(srcVal) ? ensureMutableScalar(srcVal) : srcVal; } diff --git a/src/main/java/org/perlonjava/core/Configuration.java b/src/main/java/org/perlonjava/core/Configuration.java index 8127f4854..b626e3938 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 = "5acad7563"; + public static final String gitCommitId = "1cdf0926f"; /** * 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 23 2026 09:55:16"; + public static final String buildTimestamp = "Apr 23 2026 13:55:28"; // Prevent instantiation private Configuration() { diff --git a/src/main/java/org/perlonjava/runtime/perlmodule/DBI.java b/src/main/java/org/perlonjava/runtime/perlmodule/DBI.java index a7775c72b..2e23c29f0 100644 --- a/src/main/java/org/perlonjava/runtime/perlmodule/DBI.java +++ b/src/main/java/org/perlonjava/runtime/perlmodule/DBI.java @@ -32,35 +32,48 @@ public DBI() { /** * Initializes and registers all DBI methods. * This method must be called before using any DBI functionality. + * + * With the switch to upstream DBI.pm + DBI::PurePerl, methods are now + * registered under DBD::JDBC::{dr,db,st} sub-packages so upstream's + * dispatch (which looks up $h->{ImplementorClass}::method) routes here + * for JDBC-backed dbhs. DBD::SQLite / DBD::Mem etc. inherit from these. */ public static void initialize() { // Create new DBI instance DBI dbi = new DBI(); try { - // Register all supported DBI methods - dbi.registerMethod("connect", null); - dbi.registerMethod("prepare", null); - dbi.registerMethod("execute", null); - dbi.registerMethod("fetchrow_arrayref", null); - dbi.registerMethod("fetchrow_hashref", null); - dbi.registerMethod("rows", null); - dbi.registerMethod("disconnect", null); - dbi.registerMethod("last_insert_id", null); - dbi.registerMethod("begin_work", null); - dbi.registerMethod("commit", null); - dbi.registerMethod("rollback", null); - dbi.registerMethod("bind_param", null); - dbi.registerMethod("bind_param_inout", null); - dbi.registerMethod("bind_col", null); - dbi.registerMethod("table_info", null); - dbi.registerMethod("column_info", null); - dbi.registerMethod("primary_key_info", null); - dbi.registerMethod("foreign_key_info", null); - dbi.registerMethod("type_info", null); - dbi.registerMethod("ping", null); - dbi.registerMethod("available_drivers", null); - dbi.registerMethod("data_sources", null); - dbi.registerMethod("get_info", null); + // dr-level: connect creates a dbh. available_drivers / data_sources + // are class-level but also registered here for backwards compat. + dbi.registerMethodInPackage("DBD::JDBC::dr", "connect", "connect"); + dbi.registerMethodInPackage("DBD::JDBC::dr", "data_sources", "data_sources"); + + // db-level: SQL prep / execute / transaction / info methods. + dbi.registerMethodInPackage("DBD::JDBC::db", "prepare", "prepare"); + dbi.registerMethodInPackage("DBD::JDBC::db", "disconnect", "disconnect"); + dbi.registerMethodInPackage("DBD::JDBC::db", "last_insert_id", "last_insert_id"); + dbi.registerMethodInPackage("DBD::JDBC::db", "begin_work", "begin_work"); + dbi.registerMethodInPackage("DBD::JDBC::db", "commit", "commit"); + dbi.registerMethodInPackage("DBD::JDBC::db", "rollback", "rollback"); + dbi.registerMethodInPackage("DBD::JDBC::db", "ping", "ping"); + dbi.registerMethodInPackage("DBD::JDBC::db", "table_info", "table_info"); + dbi.registerMethodInPackage("DBD::JDBC::db", "column_info", "column_info"); + dbi.registerMethodInPackage("DBD::JDBC::db", "primary_key_info", "primary_key_info"); + dbi.registerMethodInPackage("DBD::JDBC::db", "foreign_key_info", "foreign_key_info"); + dbi.registerMethodInPackage("DBD::JDBC::db", "type_info", "type_info"); + dbi.registerMethodInPackage("DBD::JDBC::db", "get_info", "get_info"); + + // st-level: execute / fetch / bind / row-count methods. + dbi.registerMethodInPackage("DBD::JDBC::st", "execute", "execute"); + dbi.registerMethodInPackage("DBD::JDBC::st", "fetchrow_arrayref", "fetchrow_arrayref"); + dbi.registerMethodInPackage("DBD::JDBC::st", "fetchrow_hashref", "fetchrow_hashref"); + dbi.registerMethodInPackage("DBD::JDBC::st", "rows", "rows"); + dbi.registerMethodInPackage("DBD::JDBC::st", "bind_param", "bind_param"); + dbi.registerMethodInPackage("DBD::JDBC::st", "bind_param_inout", "bind_param_inout"); + dbi.registerMethodInPackage("DBD::JDBC::st", "bind_col", "bind_col"); + + // Legacy: available_drivers and data_sources as DBI-class methods. + // Upstream DBI.pm defines available_drivers itself; register only + // what it doesn't already provide. } catch (NoSuchMethodException e) { System.err.println("Warning: Missing DBI method: " + e.getMessage()); } @@ -155,7 +168,7 @@ public static RuntimeList connect(RuntimeArray args, int ctx) { dbh.put("Name", new RuntimeScalar(jdbcUrl)); // Create blessed reference for Perl compatibility - RuntimeScalar dbhRef = ReferenceOperators.bless(dbh.createReference(), new RuntimeScalar("DBI::db")); + RuntimeScalar dbhRef = ReferenceOperators.bless(dbh.createReference(), new RuntimeScalar("DBD::JDBC::db")); return dbhRef.getList(); }, dbh, "connect('" + jdbcUrl + "','" + dbh.get("Username") + "',...) failed"); } @@ -236,7 +249,7 @@ public static RuntimeList prepare(RuntimeArray args, int ctx) { sth.put("NUM_OF_PARAMS", new RuntimeScalar(numParams)); // Create blessed reference for statement handle - RuntimeScalar sthRef = ReferenceOperators.bless(sth.createReference(), new RuntimeScalar("DBI::st")); + RuntimeScalar sthRef = ReferenceOperators.bless(sth.createReference(), new RuntimeScalar("DBD::JDBC::st")); dbh.get("sth").set(sthRef); @@ -831,7 +844,7 @@ public static RuntimeList table_info(RuntimeArray args, int ctx) { // Create statement handle for results RuntimeHash sth = createMetadataResultSet(dbh, rs); - RuntimeScalar sthRef = ReferenceOperators.bless(sth.createReference(), new RuntimeScalar("DBI::st")); + RuntimeScalar sthRef = ReferenceOperators.bless(sth.createReference(), new RuntimeScalar("DBD::JDBC::st")); return sthRef.getList(); }, dbh, "table_info"); } @@ -864,7 +877,7 @@ public static RuntimeList column_info(RuntimeArray args, int ctx) { ResultSet rs = metaData.getColumns(catalog, schema, table, column); RuntimeHash sth = createMetadataResultSet(dbh, rs); - RuntimeScalar sthRef = ReferenceOperators.bless(sth.createReference(), new RuntimeScalar("DBI::st")); + RuntimeScalar sthRef = ReferenceOperators.bless(sth.createReference(), new RuntimeScalar("DBD::JDBC::st")); return sthRef.getList(); }, dbh, "column_info"); } @@ -952,7 +965,7 @@ private static RuntimeList columnInfoViaPragma(RuntimeHash dbh, Connection conn, result.put("has_resultset", scalarTrue); sth.put("execute_result", result.createReference()); - RuntimeScalar sthRef = ReferenceOperators.bless(sth.createReference(), new RuntimeScalar("DBI::st")); + RuntimeScalar sthRef = ReferenceOperators.bless(sth.createReference(), new RuntimeScalar("DBD::JDBC::st")); return sthRef.getList(); } @@ -974,7 +987,7 @@ public static RuntimeList primary_key_info(RuntimeArray args, int ctx) { ResultSet rs = metaData.getPrimaryKeys(catalog, schema, table); RuntimeHash sth = createMetadataResultSet(dbh, rs); - RuntimeScalar sthRef = ReferenceOperators.bless(sth.createReference(), new RuntimeScalar("DBI::st")); + RuntimeScalar sthRef = ReferenceOperators.bless(sth.createReference(), new RuntimeScalar("DBD::JDBC::st")); return sthRef.getList(); }, dbh, "primary_key_info"); } @@ -1001,7 +1014,7 @@ public static RuntimeList foreign_key_info(RuntimeArray args, int ctx) { fkCatalog, fkSchema, fkTable); RuntimeHash sth = createMetadataResultSet(dbh, rs); - RuntimeScalar sthRef = ReferenceOperators.bless(sth.createReference(), new RuntimeScalar("DBI::st")); + RuntimeScalar sthRef = ReferenceOperators.bless(sth.createReference(), new RuntimeScalar("DBD::JDBC::st")); return sthRef.getList(); }, dbh, "foreign_key_info"); } @@ -1015,7 +1028,7 @@ public static RuntimeList type_info(RuntimeArray args, int ctx) { ResultSet rs = metaData.getTypeInfo(); RuntimeHash sth = createMetadataResultSet(dbh, rs); - RuntimeScalar sthRef = ReferenceOperators.bless(sth.createReference(), new RuntimeScalar("DBI::st")); + RuntimeScalar sthRef = ReferenceOperators.bless(sth.createReference(), new RuntimeScalar("DBD::JDBC::st")); return sthRef.getList(); }, dbh, "type_info"); } diff --git a/src/main/java/org/perlonjava/runtime/perlmodule/PerlModuleBase.java b/src/main/java/org/perlonjava/runtime/perlmodule/PerlModuleBase.java index 0226659ed..88887872d 100644 --- a/src/main/java/org/perlonjava/runtime/perlmodule/PerlModuleBase.java +++ b/src/main/java/org/perlonjava/runtime/perlmodule/PerlModuleBase.java @@ -96,6 +96,34 @@ protected void registerMethod(String methodName, String signature) throws NoSuch registerMethod(methodName, methodName, signature); } + /** + * Registers a method in the Perl module under a specific target package, + * overriding the default moduleName-derived package. Useful for modules + * that need to register methods under multiple Perl packages (e.g. a DBI + * driver registering under DBD::Foo::dr, DBD::Foo::db, DBD::Foo::st). + * + * @param targetPackage The Perl package to register the method under. + * @param perlMethodName The name of the method in Perl. + * @param javaMethodName The name of the corresponding Java method. + * @throws NoSuchMethodException If the Java method does not exist. + */ + protected void registerMethodInPackage(String targetPackage, + String perlMethodName, + String javaMethodName) throws NoSuchMethodException { + try { + MethodHandle methodHandle = RuntimeCode.lookup.findStatic( + this.getClass(), javaMethodName, RuntimeCode.methodType); + RuntimeCode code = new RuntimeCode(methodHandle, this, null); + code.isStatic = true; + code.packageName = targetPackage; + code.subName = perlMethodName; + String fullName = NameNormalizer.normalizeVariableName(perlMethodName, targetPackage); + GlobalVariable.getGlobalCodeRef(fullName).set(new RuntimeScalar(code)); + } catch (NoSuchMethodException | IllegalAccessException e) { + throw new RuntimeException(e); + } + } + /** * Defines symbols to be exported by the Perl module. * diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/GlobalContext.java b/src/main/java/org/perlonjava/runtime/runtimetypes/GlobalContext.java index b935eca25..5db5f5690 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/GlobalContext.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/GlobalContext.java @@ -287,6 +287,11 @@ public static void initializeGlobals(CompilerOptions compilerOptions) { IOHandle.initialize(); // IO::Handle methods (_sync, _error, etc.) Version.initialize(); // Initialize version module for version objects Attributes.initialize(); // attributes:: XS-equivalent functions (used by attributes.pm) + // DBI JDBC backend: with the switch to upstream DBI.pm + DBI::PurePerl, + // our Java-backed methods register under DBD::JDBC::{dr,db,st} so they + // can be inherited by JDBC-driven DBDs (DBD::SQLite, DBD::Mem, ...). + // This runs at startup so the methods exist before any `use DBI`. + DBI.initialize(); // Filter::Util::Call will be loaded via XSLoader when needed // Reset method cache after initializing UNIVERSAL diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeCode.java b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeCode.java index 6c04c59f3..947499237 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeCode.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeCode.java @@ -2025,9 +2025,19 @@ public static RuntimeList call(RuntimeScalar runtimeScalar, 1 // start looking in the parent package ); } else { - // Fully qualified method name - call the exact subroutine - method = GlobalVariable.getGlobalCodeRef(methodName); - if (!method.getDefinedBoolean()) { + // Fully qualified method name: $obj->Pkg::method(...) + // Perl semantics: look up `method` starting in `Pkg` and + // walk `@Pkg::ISA` via normal MRO. A direct symbol-table + // lookup would miss methods inherited into Pkg from its + // base classes (DBI.pm relies on this for + // `$drh->DBD::_::dr::STORE(...)` to find STORE in + // DBD::_::common via @DBD::_::dr::ISA). + int sep = methodName.lastIndexOf("::"); + String targetPackage = methodName.substring(0, sep); + String shortMethod = methodName.substring(sep + 2); + method = InheritanceResolver.findMethodInHierarchy( + shortMethod, targetPackage, methodName, 0); + if (method == null || !method.getDefinedBoolean()) { throw new PerlCompilerException("Undefined subroutine &" + methodName + " called"); } } diff --git a/src/main/perl/lib/DBD/JDBC.pm b/src/main/perl/lib/DBD/JDBC.pm new file mode 100644 index 000000000..ac90e6676 --- /dev/null +++ b/src/main/perl/lib/DBD/JDBC.pm @@ -0,0 +1,95 @@ +package DBD::JDBC; + +# PerlOnJava-specific base driver for JDBC-backed DBI drivers. +# +# This is not the CPAN DBD::JDBC (which uses a separate Java proxy +# process). It's an in-JVM base that provides the driver / dbh / sth +# handle architecture expected by upstream DBI (DBI 1.647 + DBI::PurePerl) +# on top of the JDBC connect / prepare / execute / fetch methods +# registered in Java under DBD::JDBC::{dr,db,st}. +# +# Per-flavour drivers (DBD::SQLite, DBD::Mem, …) inherit from this and +# provide a `_dsn_to_jdbc` class method that maps a Perl DBI DSN to a +# JDBC URL. + +use strict; +use warnings; + +our $VERSION = '0.01'; + +our $drh = undef; + +sub driver { + my ($class, $attr) = @_; + return $drh if $drh; + + ($drh) = DBI::_new_drh("${class}::dr", { + Name => ($class =~ /^DBD::(\w+)/)[0] || 'JDBC', + Version => $VERSION, + Attribution => "$class via JDBC (PerlOnJava)", + }); + return $drh; +} + +sub CLONE { undef $drh; } + +# --------------------------------------------------------------------- +package DBD::JDBC::dr; +our @ISA = ('DBD::_::dr'); +use strict; + +# Upstream's install_driver calls $class->driver; that returns our drh. +# connect($drh, $dsn_rest, $user, $pass, $attr) builds the dbh. +# +# For our hybrid model, we DELEGATE to the Java-registered +# DBD::JDBC::dr::connect below (installed at startup from DBI.java). +# The per-flavour driver's `_dsn_to_jdbc` converts the Perl-DBI DSN +# suffix to a JDBC URL before the call reaches the Java entry point. +# +# The Java connect returns a *flat* hashref blessed into DBD::JDBC::db +# (not an upstream tied outer / inner pair). For method dispatch, +# upstream DBI's AUTOLOAD looks up $h->{ImplementorClass}::method; since +# our dbh is blessed directly into DBD::JDBC::db (or a subclass), Perl's +# normal method-resolution finds the Java-registered methods. + +# data_sources can be overridden by subclasses. + +# --------------------------------------------------------------------- +package DBD::JDBC::db; +our @ISA = ('DBD::_::db'); +use strict; + +# `do` is inherited from DBD::_::db (via DBI.pm), which calls prepare + +# execute + (optionally) rows — that all routes back into our +# Java-registered methods on this class. + +# --------------------------------------------------------------------- +package DBD::JDBC::st; +our @ISA = ('DBD::_::st'); +use strict; + +# Alias fetch/fetchrow to our Java-registered fetchrow_arrayref so +# Perl's MRO stops on DBD::JDBC::st first and doesn't fall through to +# DBD::_::st's defaults (which call each other recursively assuming +# the driver has implemented at least one). +*fetch = \&fetchrow_arrayref; +*fetchrow = \&fetchrow_arrayref; + +1; + +__END__ + +=head1 NAME + +DBD::JDBC - PerlOnJava base driver for JDBC-backed DBDs + +=head1 DESCRIPTION + +This module is installed by PerlOnJava and is not a standalone CPAN +module. It exists to bridge between upstream DBI's driver-architecture +expectations and PerlOnJava's in-JVM JDBC backend. + +Per-flavour drivers (L, L, etc.) inherit from +this driver and only need to provide a C<_dsn_to_jdbc> class method. + +=cut diff --git a/src/main/perl/lib/DBD/Mem.pm b/src/main/perl/lib/DBD/Mem.pm deleted file mode 100644 index 23ddfce7a..000000000 --- a/src/main/perl/lib/DBD/Mem.pm +++ /dev/null @@ -1,41 +0,0 @@ -package DBD::Mem; -use strict; -use warnings; - -our $VERSION = '0.001'; - -# DBD::Mem compatibility shim for PerlOnJava -# Maps dbi:Mem: to SQLite in-memory via jdbc:sqlite::memory: -# Perl 5's DBD::Mem is a pure-Perl in-memory table engine. -# We emulate it using SQLite's in-memory mode which provides -# equivalent SQL functionality. - -sub _dsn_to_jdbc { - my ($class, $dsn_rest) = @_; - return "jdbc:sqlite::memory:"; -} - -1; - -__END__ - -=head1 NAME - -DBD::Mem - PerlOnJava in-memory database driver via SQLite - -=head1 SYNOPSIS - - use DBI; - my $dbh = DBI->connect("dbi:Mem:", "", ""); - my $dbh = DBI->connect("dbi:Mem(RaiseError=1):", "", ""); - -=head1 DESCRIPTION - -This is a PerlOnJava compatibility shim that maps C connections -to SQLite in-memory databases (C). - -In Perl 5, C is a pure-Perl in-memory table engine built on -C. PerlOnJava emulates this using SQLite's in-memory mode, -which provides equivalent SQL functionality. - -=cut diff --git a/src/main/perl/lib/DBD/SQLite.pm b/src/main/perl/lib/DBD/SQLite.pm index 624d63390..17196dc55 100644 --- a/src/main/perl/lib/DBD/SQLite.pm +++ b/src/main/perl/lib/DBD/SQLite.pm @@ -4,13 +4,52 @@ use warnings; our $VERSION = '1.74'; +# Inherit the driver factory + handle classes from DBD::JDBC. We only +# need to implement DSN translation. Real DBI discovers DBD::SQLite via +# install_driver, calls SQLite->driver (inherited), gets a drh, then +# calls $drh->connect which routes to DBD::JDBC::dr::connect (registered +# in Java) — that function consults SQLite->_dsn_to_jdbc to map the +# DSN suffix to a JDBC URL. +# +# This is NOT the CPAN DBD::SQLite (XS wrapper around sqlite3). It is +# a PerlOnJava shim that delegates to Xerial's sqlite-jdbc driver +# bundled with PerlOnJava. + +use DBI (); +use DBD::JDBC (); +our @ISA = ('DBD::JDBC'); + +{ + package DBD::SQLite::dr; + our @ISA = ('DBD::JDBC::dr'); + + # Override connect to translate the DSN before the Java entrypoint + # takes over. We call the Java-registered DBD::JDBC::dr::connect + # with the translated URL. + sub connect { + my ($drh, $dbname, $user, $pass, $attr) = @_; + my $jdbc_url = DBD::SQLite->_dsn_to_jdbc($dbname); + return DBD::JDBC::dr::connect($drh, $jdbc_url, $user, $pass, $attr); + } +} + +{ + package DBD::SQLite::db; + our @ISA = ('DBD::JDBC::db'); +} + +{ + package DBD::SQLite::st; + our @ISA = ('DBD::JDBC::st'); +} + # Translate Perl DBI DSN to JDBC URL for SQLite # Handles: -# dbi:SQLite:dbname=:memory: -> jdbc:sqlite::memory: -# dbi:SQLite::memory: -> jdbc:sqlite::memory: -# dbi:SQLite:dbname=/path/to/db -> jdbc:sqlite:/path/to/db -# dbi:SQLite:/path/to/db -> jdbc:sqlite:/path/to/db -# dbi:SQLite:dbname=file.db -> jdbc:sqlite:file.db +# dbname=:memory: -> jdbc:sqlite::memory: +# :memory: -> jdbc:sqlite::memory: +# dbname=/path/to/db -> jdbc:sqlite:/path/to/db +# /path/to/db -> jdbc:sqlite:/path/to/db +# dbname=file.db -> jdbc:sqlite:file.db sub _dsn_to_jdbc { my ($class, $dsn_rest) = @_; @@ -50,4 +89,8 @@ DBD::SQLite - PerlOnJava SQLite driver via JDBC (sqlite-jdbc) This is a PerlOnJava compatibility shim that translates Perl DBI DSN format to JDBC URL format for the Xerial sqlite-jdbc driver bundled with PerlOnJava. +It inherits handle architecture from L, which bridges +upstream DBI's driver-architecture expectations to PerlOnJava's +Java-backed JDBC methods. + =cut diff --git a/src/main/perl/lib/DBI.pm b/src/main/perl/lib/DBI.pm index d123de2fd..1ac440251 100644 --- a/src/main/perl/lib/DBI.pm +++ b/src/main/perl/lib/DBI.pm @@ -1,772 +1,8702 @@ +# $Id$ +# vim: ts=8:sw=4:et +# +# Copyright (c) 2024-2025 DBI Team +# Copyright (c) 1994-2024 Tim Bunce Ireland +# +# See COPYRIGHT section in pod text below for usage and distribution rights. +# + package DBI; + +require 5.008001; + use strict; use warnings; + +our ($XS_VERSION, $VERSION); +BEGIN { +$VERSION = "1.647"; # ==> ALSO update the version in the pod text below! +$XS_VERSION = $VERSION; +$VERSION =~ tr/_//d; +} + +=head1 NAME + +DBI - Database independent interface for Perl + +=head1 SYNOPSIS + + use DBI; + + @driver_names = DBI->available_drivers; + %drivers = DBI->installed_drivers; + @data_sources = DBI->data_sources($driver_name, \%attr); + + $dbh = DBI->connect($data_source, $username, $auth, \%attr); + + $rv = $dbh->do($statement); + $rv = $dbh->do($statement, \%attr); + $rv = $dbh->do($statement, \%attr, @bind_values); + + $ary_ref = $dbh->selectall_arrayref($statement); + $hash_ref = $dbh->selectall_hashref($statement, $key_field); + + $ary_ref = $dbh->selectcol_arrayref($statement); + $ary_ref = $dbh->selectcol_arrayref($statement, \%attr); + + @row_ary = $dbh->selectrow_array($statement); + $ary_ref = $dbh->selectrow_arrayref($statement); + $hash_ref = $dbh->selectrow_hashref($statement); + + $sth = $dbh->prepare($statement); + $sth = $dbh->prepare_cached($statement); + + $rc = $sth->bind_param($p_num, $bind_value); + $rc = $sth->bind_param($p_num, $bind_value, $bind_type); + $rc = $sth->bind_param($p_num, $bind_value, \%attr); + + $rv = $sth->execute; + $rv = $sth->execute(@bind_values); + $rv = $sth->execute_array(\%attr, ...); + + $rc = $sth->bind_col($col_num, \$col_variable); + $rc = $sth->bind_columns(@list_of_refs_to_vars_to_bind); + + @row_ary = $sth->fetchrow_array; + $ary_ref = $sth->fetchrow_arrayref; + $hash_ref = $sth->fetchrow_hashref; + + $ary_ref = $sth->fetchall_arrayref; + $ary_ref = $sth->fetchall_arrayref( $slice, $max_rows ); + + $hash_ref = $sth->fetchall_hashref( $key_field ); + + $rv = $sth->rows; + + $rc = $dbh->begin_work; + $rc = $dbh->commit; + $rc = $dbh->rollback; + + $quoted_string = $dbh->quote($string); + + $rc = $h->err; + $str = $h->errstr; + $rv = $h->state; + + $rc = $dbh->disconnect; + +I + + +=head2 GETTING HELP + +=head3 General + +Before asking any questions, reread this document, consult the archives and +read the DBI FAQ. The archives are listed at the end of this document and on +the DBI home page L + +You might also like to read the Advanced DBI Tutorial at +L + +To help you make the best use of the dbi-users mailing list, +and any other lists or forums you may use, I recommend that you read +"Getting Answers" by Mike Ash: L. + +=head3 Mailing Lists + +If you have questions about DBI, or DBD driver modules, you can get +help from the I mailing list. This is the best way to get +help. You don't have to subscribe to the list in order to post, though I'd +recommend it. You can get help on subscribing and using the list by emailing +I. + +Please note that Tim Bunce does not maintain the mailing lists or the +web pages (generous volunteers do that). So please don't send mail +directly to him; he just doesn't have the time to answer questions +personally. The I mailing list has lots of experienced +people who should be able to help you if you need it. If you do email +Tim he is very likely to just forward it to the mailing list. + +=head3 IRC + +DBI IRC Channel: #dbi on irc.perl.org (L) + +=for html (click for instant chatroom login) + +=head3 Online + +StackOverflow has a DBI tag L +with over 800 questions. + +The DBI home page at L might be worth a visit. +It includes links to other resources, but I. + +=head3 Reporting a Bug + +If you think you've found a bug then please read +"How to Report Bugs Effectively" by Simon Tatham: +L. + +If you think you've found a memory leak then read L. + +Your problem is most likely related to the specific DBD driver module you're +using. If that's the case then click on the 'Bugs' link on the L +page for your driver. Only submit a bug report against the DBI itself if you're +sure that your issue isn't related to the driver you're using. + +=head2 NOTES + +This is the DBI specification that corresponds to DBI version 1.647 +(see L for details). + +The DBI is evolving at a steady pace, so it's good to check that +you have the latest copy. + +The significant user-visible changes in each release are documented +in the L module so you can read them by executing +C. + +Some DBI changes require changes in the drivers, but the drivers +can take some time to catch up. Newer versions of the DBI have +added features that may not yet be supported by the drivers you +use. Talk to the authors of your drivers if you need a new feature +that is not yet supported. + +Features added after DBI 1.21 (February 2002) are marked in the +text with the version number of the DBI release they first appeared in. + +Extensions to the DBI API often use the C namespace. +See L. DBI extension modules +can be found at L. And all modules +related to the DBI can be found at L. + +=cut + +# The POD text continues at the end of the file. + use Scalar::Util (); -use XSLoader; +use Carp(); +use XSLoader (); use Exporter (); -our $VERSION = '1.643'; +our (@ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS); +BEGIN { +@ISA = qw(Exporter); -XSLoader::load( 'DBI' ); +# Make some utility functions available if asked for +@EXPORT = (); # we export nothing by default +@EXPORT_OK = qw(%DBI %DBI_methods hash); # also populated by export_ok_tags: +%EXPORT_TAGS = ( + sql_types => [ qw( + SQL_GUID + SQL_WLONGVARCHAR + SQL_WVARCHAR + SQL_WCHAR + SQL_BIGINT + SQL_BIT + SQL_TINYINT + SQL_LONGVARBINARY + SQL_VARBINARY + SQL_BINARY + SQL_LONGVARCHAR + SQL_UNKNOWN_TYPE + SQL_ALL_TYPES + SQL_CHAR + SQL_NUMERIC + SQL_DECIMAL + SQL_INTEGER + SQL_SMALLINT + SQL_FLOAT + SQL_REAL + SQL_DOUBLE + SQL_DATETIME + SQL_DATE + SQL_INTERVAL + SQL_TIME + SQL_TIMESTAMP + SQL_VARCHAR + SQL_BOOLEAN + SQL_UDT + SQL_UDT_LOCATOR + SQL_ROW + SQL_REF + SQL_BLOB + SQL_BLOB_LOCATOR + SQL_CLOB + SQL_CLOB_LOCATOR + SQL_ARRAY + SQL_ARRAY_LOCATOR + SQL_MULTISET + SQL_MULTISET_LOCATOR + SQL_TYPE_DATE + SQL_TYPE_TIME + SQL_TYPE_TIMESTAMP + SQL_TYPE_TIME_WITH_TIMEZONE + SQL_TYPE_TIMESTAMP_WITH_TIMEZONE + SQL_INTERVAL_YEAR + SQL_INTERVAL_MONTH + SQL_INTERVAL_DAY + SQL_INTERVAL_HOUR + SQL_INTERVAL_MINUTE + SQL_INTERVAL_SECOND + SQL_INTERVAL_YEAR_TO_MONTH + SQL_INTERVAL_DAY_TO_HOUR + SQL_INTERVAL_DAY_TO_MINUTE + SQL_INTERVAL_DAY_TO_SECOND + SQL_INTERVAL_HOUR_TO_MINUTE + SQL_INTERVAL_HOUR_TO_SECOND + SQL_INTERVAL_MINUTE_TO_SECOND + ) ], + sql_cursor_types => [ qw( + SQL_CURSOR_FORWARD_ONLY + SQL_CURSOR_KEYSET_DRIVEN + SQL_CURSOR_DYNAMIC + SQL_CURSOR_STATIC + SQL_CURSOR_TYPE_DEFAULT + ) ], # for ODBC cursor types + utils => [ qw( + neat neat_list $neat_maxlen dump_results looks_like_number + data_string_diff data_string_desc data_diff sql_type_cast + DBIstcf_DISCARD_STRING + DBIstcf_STRICT + ) ], + profile => [ qw( + dbi_profile dbi_profile_merge dbi_profile_merge_nodes dbi_time + ) ], # notionally "in" DBI::Profile and normally imported from there +); -# DBI::db and DBI::st inherit from DBI so method dispatch works -# when handles are blessed into subclass packages. -# DBI also inherits from Exporter so `use DBI qw(:sql_types ...)` works. -our @ISA = ('Exporter'); -@DBI::db::ISA = ('DBI'); -@DBI::st::ISA = ('DBI'); +$DBI::dbi_debug = 0; # mixture of bit fields and int sub-fields +$DBI::neat_maxlen = 1000; +$DBI::stderr = 2_000_000_000; # a very round number below 2**31 -our $neat_maxlen = 1000; +# If you get an error here like "Can't find loadable object ..." +# then you haven't installed the DBI correctly. Read the README +# then install it again. +# +# PerlOnJava customisation: there is no XS loader, so we force +# DBI::PurePerl mode. Set DBI_PUREPERL to 2 (unless already set by +# the user) before the conditional below so PurePerl is always +# loaded and XSLoader is never attempted. +$ENV{DBI_PUREPERL} = 2 unless defined $ENV{DBI_PUREPERL} && length $ENV{DBI_PUREPERL}; +if ( $ENV{DBI_PUREPERL} ) { + eval { XSLoader::load('DBI', $XS_VERSION) } if $ENV{DBI_PUREPERL} == 1; + require DBI::PurePerl if $@ or $ENV{DBI_PUREPERL} >= 2; + $DBI::PurePerl ||= 0; # just to silence "only used once" warnings +} +else { + XSLoader::load( 'DBI', $XS_VERSION); +} -# Wrap Java DBI methods with HandleError support and DBI attribute tracking. -# In real DBI, HandleError is called from C before RaiseError/die. -# Since our Java methods just die with RaiseError, we wrap them in Perl -# to intercept the die and call HandleError from Perl context (where -# caller() works correctly for DBIC's __find_caller). -{ - my $orig_prepare = \&DBI::prepare; - my $orig_execute = \&DBI::execute; - my $orig_finish = \&DBI::finish; - my $orig_disconnect = \&DBI::disconnect; +$EXPORT_TAGS{preparse_flags} = [ grep { /^DBIpp_\w\w_/ } keys %DBI:: ]; - no warnings 'redefine'; +Exporter::export_ok_tags(keys %EXPORT_TAGS); - *DBI::prepare = sub { - my $result = eval { $orig_prepare->(@_) }; - if ($@) { - return _handle_error($_[0], $@); - } - if ($result) { - my $dbh = $_[0]; - my $sql = $_[1]; - # Track statement handle count (Kids) and last statement - $dbh->{Kids} = ($dbh->{Kids} || 0) + 1; - $dbh->{Statement} = $sql; - # Link sth back to parent dbh - $result->{Database} = $dbh; - } - return $result; - }; +} - *DBI::execute = sub { - my $result = eval { $orig_execute->(@_) }; - if ($@) { - # For sth errors, try HandleError on the parent dbh first, then sth - my $sth_handle = $_[0]; - my $parent_dbh = $sth_handle->{Database}; - if ($parent_dbh && Scalar::Util::reftype($parent_dbh->{HandleError} || '') eq 'CODE') { - return _handle_error_with_handler($parent_dbh->{HandleError}, $@); - } - return _handle_error($sth_handle, $@); - } - if ($result) { - my $sth = $_[0]; - my $dbh = $sth->{Database}; - if ($dbh) { - # Only mark as active for result-returning statements (SELECT etc.) - # DDL/DML statements (CREATE, INSERT, etc.) have NUM_OF_FIELDS == 0 - if (($sth->{NUM_OF_FIELDS} || 0) > 0) { - $dbh->{ActiveKids} = ($dbh->{ActiveKids} || 0) + 1; - $sth->{Active} = 1; - } - } - } - return $result; - }; +# Alias some handle methods to also be DBI class methods +for (qw(trace_msg set_err parse_trace_flag parse_trace_flags)) { + no strict; + *$_ = \&{"DBD::_::common::$_"}; +} - *DBI::finish = sub { - my $sth = $_[0]; - if ($sth->{Active} && $sth->{Database}) { - my $active = $sth->{Database}{ActiveKids} || 0; - $sth->{Database}{ActiveKids} = $active > 0 ? $active - 1 : 0; - $sth->{Active} = 0; - } - return $orig_finish->(@_); - }; +DBI->trace(split /=/, $ENV{DBI_TRACE}, 2) if $ENV{DBI_TRACE}; - *DBI::disconnect = sub { - my $dbh = $_[0]; - $dbh->{Active} = 0; - return $orig_disconnect->(@_); - }; +$DBI::connect_via ||= "connect"; + +# check if user wants a persistent database connection ( Apache + mod_perl ) +if ($INC{'Apache/DBI.pm'} && $ENV{MOD_PERL}) { + $DBI::connect_via = "Apache::DBI::connect"; + DBI->trace_msg("DBI connect via $DBI::connect_via in $INC{'Apache/DBI.pm'}\n"); } -sub _handle_error { - my ($handle, $err) = @_; - if (ref($handle) && Scalar::Util::reftype($handle->{HandleError} || '') eq 'CODE') { - # Call HandleError — if it throws (as DBIC's does), propagate the exception - $handle->{HandleError}->($err, $handle, undef); - # If HandleError returns without dying, return undef (error handled) - return undef; - } - die $err; -} - -sub _handle_error_with_handler { - my ($handler, $err) = @_; - $handler->($err, undef, undef); - return undef; -} - -# NOTE: The rest of the code is in file: -# src/main/java/org/perlonjava/runtime/perlmodule/DBI.java - -# SQL type constants (from DBI spec, java.sql.Types values) -# Used by DBIx::Class::Storage::DBI::SQLite and others. -# Split into multiple blocks to avoid a PerlOnJava bytecode verifier -# limit with very large `use constant { ... }` hashes. -use constant { - SQL_GUID => -11, - SQL_WLONGVARCHAR => -10, - SQL_WVARCHAR => -9, - SQL_WCHAR => -8, - SQL_BIGINT => -5, - SQL_BIT => -7, - SQL_TINYINT => -6, - SQL_LONGVARBINARY => -4, - SQL_VARBINARY => -3, - SQL_BINARY => -2, - SQL_LONGVARCHAR => -1, - SQL_UNKNOWN_TYPE => 0, - SQL_ALL_TYPES => 0, - SQL_CHAR => 1, - SQL_NUMERIC => 2, - SQL_DECIMAL => 3, - SQL_INTEGER => 4, - SQL_SMALLINT => 5, - SQL_FLOAT => 6, - SQL_REAL => 7, - SQL_DOUBLE => 8, -}; +%DBI::installed_drh = (); # maps driver names to installed driver handles +sub installed_drivers { %DBI::installed_drh } +%DBI::installed_methods = (); # XXX undocumented, may change +sub installed_methods { %DBI::installed_methods } -use constant { - SQL_DATETIME => 9, - SQL_DATE => 9, - SQL_INTERVAL => 10, - SQL_TIME => 10, - SQL_TIMESTAMP => 11, - SQL_VARCHAR => 12, - SQL_BOOLEAN => 16, - SQL_UDT => 17, - SQL_UDT_LOCATOR => 18, - SQL_ROW => 19, - SQL_REF => 20, - SQL_BLOB => 30, - SQL_BLOB_LOCATOR => 31, - SQL_CLOB => 40, - SQL_CLOB_LOCATOR => 41, - SQL_ARRAY => 50, - SQL_ARRAY_LOCATOR => 51, - SQL_MULTISET => 55, - SQL_MULTISET_LOCATOR => 56, - SQL_TYPE_DATE => 91, - SQL_TYPE_TIME => 92, - SQL_TYPE_TIMESTAMP => 93, - SQL_TYPE_TIME_WITH_TIMEZONE => 94, - SQL_TYPE_TIMESTAMP_WITH_TIMEZONE => 95, -}; +# Setup special DBI dynamic variables. See DBI::var::FETCH for details. +# These are dynamically associated with the last handle used. +tie $DBI::err, 'DBI::var', '*err'; # special case: referenced via IHA list +tie $DBI::state, 'DBI::var', '"state'; # special case: referenced via IHA list +tie $DBI::lasth, 'DBI::var', '!lasth'; # special case: return boolean +tie $DBI::errstr, 'DBI::var', '&errstr'; # call &errstr in last used pkg +tie $DBI::rows, 'DBI::var', '&rows'; # call &rows in last used pkg +sub DBI::var::TIESCALAR{ my $var = $_[1]; bless \$var, 'DBI::var'; } +sub DBI::var::STORE { Carp::croak("Can't modify \$DBI::${$_[0]} special variable") } -use constant { - SQL_INTERVAL_YEAR => 101, - SQL_INTERVAL_MONTH => 102, - SQL_INTERVAL_DAY => 103, - SQL_INTERVAL_HOUR => 104, - SQL_INTERVAL_MINUTE => 105, - SQL_INTERVAL_SECOND => 106, - SQL_INTERVAL_YEAR_TO_MONTH => 107, - SQL_INTERVAL_DAY_TO_HOUR => 108, - SQL_INTERVAL_DAY_TO_MINUTE => 109, - SQL_INTERVAL_DAY_TO_SECOND => 110, - SQL_INTERVAL_HOUR_TO_MINUTE => 111, - SQL_INTERVAL_HOUR_TO_SECOND => 112, - SQL_INTERVAL_MINUTE_TO_SECOND => 113, -}; +# --- Driver Specific Prefix Registry --- -use constant { - SQL_CURSOR_FORWARD_ONLY => 0, - SQL_CURSOR_KEYSET_DRIVEN => 1, - SQL_CURSOR_DYNAMIC => 2, - SQL_CURSOR_STATIC => 3, - SQL_CURSOR_TYPE_DEFAULT => 0, - DBIstcf_STRICT => 0x0001, - DBIstcf_DISCARD_STRING => 0x0002, +my $dbd_prefix_registry = { + ad_ => { class => 'DBD::AnyData', }, + ad2_ => { class => 'DBD::AnyData2', }, + ado_ => { class => 'DBD::ADO', }, + amzn_ => { class => 'DBD::Amazon', }, + best_ => { class => 'DBD::BestWins', }, + csv_ => { class => 'DBD::CSV', }, + cubrid_ => { class => 'DBD::cubrid', }, + db2_ => { class => 'DBD::DB2', }, + dbi_ => { class => 'DBI', }, + dbm_ => { class => 'DBD::DBM', }, + df_ => { class => 'DBD::DF', }, + examplep_ => { class => 'DBD::ExampleP', }, + f_ => { class => 'DBD::File', }, + file_ => { class => 'DBD::TextFile', }, + go_ => { class => 'DBD::Gofer', }, + ib_ => { class => 'DBD::InterBase', }, + ing_ => { class => 'DBD::Ingres', }, + ix_ => { class => 'DBD::Informix', }, + jdbc_ => { class => 'DBD::JDBC', }, + mariadb_ => { class => 'DBD::MariaDB', }, + mem_ => { class => 'DBD::Mem', }, + mo_ => { class => 'DBD::MO', }, + monetdb_ => { class => 'DBD::monetdb', }, + msql_ => { class => 'DBD::mSQL', }, + mvsftp_ => { class => 'DBD::MVS_FTPSQL', }, + mysql_ => { class => 'DBD::mysql', }, + multi_ => { class => 'DBD::Multi' }, + mx_ => { class => 'DBD::Multiplex', }, + neo_ => { class => 'DBD::Neo4p', }, + nullp_ => { class => 'DBD::NullP', }, + odbc_ => { class => 'DBD::ODBC', }, + ora_ => { class => 'DBD::Oracle', }, + pg_ => { class => 'DBD::Pg', }, + pgpp_ => { class => 'DBD::PgPP', }, + plb_ => { class => 'DBD::Plibdata', }, + po_ => { class => 'DBD::PO', }, + proxy_ => { class => 'DBD::Proxy', }, + ram_ => { class => 'DBD::RAM', }, + rdb_ => { class => 'DBD::RDB', }, + sapdb_ => { class => 'DBD::SAP_DB', }, + snmp_ => { class => 'DBD::SNMP', }, + solid_ => { class => 'DBD::Solid', }, + spatialite_ => { class => 'DBD::Spatialite', }, + sponge_ => { class => 'DBD::Sponge', }, + sql_ => { class => 'DBI::DBD::SqlEngine', }, + sqlite_ => { class => 'DBD::SQLite', }, + syb_ => { class => 'DBD::Sybase', }, + sys_ => { class => 'DBD::Sys', }, + tdat_ => { class => 'DBD::Teradata', }, + tmpl_ => { class => 'DBD::Template', }, + tmplss_ => { class => 'DBD::TemplateSS', }, + tree_ => { class => 'DBD::TreeData', }, + tuber_ => { class => 'DBD::Tuber', }, + uni_ => { class => 'DBD::Unify', }, + vt_ => { class => 'DBD::Vt', }, + wmi_ => { class => 'DBD::WMI', }, + x_ => { }, # for private use + xbase_ => { class => 'DBD::XBase', }, + xmlsimple_ => { class => 'DBD::XMLSimple', }, + xl_ => { class => 'DBD::Excel', }, + yaswi_ => { class => 'DBD::Yaswi', }, }; -# Exporter wiring, %EXPORT_TAGS, and the small utility functions -# (neat / neat_list / looks_like_number / ...) live in a separate -# file so PerlOnJava compiles them to their own JVM class — the -# combined DBI.pm would otherwise exceed a per-method bytecode limit. -require DBI::_Utils; - -# Driver-architecture pieces: DBI->install_driver, DBI::_new_drh / -# _new_dbh / _new_sth, and the DBD::_::common / dr / db / st base -# classes. Also lives in its own file for the per-method bytecode -# size limit reason. Required by the pure-Perl DBDs bundled with -# upstream DBI (DBD::NullP, DBD::ExampleP, DBD::Sponge, DBD::File, -# DBD::DBM, DBD::Mem, etc.). -require DBI::_Handles; - -# DSN translation: convert Perl DBI DSN format to JDBC URL -# This wraps the Java-side connect() to support dbi:Driver:... format -# Handles attribute syntax: dbi:Driver(RaiseError=1):rest -{ - no warnings 'redefine'; - my $orig_connect = \&connect; - *connect = sub { - my ($class, $dsn, $user, $pass, $attr) = @_; - $dsn = '' unless defined $dsn; - $user = '' unless defined $user; - $pass = '' unless defined $pass; - $attr = {} unless ref $attr eq 'HASH'; - my $driver_name; - my $dsn_rest; - if ($dsn =~ /^dbi:(\w+)(?:\(([^)]*)\))?:(.*)$/i) { - my ($driver, $dsn_attrs, $rest) = ($1, $2, $3); - $driver_name = $driver; - $dsn_rest = $rest; - - # Parse DSN-embedded attributes like (RaiseError=1,PrintError=0) - if (defined $dsn_attrs && length $dsn_attrs) { - for my $pair (split /,/, $dsn_attrs) { - if ($pair =~ /^\s*(\w+)\s*=\s*(.*?)\s*$/) { - $attr->{$1} = $2 unless exists $attr->{$1}; - } - } - } +my %dbd_class_registry = map { $dbd_prefix_registry->{$_}->{class} => { prefix => $_ } } + grep { exists $dbd_prefix_registry->{$_}->{class} } + keys %{$dbd_prefix_registry}; - my $dbd_class = "DBD::$driver"; - eval "require $dbd_class"; - if ($dbd_class->can('_dsn_to_jdbc')) { - $dsn = $dbd_class->_dsn_to_jdbc($rest); - } - elsif ($dbd_class->can('driver')) { - # Pure-Perl DBD (no JDBC backing). Route through the - # DBI driver-architecture path: install the driver and - # let its connect() build the dbh via DBI::_new_dbh. - my $drh = eval { DBI->install_driver($driver) }; - if ($drh) { - my $dbh = $drh->connect($rest, $user, $pass, $attr); - if ($dbh) { - # real DBI does this in _new_dbh but we want - # to be permissive for drivers that don't. - $dbh->{Driver} = $drh; - $dbh->{Name} = $rest if !defined $dbh->{Name}; - $dbh->STORE(Active => 1) unless $dbh->FETCH('Active'); - # Apply user-supplied attributes. These always - # override whatever defaults the driver (or our - # _new_dbh) installed — the user's explicit - # connect() attr hash is authoritative. - if (ref $attr eq 'HASH') { - for my $k (keys %$attr) { - $dbh->STORE($k, $attr->{$k}); - } - } - } - return $dbh; - } - # fall through to JDBC path if install_driver croaked - } - } - my $dbh = $orig_connect->($class, $dsn, $user, $pass, $attr); - if ($dbh && $driver_name) { - # Set Driver attribute so DBIx::Class can detect the driver - # (e.g. $dbh->{Driver}{Name} returns "SQLite") - $dbh->{Driver} = bless { Name => $driver_name }, 'DBI::dr'; - # Initialize DBI handle tracking attributes - $dbh->{Kids} = 0; - $dbh->{ActiveKids} = 0; - $dbh->{Statement} = ''; - # Set Name to DSN rest (after driver:), not the JDBC URL - $dbh->{Name} = $dsn_rest if defined $dsn_rest; - } - return $dbh; - }; +sub dump_dbd_registry { + require Data::Dumper; + local $Data::Dumper::Sortkeys=1; + local $Data::Dumper::Indent=1; + print Data::Dumper->Dump([$dbd_prefix_registry], [qw($dbd_prefix_registry)]); } -# Example: -# -# java -cp "h2-2.2.224.jar:target/perlonjava-5.42.0.jar" org.perlonjava.app.cli.Main dbi.pl -# -# # Connect to H2 database -# my $dbh = DBI->connect( -# "jdbc:h2:mem:testdb;DB_CLOSE_DELAY=-1", # In-memory H2 database -# "sa", # Default H2 username -# "", # Empty password -# { RaiseError => 1 } -# ); - -# Cache variables for prepare_cached and connect_cached -our %CACHED_STATEMENTS; -our $MAX_CACHED_STATEMENTS = 100; -our %CACHED_CONNECTIONS; -our $MAX_CACHED_CONNECTIONS = 10; - -# FETCH/STORE methods for tied-hash compatibility -# In real Perl DBI, handles are tied hashes. DBIx::Class calls -# $dbh->FETCH('Active') explicitly, so we need method wrappers. -sub FETCH { - my ($self, $key) = @_; - return $self->{$key}; -} - -sub STORE { - my ($self, $key, $value) = @_; - $self->{$key} = $value; -} - -sub do { - my ($dbh, $statement, $attr, @params) = @_; - my $sth = $dbh->prepare($statement, $attr) or return undef; - $sth->execute(@params) or return undef; - my $rows = $sth->rows; - ($rows == 0) ? "0E0" : $rows; -} - -sub finish { - my ($sth) = @_; - $sth->{Active} = 0; -} - -# Batch execution: calls $fetch_tuple->() repeatedly to get parameter arrays, -# executes the prepared statement for each, and tracks results in $tuple_status. -sub execute_for_fetch { - my ($sth, $fetch_tuple_sub, $tuple_status) = @_; - # start with empty status array - if ($tuple_status) { - @$tuple_status = (); - } else { - $tuple_status = []; - } - - my $rc_total = 0; - my $err_count; - while ( my $tuple = &$fetch_tuple_sub() ) { - my $rc = eval { $sth->execute(@$tuple) }; - if ($rc) { - push @$tuple_status, $rc; - $rc_total = ($rc >= 0 && $rc_total >= 0) ? $rc_total + $rc : -1; - } - else { - $err_count++; - push @$tuple_status, [ $sth->err, $sth->errstr || $@, $sth->state ]; - } - } - my $tuples = @$tuple_status; - if ($err_count) { - my $err_msg = "executing $tuples generated $err_count errors"; - die $err_msg if $sth->{Database}{RaiseError}; - warn $err_msg if $sth->{Database}{PrintError}; - return undef; +# --- Dynamically create the DBI Standard Interface + +my $keeperr = { O=>0x0004 }; + +%DBI::DBI_methods = ( # Define the DBI interface methods per class: + + common => { # Interface methods common to all DBI handle classes + 'DESTROY' => { O=>0x004|0x10000 }, + 'CLEAR' => $keeperr, + 'EXISTS' => $keeperr, + 'FETCH' => { O=>0x0404 }, + 'FETCH_many' => { O=>0x0404 }, + 'FIRSTKEY' => $keeperr, + 'NEXTKEY' => $keeperr, + 'STORE' => { O=>0x0418 | 0x4 }, + 'DELETE' => { O=>0x0404 }, + can => { O=>0x0100 }, # special case, see dispatch + debug => { U =>[1,2,'[$debug_level]'], O=>0x0004 }, # old name for trace + dump_handle => { U =>[1,3,'[$message [, $level]]'], O=>0x0004 }, + err => $keeperr, + errstr => $keeperr, + state => $keeperr, + func => { O=>0x0006 }, + parse_trace_flag => { U =>[2,2,'$name'], O=>0x0404, T=>8 }, + parse_trace_flags => { U =>[2,2,'$flags'], O=>0x0404, T=>8 }, + private_data => { U =>[1,1], O=>0x0004 }, + set_err => { U =>[3,6,'$err, $errmsg [, $state, $method, $rv]'], O=>0x0010 }, + trace => { U =>[1,3,'[$trace_level, [$filename]]'], O=>0x0004 }, + trace_msg => { U =>[2,3,'$message_text [, $min_level ]' ], O=>0x0004, T=>8 }, + swap_inner_handle => { U =>[2,3,'$h [, $allow_reparent ]'] }, + private_attribute_info => { }, + visit_child_handles => { U => [2,3,'$coderef [, $info ]'], O=>0x0404, T=>4 }, + }, + dr => { # Database Driver Interface + 'connect' => { U =>[1,5,'[$db [,$user [,$passwd [,\%attr]]]]'], H=>3, O=>0x8000, T=>0x200 }, + 'connect_cached'=>{U=>[1,5,'[$db [,$user [,$passwd [,\%attr]]]]'], H=>3, O=>0x8000, T=>0x200 }, + 'disconnect_all'=>{ U =>[1,1], O=>0x0800, T=>0x200 }, + data_sources => { U =>[1,2,'[\%attr]' ], O=>0x0800, T=>0x200 }, + default_user => { U =>[3,4,'$user, $pass [, \%attr]' ], T=>0x200 }, + dbixs_revision => $keeperr, + }, + db => { # Database Session Class Interface + data_sources => { U =>[1,2,'[\%attr]' ], O=>0x0200 }, + take_imp_data => { U =>[1,1], O=>0x10000 }, + clone => { U =>[1,2,'[\%attr]'], T=>0x200 }, + connected => { U =>[1,0], O => 0x0004, T=>0x200, H=>3 }, + begin_work => { U =>[1,2,'[ \%attr ]'], O=>0x0400, T=>0x1000 }, + commit => { U =>[1,1], O=>0x0480|0x0800, T=>0x1000 }, + rollback => { U =>[1,1], O=>0x0480|0x0800, T=>0x1000 }, + 'do' => { U =>[2,0,'$statement [, \%attr [, @bind_params ] ]'], O=>0x3200 }, + last_insert_id => { U =>[1,6,'[$catalog [,$schema [,$table_name [,$field_name [, \%attr ]]]]]'], O=>0x2800 }, + preparse => { }, # XXX + prepare => { U =>[2,3,'$statement [, \%attr]'], O=>0xA200 }, + prepare_cached => { U =>[2,4,'$statement [, \%attr [, $if_active ] ]'], O=>0xA200 }, + selectrow_array => { U =>[2,0,'$statement [, \%attr [, @bind_params ] ]'], O=>0x2000 }, + selectrow_arrayref=>{U =>[2,0,'$statement [, \%attr [, @bind_params ] ]'], O=>0x2000 }, + selectrow_hashref=>{ U =>[2,0,'$statement [, \%attr [, @bind_params ] ]'], O=>0x2000 }, + selectall_arrayref=>{U =>[2,0,'$statement [, \%attr [, @bind_params ] ]'], O=>0x2000 }, + selectall_array =>{U =>[2,0,'$statement [, \%attr [, @bind_params ] ]'], O=>0x2000 }, + selectall_hashref=>{ U =>[3,0,'$statement, $keyfield [, \%attr [, @bind_params ] ]'], O=>0x2000 }, + selectcol_arrayref=>{U =>[2,0,'$statement [, \%attr [, @bind_params ] ]'], O=>0x2000 }, + ping => { U =>[1,1], O=>0x0404 }, + disconnect => { U =>[1,1], O=>0x0400|0x0800|0x10000, T=>0x200 }, + quote => { U =>[2,3, '$string [, $data_type ]' ], O=>0x0430, T=>2 }, + quote_identifier=> { U =>[2,6, '$name [, ...] [, \%attr ]' ], O=>0x0430, T=>2 }, + rows => $keeperr, + + tables => { U =>[1,6,'$catalog, $schema, $table, $type [, \%attr ]' ], O=>0x2200 }, + table_info => { U =>[1,6,'$catalog, $schema, $table, $type [, \%attr ]' ], O=>0x2200|0x8800 }, + column_info => { U =>[5,6,'$catalog, $schema, $table, $column [, \%attr ]'],O=>0x2200|0x8800 }, + primary_key_info=> { U =>[4,5,'$catalog, $schema, $table [, \%attr ]' ], O=>0x2200|0x8800 }, + primary_key => { U =>[4,5,'$catalog, $schema, $table [, \%attr ]' ], O=>0x2200 }, + foreign_key_info=> { U =>[7,8,'$pk_catalog, $pk_schema, $pk_table, $fk_catalog, $fk_schema, $fk_table [, \%attr ]' ], O=>0x2200|0x8800 }, + statistics_info => { U =>[6,7,'$catalog, $schema, $table, $unique_only, $quick, [, \%attr ]' ], O=>0x2200|0x8800 }, + type_info_all => { U =>[1,1], O=>0x2200|0x0800 }, + type_info => { U =>[1,2,'$data_type'], O=>0x2200 }, + get_info => { U =>[2,2,'$info_type'], O=>0x2200|0x0800 }, + }, + st => { # Statement Class Interface + bind_col => { U =>[3,4,'$column, \\$var [, \%attr]'] }, + bind_columns => { U =>[2,0,'\\$var1 [, \\$var2, ...]'] }, + bind_param => { U =>[3,4,'$parameter, $var [, \%attr]'] }, + bind_param_inout=> { U =>[4,5,'$parameter, \\$var, $maxlen, [, \%attr]'] }, + execute => { U =>[1,0,'[@args]'], O=>0x1040 }, + last_insert_id => { U =>[1,6,'[$catalog [,$schema [,$table_name [,$field_name [, \%attr ]]]]]'], O=>0x2800 }, + + bind_param_array => { U =>[3,4,'$parameter, $var [, \%attr]'] }, + bind_param_inout_array => { U =>[4,5,'$parameter, \\@var, $maxlen, [, \%attr]'] }, + execute_array => { U =>[2,0,'\\%attribs [, @args]'], O=>0x1040|0x4000 }, + execute_for_fetch => { U =>[2,3,'$fetch_sub [, $tuple_status]'], O=>0x1040|0x4000 }, + + fetch => undef, # alias for fetchrow_arrayref + fetchrow_arrayref => undef, + fetchrow_hashref => undef, + fetchrow_array => undef, + fetchrow => undef, # old alias for fetchrow_array + + fetchall_arrayref => { U =>[1,3, '[ $slice [, $max_rows]]'] }, + fetchall_hashref => { U =>[2,2,'$key_field'] }, + + blob_read => { U =>[4,5,'$field, $offset, $len [, \\$buf [, $bufoffset]]'] }, + blob_copy_to_file => { U =>[3,3,'$field, $filename_or_handleref'] }, + dump_results => { U =>[1,5,'$maxfieldlen, $linesep, $fieldsep, $filehandle'] }, + more_results => { U =>[1,1] }, + finish => { U =>[1,1] }, + cancel => { U =>[1,1], O=>0x0800 }, + rows => $keeperr, + + _get_fbav => undef, + _set_fbav => { T=>6 }, + }, +); + +while ( my ($class, $meths) = each %DBI::DBI_methods ) { + my $ima_trace = 0+($ENV{DBI_IMA_TRACE}||0); + while ( my ($method, $info) = each %$meths ) { + my $fullmeth = "DBI::${class}::$method"; + if (($DBI::dbi_debug & 0xF) == 15) { # quick hack to list DBI methods + # and optionally filter by IMA flags + my $O = $info->{O}||0; + printf "0x%04x %-20s\n", $O, $fullmeth + unless $ima_trace && !($O & $ima_trace); + } + DBI->_install_method($fullmeth, 'DBI.pm', $info); } - $tuples ||= "0E0"; - return $tuples unless wantarray; - return ($tuples, $rc_total); } -sub bind_param { - my ($sth, $param_num, $value, $attr) = @_; - # Store bind parameter for later use - $sth->{_bind_params} ||= {}; - $sth->{_bind_params}{$param_num} = $value; - return 1; +{ + package DBI::common; + @DBI::dr::ISA = ('DBI::common'); + @DBI::db::ISA = ('DBI::common'); + @DBI::st::ISA = ('DBI::common'); } -sub clone { - my ($dbh) = @_; - my %new_dbh = %{$dbh}; # Shallow copy - return bless \%new_dbh, ref($dbh); -} +# End of init code -sub err { - my ($handle) = @_; - return $handle->{err}; +END { + return unless defined &DBI::trace_msg; # return unless bootstrap'd ok + local ($!,$?); + DBI->trace_msg(sprintf(" -- DBI::END (\$\@: %s, \$!: %s)\n", $@||'', $!||''), 2); + # Let drivers know why we are calling disconnect_all: + $DBI::PERL_ENDING = $DBI::PERL_ENDING = 1; # avoid typo warning + DBI->disconnect_all() if %DBI::installed_drh; } -sub errstr { - my ($handle) = @_; - return $handle->{errstr} || ''; -} -sub state { - my ($handle) = @_; - my $state = $handle->{state}; - # Return empty string for success code 00000 - return ($state && $state eq '00000') ? '' : ($state || 'S1000'); +sub CLONE { + _clone_dbis() unless $DBI::PurePerl; # clone the DBIS structure + DBI->trace_msg("CLONE DBI for new thread\n"); + while ( my ($driver, $drh) = each %DBI::installed_drh) { + no strict 'refs'; + next if defined &{"DBD::${driver}::CLONE"}; + warn("$driver has no driver CLONE() function so is unsafe threaded\n"); + } + %DBI::installed_drh = (); # clear loaded drivers so they have a chance to reinitialize } -sub selectrow_arrayref { - my ($dbh, $statement, $attr, @params) = @_; - my $sth = $dbh->prepare($statement, $attr) or return undef; - $sth->execute(@params) or return undef; - return $sth->fetchrow_arrayref(); +sub parse_dsn { + my ($class, $dsn) = @_; + $dsn =~ s/^(dbi):(\w*?)(?:\((.*?)\))?://i or return; + my ($scheme, $driver, $attr, $attr_hash) = (lc($1), $2, $3); + $driver ||= $ENV{DBI_DRIVER} || ''; + $attr_hash = { split /\s*=>?\s*|\s*,\s*/, $attr, -1 } if $attr; + return ($scheme, $driver, $attr, $attr_hash, $dsn); } -sub selectrow_hashref { - my ($dbh, $statement, $attr, @params) = @_; - my $sth = $dbh->prepare($statement, $attr) or return undef; - $sth->execute(@params) or return undef; - return $sth->fetchrow_hashref(); +sub visit_handles { + my ($class, $code, $outer_info) = @_; + $outer_info = {} if not defined $outer_info; + my %drh = DBI->installed_drivers; + for my $h (values %drh) { + my $child_info = $code->($h, $outer_info) + or next; + $h->visit_child_handles($code, $child_info); + } + return $outer_info; } -sub selectrow_array { - my $arr = selectrow_arrayref(@_); - return $arr ? @$arr : (); -} -sub fetchrow_array { - my $arr = fetchrow_arrayref(@_); - return $arr ? @$arr : (); -} +# --- The DBI->connect Front Door methods -sub fetch { - return fetchrow_arrayref(@_); +sub connect_cached { + # For library code using connect_cached() with mod_perl + # we redirect those calls to Apache::DBI::connect() as well + my ($class, $dsn, $user, $pass, $attr) = @_; + my $dbi_connect_method = ($DBI::connect_via eq "Apache::DBI::connect") + ? 'Apache::DBI::connect' : 'connect_cached'; + $attr = { + $attr ? %$attr : (), # clone, don't modify callers data + dbi_connect_method => $dbi_connect_method, + }; + return $class->connect($dsn, $user, $pass, $attr); } -sub fetchall_arrayref { - my ($sth, $slice, $max_rows) = @_; +sub connect { + my $class = shift; + my ($dsn, $user, $pass, $attr, $old_driver) = my @orig_args = @_; + my $driver; + + if ($attr and !ref($attr)) { # switch $old_driver<->$attr if called in old style + Carp::carp("DBI->connect using 'old-style' syntax is deprecated and will be an error in future versions"); + ($old_driver, $attr) = ($attr, $old_driver); + } - # Return undef if statement handle is inactive - return undef unless $sth->{Database}{Active}; + my $connect_meth = $attr->{dbi_connect_method}; + $connect_meth ||= $DBI::connect_via; # fallback to default - my @rows; - my $row_count = 0; + $dsn ||= $ENV{DBI_DSN} || $ENV{DBI_DBNAME} || '' unless $old_driver; - # Handle different slice types - if (!defined $slice) { - # Default behavior - fetch all columns as array refs - while (!defined($max_rows) || $row_count < $max_rows) { - my $row = $sth->fetchrow_arrayref(); - last unless $row; - push @rows, $row; # Use the row directly to avoid unnecessary copying - $row_count++; - } + if ($DBI::dbi_debug) { + no warnings; + pop @_ if $connect_meth ne 'connect'; + my @args = @_; $args[2] = '****'; # hide password + DBI->trace_msg(" -> $class->$connect_meth(".join(", ",@args).")\n"); } - elsif (ref($slice) eq 'ARRAY') { - # Array slice - select specific columns by index - while (!defined($max_rows) || $row_count < $max_rows) { - my $row = $sth->fetchrow_arrayref(); - last unless $row; - if (@$slice) { - push @rows, [ map {$row->[$_]} @$slice ]; - } - else { - push @rows, $row; # Use the row directly - } - $row_count++; - } + Carp::croak('Usage: $class->connect([$dsn [,$user [,$passwd [,\%attr]]]])') + if (ref $old_driver or ($attr and not ref $attr) or + (ref $pass and not defined Scalar::Util::blessed($pass))); + + # extract dbi:driver prefix from $dsn into $1 + my $orig_dsn = $dsn; + $dsn =~ s/^dbi:(\w*?)(?:\((.*?)\))?://i + or '' =~ /()/; # ensure $1 etc are empty if match fails + my $driver_attrib_spec = $2 || ''; + + # Set $driver. Old style driver, if specified, overrides new dsn style. + $driver = $old_driver || $1 || $ENV{DBI_DRIVER} + or Carp::croak("Can't connect to data source '$orig_dsn' " + ."because I can't work out what driver to use " + ."(it doesn't seem to contain a 'dbi:driver:' prefix " + ."and the DBI_DRIVER env var is not set)"); + + my $proxy; + if ($ENV{DBI_AUTOPROXY} && $driver ne 'Proxy' && $driver ne 'Sponge' && $driver ne 'Switch') { + my $dbi_autoproxy = $ENV{DBI_AUTOPROXY}; + $proxy = 'Proxy'; + if ($dbi_autoproxy =~ s/^dbi:(\w*?)(?:\((.*?)\))?://i) { + $proxy = $1; + $driver_attrib_spec = join ",", + ($driver_attrib_spec) ? $driver_attrib_spec : (), + ($2 ) ? $2 : (); + } + $dsn = "$dbi_autoproxy;dsn=dbi:$driver:$dsn"; + $driver = $proxy; + DBI->trace_msg(" DBI_AUTOPROXY: dbi:$driver($driver_attrib_spec):$dsn\n"); + } + # avoid recursion if proxy calls DBI->connect itself + local $ENV{DBI_AUTOPROXY} if $ENV{DBI_AUTOPROXY}; + + my %attributes; # take a copy we can delete from + if ($old_driver) { + %attributes = %$attr if $attr; + } + else { # new-style connect so new default semantics + %attributes = ( + PrintError => 1, + AutoCommit => 1, + ref $attr ? %$attr : (), + # attributes in DSN take precedence over \%attr connect parameter + $driver_attrib_spec ? (split /\s*=>?\s*|\s*,\s*/, $driver_attrib_spec, -1) : (), + ); + } + $attr = \%attributes; # now set $attr to refer to our local copy + + my $drh = $DBI::installed_drh{$driver} || $class->install_driver($driver) + or die "panic: $class->install_driver($driver) failed"; + + # attributes in DSN take precedence over \%attr connect parameter + $user = $attr->{Username} if defined $attr->{Username}; + $pass = $attr->{Password} if defined $attr->{Password}; + delete $attr->{Password}; # always delete Password as closure stores it securely + if ( !(defined $user && defined $pass) ) { + ($user, $pass) = $drh->default_user($user, $pass, $attr); } - elsif (ref($slice) eq 'HASH') { - # Hash slice - fetch as hash refs with selected columns - while (!defined($max_rows) || $row_count < $max_rows) { - my $row = $sth->fetchrow_hashref(); - last unless $row; - if (%$slice) { - # Select only requested columns - my %new_row = map {$_ => $row->{$_}} - grep {exists $slice->{$_}} - keys %$row; - push @rows, \%new_row; + $attr->{Username} = $user; # force the Username to be the actual one used + + my $connect_closure = sub { + my ($old_dbh, $override_attr) = @_; + + #use Data::Dumper; + #warn "connect_closure: ".Data::Dumper::Dumper([$attr,\%attributes, $override_attr]); + + my $dbh; + unless ($dbh = $drh->$connect_meth($dsn, $user, $pass, $attr)) { + $user = '' if !defined $user; + $dsn = '' if !defined $dsn; + # $drh->errstr isn't safe here because $dbh->DESTROY may not have + # been called yet and so the dbh errstr would not have been copied + # up to the drh errstr. Certainly true for connect_cached! + my $errstr = $DBI::errstr; + # Getting '(no error string)' here is a symptom of a ref loop + $errstr = '(no error string)' if !defined $errstr; + my $msg = "$class connect('$dsn','$user',...) failed: $errstr"; + DBI->trace_msg(" $msg\n"); + # XXX HandleWarn + unless ($attr->{HandleError} && $attr->{HandleError}->($msg, $drh, $dbh)) { + Carp::croak($msg) if $attr->{RaiseError}; + Carp::carp ($msg) if $attr->{PrintError}; + } + $! = 0; # for the daft people who do DBI->connect(...) || die "$!"; + return $dbh; # normally undef, but HandleError could change it + } + + # merge any attribute overrides but don't change $attr itself (for closure) + my $apply = { ($override_attr) ? (%$attr, %$override_attr ) : %$attr }; + + # handle basic RootClass subclassing: + my $rebless_class = $apply->{RootClass} || ($class ne 'DBI' ? $class : ''); + if ($rebless_class) { + no strict 'refs'; + if ($apply->{RootClass}) { # explicit attribute (ie not static method call class) + delete $apply->{RootClass}; + DBI::_load_class($rebless_class, 0); + } + unless (@{"$rebless_class\::db::ISA"} && @{"$rebless_class\::st::ISA"}) { + Carp::carp("DBI subclasses '$rebless_class\::db' and ::st are not setup, RootClass ignored"); + $rebless_class = undef; + $class = 'DBI'; } else { - push @rows, $row; # Use the row directly + $dbh->{RootClass} = $rebless_class; # $dbh->STORE called via plain DBI::db + DBI::_set_isa([$rebless_class], 'DBI'); # sets up both '::db' and '::st' + DBI::_rebless($dbh, $rebless_class); # appends '::db' } - $row_count++; } - } - elsif (ref($slice) eq 'REF' && ref($slice) eq 'HASH') { - # Column index to name mapping - while (!defined($max_rows) || $row_count < $max_rows) { - my $row = $sth->fetchrow_arrayref(); - last unless $row; - my %new_row; - while (my ($idx, $key) = each %{$slice}) { - $new_row{$key} = $row->[$idx]; + + if (%$apply) { + + if ($apply->{DbTypeSubclass}) { + my $DbTypeSubclass = delete $apply->{DbTypeSubclass}; + DBI::_rebless_dbtype_subclass($dbh, $rebless_class||$class, $DbTypeSubclass); } - push @rows, \%new_row; - $row_count++; - } + my $a; + foreach $a (qw(Profile RaiseError PrintError AutoCommit)) { # do these first + next unless exists $apply->{$a}; + $dbh->{$a} = delete $apply->{$a}; + } + while ( my ($a, $v) = each %$apply) { + eval { $dbh->{$a} = $v }; # assign in void context to avoid re-FETCH + warn $@ if $@; + } + } + + # confirm to driver (ie if subclassed) that we've connected successfully + # and finished the attribute setup. pass in the original arguments + $dbh->connected(@orig_args); #if ref $dbh ne 'DBI::db' or $proxy; + + DBI->trace_msg(" <- connect= $dbh\n") if $DBI::dbi_debug & 0xF; + + return $dbh; + }; + + my $dbh = &$connect_closure(undef, undef); + + $dbh->{dbi_connect_closure} = $connect_closure if $dbh; + + return $dbh; +} + + +sub disconnect_all { + keys %DBI::installed_drh; # reset iterator + while ( my ($name, $drh) = each %DBI::installed_drh ) { + $drh->disconnect_all() if ref $drh; } +} + - return \@rows; +sub disconnect { # a regular beginners bug + Carp::croak("DBI->disconnect is not a DBI method (read the DBI manual)"); } -sub fetchall_hashref { - my ($sth, $key_field) = @_; - # Return undef if statement handle is inactive - return undef unless $sth->{Database}{Active}; +sub install_driver { # croaks on failure + my $class = shift; + my($driver, $attr) = @_; + my $drh; - my %results; + $driver ||= $ENV{DBI_DRIVER} || ''; - # Convert key_field to array ref if it's not already - my @key_fields = ref($key_field) eq 'ARRAY' ? @$key_field : ($key_field); + # allow driver to be specified as a 'dbi:driver:' string + $driver = $1 if $driver =~ s/^DBI:(.*?)://i; - # Get column names/info - my $hash_key_name = $sth->{FetchHashKeyName} || 'NAME'; - my $fields = $sth->{$hash_key_name}; - my %field_index; - for my $i (0 .. $#{$fields}) { - $field_index{$fields->[$i]} = $i + 1; # 1-based indexing + Carp::croak("usage: $class->install_driver(\$driver [, \%attr])") + unless ($driver and @_<=3); + + # already installed + return $drh if $drh = $DBI::installed_drh{$driver}; + + $class->trace_msg(" -> $class->install_driver($driver" + .") for $^O perl=$] pid=$$ ruid=$< euid=$>\n") + if $DBI::dbi_debug & 0xF; + + # --- load the code + my $driver_class = "DBD::$driver"; + eval qq{package # hide from PAUSE + DBI::_firesafe; # just in case + require $driver_class; # load the driver + }; + if ($@) { + my $err = $@; + my $advice = ""; + if ($err =~ /Can't find loadable object/) { + $advice = "Perhaps DBD::$driver was statically linked into a new perl binary." + ."\nIn which case you need to use that new perl binary." + ."\nOr perhaps only the .pm file was installed but not the shared object file." + } + elsif ($err =~ /Can't locate.*?DBD\/$driver\.pm in \@INC/) { + my @drv = $class->available_drivers(1); + $advice = "Perhaps the DBD::$driver perl module hasn't been fully installed,\n" + ."or perhaps the capitalisation of '$driver' isn't right.\n" + ."Available drivers: ".join(", ", @drv)."."; + } + elsif ($err =~ /Can't load .*? for module DBD::/) { + $advice = "Perhaps a required shared library or dll isn't installed where expected"; + } + elsif ($err =~ /Can't locate .*? in \@INC/) { + $advice = "Perhaps a module that DBD::$driver requires hasn't been fully installed"; + } + Carp::croak("install_driver($driver) failed: $err$advice\n"); + } + if ($DBI::dbi_debug & 0xF) { + no strict 'refs'; + (my $driver_file = $driver_class) =~ s/::/\//g; + my $dbd_ver = ${"$driver_class\::VERSION"} || "undef"; + $class->trace_msg(" install_driver: $driver_class version $dbd_ver" + ." loaded from $INC{qq($driver_file.pm)}\n"); } - # Verify key fields exist - for my $key (@key_fields) { - unless (exists $field_index{$key} || ($key =~ /^\d+$/ && $key <= @$fields)) { - return undef; # Invalid key field - } + # --- do some behind-the-scenes checks and setups on the driver + $class->setup_driver($driver_class); + + # --- run the driver function + $drh = eval { $driver_class->driver($attr || {}) }; + unless ($drh && ref $drh && !$@) { + my $advice = ""; + $@ ||= "$driver_class->driver didn't return a handle"; + # catch people on case in-sensitive systems using the wrong case + $advice = "\nPerhaps the capitalisation of DBD '$driver' isn't right." + if $@ =~ /locate object method/; + Carp::croak("$driver_class initialisation failed: $@$advice"); } - # Fetch all rows - while (my $row = $sth->fetchrow_hashref()) { - my $href = \%results; + $DBI::installed_drh{$driver} = $drh; + $class->trace_msg(" <- install_driver= $drh\n") if $DBI::dbi_debug & 0xF; + $drh; +} - # Navigate through all but the last key - for my $i (0 .. $#key_fields - 1) { - my $key = $key_fields[$i]; - my $key_value; +*driver = \&install_driver; # currently an alias, may change - # Handle numeric column reference - if ($key =~ /^\d+$/) { - $key_value = $row->{$fields->[$key - 1]}; - } - else { - $key_value = $row->{$key}; - } - $href->{$key_value} ||= {}; - $href = $href->{$key_value}; - } +sub setup_driver { + my ($class, $driver_class) = @_; + my $h_type; + foreach $h_type (qw(dr db st)){ + my $h_class = $driver_class."::$h_type"; + no strict 'refs'; + push @{"${h_class}::ISA"}, "DBD::_::$h_type" + unless UNIVERSAL::isa($h_class, "DBD::_::$h_type"); + # The _mem class stuff is (IIRC) a crufty hack for global destruction + # timing issues in early versions of perl5 and possibly no longer needed. + my $mem_class = "DBD::_mem::$h_type"; + push @{"${h_class}_mem::ISA"}, $mem_class + unless UNIVERSAL::isa("${h_class}_mem", $mem_class) + or $DBI::PurePerl; + } +} - # Handle the last key - my $final_key = $key_fields[-1]; - my $final_value; - # Handle numeric column reference - if ($final_key =~ /^\d+$/) { - $final_value = $row->{$fields->[$final_key - 1]}; - } - else { - $final_value = $row->{$final_key}; - } +sub _rebless { + my $dbh = shift; + my ($outer, $inner) = DBI::_handles($dbh); + my $class = shift(@_).'::db'; + bless $inner => $class; + bless $outer => $class; # outer last for return +} + - $href->{$final_value} = $row; # Use the row directly +sub _set_isa { + my ($classes, $topclass) = @_; + my $trace = DBI->trace_msg(" _set_isa([@$classes])\n"); + foreach my $suffix ('::db','::st') { + my $previous = $topclass || 'DBI'; # trees are rooted here + foreach my $class (@$classes) { + my $base_class = $previous.$suffix; + my $sub_class = $class.$suffix; + my $sub_class_isa = "${sub_class}::ISA"; + no strict 'refs'; + if (@$sub_class_isa) { + DBI->trace_msg(" $sub_class_isa skipped (already set to @$sub_class_isa)\n") + if $trace; + } + else { + @$sub_class_isa = ($base_class) unless @$sub_class_isa; + DBI->trace_msg(" $sub_class_isa = $base_class\n") + if $trace; + } + $previous = $class; + } } +} + - return \%results; +sub _rebless_dbtype_subclass { + my ($dbh, $rootclass, $DbTypeSubclass) = @_; + # determine the db type names for class hierarchy + my @hierarchy = DBI::_dbtype_names($dbh, $DbTypeSubclass); + # add the rootclass prefix to each ('DBI::' or 'MyDBI::' etc) + $_ = $rootclass.'::'.$_ foreach (@hierarchy); + # load the modules from the 'top down' + DBI::_load_class($_, 1) foreach (reverse @hierarchy); + # setup class hierarchy if needed, does both '::db' and '::st' + DBI::_set_isa(\@hierarchy, $rootclass); + # finally bless the handle into the subclass + DBI::_rebless($dbh, $hierarchy[0]); } -sub selectall_arrayref { - my ($dbh, $statement, $attr, @bind_values) = @_; - # Handle statement handle or SQL string - my $sth = ref($statement) ? $statement : $dbh->prepare($statement, $attr) - or return undef; +sub _dbtype_names { # list dbtypes for hierarchy, ie Informix=>ADO=>ODBC + my ($dbh, $DbTypeSubclass) = @_; - $sth->execute(@bind_values) or return undef; + if ($DbTypeSubclass && $DbTypeSubclass ne '1' && ref $DbTypeSubclass ne 'CODE') { + # treat $DbTypeSubclass as a comma separated list of names + my @dbtypes = split /\s*,\s*/, $DbTypeSubclass; + $dbh->trace_msg(" DbTypeSubclass($DbTypeSubclass)=@dbtypes (explicit)\n"); + return @dbtypes; + } - # Extract MaxRows and Slice/Columns attributes - my $max_rows = $attr->{MaxRows}; - my $slice = $attr->{Slice}; + # XXX will call $dbh->get_info(17) (=SQL_DBMS_NAME) in future? - # Handle Columns attribute (convert 1-based indices to 0-based) - if (!defined $slice && defined $attr->{Columns}) { - if (ref $attr->{Columns} eq 'ARRAY') { - $slice = [ map {$_ - 1} @{$attr->{Columns}} ]; - } - else { - $slice = $attr->{Columns}; - } + my $driver = $dbh->{Driver}->{Name}; + if ( $driver eq 'Proxy' ) { + # XXX Looking into the internals of DBD::Proxy is questionable! + ($driver) = $dbh->{proxy_client}->{application} =~ /^DBI:(.+?):/i + or die "Can't determine driver name from proxy"; } - # Fetch all rows using the specified parameters - my $rows = $sth->fetchall_arrayref($slice, $max_rows); + my @dbtypes = (ucfirst($driver)); + if ($driver eq 'ODBC' || $driver eq 'ADO') { + # XXX will move these out and make extensible later: + my $_dbtype_name_regexp = 'Oracle'; # eg 'Oracle|Foo|Bar' + my %_dbtype_name_map = ( + 'Microsoft SQL Server' => 'MSSQL', + 'SQL Server' => 'Sybase', + 'Adaptive Server Anywhere' => 'ASAny', + 'ADABAS D' => 'AdabasD', + ); - # Call finish() if MaxRows was specified - $sth->finish if defined $max_rows; + my $name; + $name = $dbh->func(17, 'GetInfo') # SQL_DBMS_NAME + if $driver eq 'ODBC'; + $name = $dbh->{ado_conn}->Properties->Item('DBMS Name')->Value + if $driver eq 'ADO'; + die "Can't determine driver name! ($DBI::errstr)\n" + unless $name; - return $rows; + my $dbtype; + if ($_dbtype_name_map{$name}) { + $dbtype = $_dbtype_name_map{$name}; + } + else { + if ($name =~ /($_dbtype_name_regexp)/) { + $dbtype = lc($1); + } + else { # generic mangling for other names: + $dbtype = lc($name); + } + $dbtype =~ s/\b(\w)/\U$1/g; + $dbtype =~ s/\W+/_/g; + } + # add ODBC 'behind' ADO + push @dbtypes, 'ODBC' if $driver eq 'ADO'; + # add discovered dbtype in front of ADO/ODBC + unshift @dbtypes, $dbtype; + } + @dbtypes = &$DbTypeSubclass($dbh, \@dbtypes) + if (ref $DbTypeSubclass eq 'CODE'); + $dbh->trace_msg(" DbTypeSubclass($DbTypeSubclass)=@dbtypes\n"); + return @dbtypes; } -sub selectall_hashref { - my ($dbh, $statement, $key_field, $attr, @bind_values) = @_; - - # Handle statement handle or SQL string - my $sth = ref($statement) ? $statement : $dbh->prepare($statement, $attr) - or return undef; +sub _load_class { + my ($load_class, $missing_ok) = @_; + DBI->trace_msg(" _load_class($load_class, $missing_ok)\n", 2); + no strict 'refs'; + return 1 if @{"$load_class\::ISA"}; # already loaded/exists + (my $module = $load_class) =~ s!::!/!g; + DBI->trace_msg(" _load_class require $module\n", 2); + eval { require "$module.pm"; }; + return 1 unless $@; + return 0 if $missing_ok && $@ =~ /^Can't locate \Q$module.pm\E/; + die $@; +} - # Execute with bind values if provided - $sth->execute(@bind_values) or return undef; - # Reuse fetchall_hashref to do the heavy lifting - return $sth->fetchall_hashref($key_field); +sub init_rootclass { # deprecated + return 1; } -sub bind_columns { - my ($sth, @refs) = @_; - return 1 unless @refs; - # Clear existing bound columns - $sth->{bound_columns} = {}; +*internal = \&DBD::Switch::dr::driver; + +sub driver_prefix { + my ($class, $driver) = @_; + return $dbd_class_registry{$driver}->{prefix} if exists $dbd_class_registry{$driver}; + return; +} - # Bind each column reference - for (my $i = 0; $i < @refs; $i++) { - $sth->bind_col($i + 1, $refs[$i]) or return undef; +sub available_drivers { + my($quiet) = @_; + my(@drivers, $d, $f); + local(*DBI::DIR, $@); + my(%seen_dir, %seen_dbd); + my $haveFileSpec = eval { require File::Spec }; + foreach $d (@INC){ + chomp($d); # Perl 5 beta 3 bug in #!./perl -Ilib from Test::Harness + my $dbd_dir = + ($haveFileSpec ? File::Spec->catdir($d, 'DBD') : "$d/DBD"); + next unless -d $dbd_dir; + next if $seen_dir{$d}; + $seen_dir{$d} = 1; + # XXX we have a problem here with case insensitive file systems + # XXX since we can't tell what case must be used when loading. + opendir(DBI::DIR, $dbd_dir) || Carp::carp "opendir $dbd_dir: $!\n"; + foreach $f (readdir(DBI::DIR)){ + next unless $f =~ s/\.pm$//; + next if $f eq 'NullP'; + if ($seen_dbd{$f}){ + Carp::carp "DBD::$f in $d is hidden by DBD::$f in $seen_dbd{$f}\n" + unless $quiet; + } else { + push(@drivers, $f); + } + $seen_dbd{$f} = $d; + } + closedir(DBI::DIR); } - return 1; + + # "return sort @drivers" will not DWIM in scalar context. + return wantarray ? sort @drivers : @drivers; } -sub trace { - my ($dbh, $level, $output) = @_; - my $old_level; - - if (ref $dbh) { - $old_level = $dbh->{TraceLevel} || 0; - $dbh->{TraceLevel} = $level if defined $level; - } else { - # class method: DBI->trace(...) sets the process-global level - $old_level = $DBI::dbi_debug || 0; - $DBI::dbi_debug = $level if defined $level; - } - - # If a third argument is passed (even as undef), it controls where - # trace output goes. A filename or filehandle opens / installs it - # as the process-global trace filehandle (real DBI's $DBI::tfh). - # undef closes any installed tracefile and reverts to STDERR. - if (@_ >= 3) { - if (ref $output && (ref $output eq 'GLOB' || eval { *{$output}{IO} })) { - $DBI::tfh = $output; - } elsif (defined $output && length $output) { - # Close any previously-opened trace file. - if ($DBI::tfh_owned) { - close $DBI::tfh; - $DBI::tfh = undef; - } - open my $fh, '>>', $output - or do { warn "DBI trace($output): $!"; return $old_level }; - # unbuffer trace output so the test `-s $trace_file` sees it. - my $oldfh = select $fh; $| = 1; select $oldfh; - $DBI::tfh = $fh; - $DBI::tfh_owned = 1; - } else { - # $output was passed but is undef / empty — restore STDERR. - if ($DBI::tfh_owned) { - close $DBI::tfh; - $DBI::tfh_owned = 0; - } - $DBI::tfh = undef; - } +sub installed_versions { + my ($class, $quiet) = @_; + my %error; + my %version; + for my $driver ($class->available_drivers($quiet)) { + next if $DBI::PurePerl && grep { -d "$_/auto/DBD/$driver" } @INC; + my $drh = eval { + local $SIG{__WARN__} = sub {}; + $class->install_driver($driver); + }; + ($error{"DBD::$driver"}=$@),next if $@; + no strict 'refs'; + my $vers = ${"DBD::$driver" . '::VERSION'}; + $version{"DBD::$driver"} = $vers || '?'; + } + if (wantarray) { + return map { m/^DBD::(\w+)/ ? ($1) : () } sort keys %version; } + $version{"DBI"} = $DBI::VERSION; + $version{"DBI::PurePerl"} = $DBI::PurePerl::VERSION if $DBI::PurePerl; + if (!defined wantarray) { # void context + require Config; # add more detail + $version{OS} = "$^O\t($Config::Config{osvers})"; + $version{Perl} = "$]\t($Config::Config{archname})"; + $version{$_} = (($error{$_} =~ s/ \(\@INC.*//s),$error{$_}) + for keys %error; + printf " %-16s: %s\n",$_,$version{$_} + for reverse sort keys %version; + } + return \%version; +} - return $old_level; + +sub data_sources { + my ($class, $driver, @other) = @_; + my $drh = $class->install_driver($driver); + my @ds = $drh->data_sources(@other); + return @ds; } -# _trace_fh() — picks the right filehandle to write a trace message to. -sub _trace_fh { - return $DBI::tfh if defined $DBI::tfh; - return \*STDERR; + +sub neat_list { + my ($listref, $maxlen, $sep) = @_; + $maxlen = 0 unless defined $maxlen; # 0 == use internal default + $sep = ", " unless defined $sep; + join($sep, map { neat($_,$maxlen) } @$listref); } -sub trace_msg { - my ($dbh, $msg, $level) = @_; - $level ||= 1; - my $current_level = ref($dbh) - ? ($dbh->{TraceLevel} || 0) - : ($DBI::dbi_debug || 0); - if ($level <= $current_level) { - my $fh = DBI::_trace_fh(); - print $fh $msg; +sub dump_results { # also aliased as a method in DBD::_::st + my ($sth, $maxlen, $lsep, $fsep, $fh) = @_; + return 0 unless $sth; + $maxlen ||= 35; + $lsep ||= "\n"; + $fh ||= \*STDOUT; + my $rows = 0; + my $ref; + while($ref = $sth->fetch) { + print $fh $lsep if $rows++ and $lsep; + my $str = neat_list($ref,$maxlen,$fsep); + print $fh $str; # done on two lines to avoid 5.003 errors } - return 1; + print $fh "\n$rows rows".($DBI::err ? " ($DBI::err: $DBI::errstr)" : "")."\n"; + $rows; } -sub prepare_cached { - my ($dbh, $sql, $attr, $if_active) = @_; - - # Use a per-dbh cache (like real DBI's CachedKids) to avoid cross-connection - # cache hits when multiple connections share the same Name (e.g., :memory:) - $dbh->{CachedKids} ||= {}; - my $cache = $dbh->{CachedKids}; - - if (exists $cache->{$sql}) { - my $sth = $cache->{$sql}; - if ($sth->{Database}{Active}) { - # Handle if_active parameter: - # 1 = warn and finish, 2 = finish silently, 3 = return new sth - if ($if_active && $sth->{Active}) { - if ($if_active == 3) { - # Return a fresh sth instead of the active cached one - my $new_sth = _prepare_as_cached($dbh, $sql, $attr); - return undef unless $new_sth; - $cache->{$sql} = $new_sth; - return $new_sth; - } - $sth->finish; - } - return $sth; - } - } - my $sth = _prepare_as_cached($dbh, $sql, $attr); - return undef unless $sth; - $cache->{$sql} = $sth; - return $sth; +sub data_diff { + my ($a, $b, $logical) = @_; + + my $diff = data_string_diff($a, $b); + return "" if $logical and !$diff; + + my $a_desc = data_string_desc($a); + my $b_desc = data_string_desc($b); + return "" if !$diff and $a_desc eq $b_desc; + + $diff ||= "Strings contain the same sequence of characters" + if length($a); + $diff .= "\n" if $diff; + return "a: $a_desc\nb: $b_desc\n$diff"; } -# Call prepare() but rewrite error messages to say prepare_cached. -# This matches real DBI behavior where prepare_cached is the reported method. -sub _prepare_as_cached { - my ($dbh, $sql, $attr) = @_; - my $sth = eval { $dbh->prepare($sql, $attr) }; - if ($@) { - my $err = "$@"; - $err =~ s/\bDBI prepare failed\b/DBI prepare_cached failed/g; - die $err; + +sub data_string_diff { + # Compares 'logical' characters, not bytes, so a latin1 string and an + # an equivalent Unicode string will compare as equal even though their + # byte encodings are different. + my ($a, $b) = @_; + unless (defined $a and defined $b) { # one undef + return "" + if !defined $a and !defined $b; + return "String a is undef, string b has ".length($b)." characters" + if !defined $a; + return "String b is undef, string a has ".length($a)." characters" + if !defined $b; } - return $sth; + + my @a_chars = (utf8::is_utf8($a)) ? unpack("U*", $a) : unpack("C*", $a); + my @b_chars = (utf8::is_utf8($b)) ? unpack("U*", $b) : unpack("C*", $b); + my $i = 0; + while (@a_chars && @b_chars) { + ++$i, shift(@a_chars), shift(@b_chars), next + if $a_chars[0] == $b_chars[0];# compare ordinal values + my @desc = map { + $_ > 255 ? # if wide character... + sprintf("\\x{%04X}", $_) : # \x{...} + chr($_) =~ /[[:cntrl:]]/ ? # else if control character ... + sprintf("\\x%02X", $_) : # \x.. + chr($_) # else as themselves + } ($a_chars[0], $b_chars[0]); + # highlight probable double-encoding? + foreach my $c ( @desc ) { + next unless $c =~ m/\\x\{08(..)}/; + $c .= "='" .chr(hex($1)) ."'" + } + return sprintf "Strings differ at index $i: a[$i]=$desc[0], b[$i]=$desc[1]"; + } + return "String a truncated after $i characters" if @b_chars; + return "String b truncated after $i characters" if @a_chars; + return ""; } -sub connect_cached { - my ($class, $dsn, $user, $pass, $attr) = @_; - my $cache_key = "$dsn:$user"; +sub data_string_desc { # describe a data string + my ($a) = @_; + require bytes; - if (exists $CACHED_CONNECTIONS{$cache_key}) { - my $dbh = $CACHED_CONNECTIONS{$cache_key}; - if ($dbh->{Active} && $dbh->ping) { - return $dbh; - } + # Give sufficient info to help diagnose at least these kinds of situations: + # - valid UTF8 byte sequence but UTF8 flag not set + # (might be ascii so also need to check for hibit to make it worthwhile) + # - UTF8 flag set but invalid UTF8 byte sequence + # could do better here, but this'll do for now + my $utf8 = sprintf "UTF8 %s%s", + utf8::is_utf8($a) ? "on" : "off", + utf8::valid($a||'') ? "" : " but INVALID encoding"; + return "$utf8, undef" unless defined $a; + my $is_ascii = $a =~ m/^[\000-\177]*$/; + return sprintf "%s, %s, %d characters %d bytes", + $utf8, $is_ascii ? "ASCII" : "non-ASCII", + length($a), bytes::length($a); +} + + +sub connect_test_perf { + my($class, $dsn,$dbuser,$dbpass, $attr) = @_; + Carp::croak("connect_test_perf needs hash ref as fourth arg") unless ref $attr; + # these are non standard attributes just for this special method + my $loops ||= $attr->{dbi_loops} || 5; + my $par ||= $attr->{dbi_par} || 1; # parallelism + my $verb ||= $attr->{dbi_verb} || 1; + my $meth ||= $attr->{dbi_meth} || 'connect'; + print "$dsn: testing $loops sets of $par connections:\n"; + require "FileHandle.pm"; # don't let toke.c create empty FileHandle package + local $| = 1; + my $drh = $class->install_driver($dsn) or Carp::croak("Can't install $dsn driver\n"); + # test the connection and warm up caches etc + $drh->connect($dsn,$dbuser,$dbpass) or Carp::croak("connect failed: $DBI::errstr"); + my $t1 = dbi_time(); + my $loop; + for $loop (1..$loops) { + my @cons; + print "Connecting... " if $verb; + for (1..$par) { + print "$_ "; + push @cons, ($drh->connect($dsn,$dbuser,$dbpass) + or Carp::croak("connect failed: $DBI::errstr\n")); + } + print "\nDisconnecting...\n" if $verb; + for (@cons) { + $_->disconnect or warn "disconnect failed: $DBI::errstr" + } } + my $t2 = dbi_time(); + my $td = $t2 - $t1; + printf "$meth %d and disconnect them, %d times: %.4fs / %d = %.4fs\n", + $par, $loops, $td, $loops*$par, $td/($loops*$par); + return $td; +} + + +# Help people doing DBI->errstr, might even document it one day +# XXX probably best moved to cheaper XS code if this gets documented +sub err { $DBI::err } +sub errstr { $DBI::errstr } + + +# --- Private Internal Function for Creating New DBI Handles + +# XXX move to PurePerl? +*DBI::dr::TIEHASH = \&DBI::st::TIEHASH; +*DBI::db::TIEHASH = \&DBI::st::TIEHASH; + + +# These three special constructors are called by the drivers +# The way they are called is likely to change. - my $dbh = $class->connect($dsn, $user, $pass, $attr) or return undef; +our $shared_profile; - # Implement simple LRU - if (keys %CACHED_CONNECTIONS >= $MAX_CACHED_CONNECTIONS) { - my @keys = keys %CACHED_CONNECTIONS; - delete $CACHED_CONNECTIONS{$keys[0]}; +sub _new_drh { # called by DBD::::driver() + my ($class, $initial_attr, $imp_data) = @_; + # Provide default storage for State,Err and Errstr. + # Note that these are shared by all child handles by default! XXX + # State must be undef to get automatic faking in DBI::var::FETCH + my ($h_state_store, $h_err_store, $h_errstr_store) = (undef, undef, ''); + my $attr = { + # these attributes get copied down to child handles by default + 'State' => \$h_state_store, # Holder for DBI::state + 'Err' => \$h_err_store, # Holder for DBI::err + 'Errstr' => \$h_errstr_store, # Holder for DBI::errstr + 'TraceLevel' => 0, + FetchHashKeyName=> 'NAME', + %$initial_attr, + }; + my ($h, $i) = _new_handle('DBI::dr', '', $attr, $imp_data, $class); + + # XXX DBI_PROFILE unless DBI::PurePerl because for some reason + # it kills the t/zz_*_pp.t tests (they silently exit early) + if (($ENV{DBI_PROFILE} && !$DBI::PurePerl) || $shared_profile) { + # The profile object created here when the first driver is loaded + # is shared by all drivers so we end up with just one set of profile + # data and thus the 'total time in DBI' is really the true total. + if (!$shared_profile) { # first time + $h->{Profile} = $ENV{DBI_PROFILE}; # write string + $shared_profile = $h->{Profile}; # read and record object + } + else { + $h->{Profile} = $shared_profile; + } } + return $h unless wantarray; + ($h, $i); +} - $CACHED_CONNECTIONS{$cache_key} = $dbh; - return $dbh; +sub _new_dbh { # called by DBD::::dr::connect() + my ($drh, $attr, $imp_data) = @_; + my $imp_class = $drh->{ImplementorClass} + or Carp::croak("DBI _new_dbh: $drh has no ImplementorClass"); + substr($imp_class,-4,4) = '::db'; + my $app_class = ref $drh; + substr($app_class,-4,4) = '::db'; + $attr->{Err} ||= \my $err; + $attr->{Errstr} ||= \my $errstr; + $attr->{State} ||= \my $state; + _new_handle($app_class, $drh, $attr, $imp_data, $imp_class); } -1; +sub _new_sth { # called by DBD::::db::prepare) + my ($dbh, $attr, $imp_data) = @_; + my $imp_class = $dbh->{ImplementorClass} + or Carp::croak("DBI _new_sth: $dbh has no ImplementorClass"); + substr($imp_class,-4,4) = '::st'; + my $app_class = ref $dbh; + substr($app_class,-4,4) = '::st'; + _new_handle($app_class, $dbh, $attr, $imp_data, $imp_class); +} -__END__ -Author and Copyright messages from the original DBI.pm: +# end of DBI package -=head1 AUTHORS -DBI by Tim Bunce, L -This pod text by Tim Bunce, J. Douglas Dunlop, Jonathan Leffler and others. -Perl by Larry Wall and the C. +# -------------------------------------------------------------------- +# === The internal DBI Switch pseudo 'driver' class === -=head1 COPYRIGHT +{ package # hide from PAUSE + DBD::Switch::dr; + DBI->setup_driver('DBD::Switch'); # sets up @ISA -The DBI module is Copyright (c) 1994-2012 Tim Bunce. Ireland. -All rights reserved. + $DBD::Switch::dr::imp_data_size = 0; + $DBD::Switch::dr::imp_data_size = 0; # avoid typo warning + my $drh; -You may distribute under the terms of either the GNU General Public -License or the Artistic License, as specified in the Perl 5.10.0 README file. + sub driver { + return $drh if $drh; # a package global + + my $inner; + ($drh, $inner) = DBI::_new_drh('DBD::Switch::dr', { + 'Name' => 'Switch', + 'Version' => $DBI::VERSION, + 'Attribution' => "DBI $DBI::VERSION by Tim Bunce", + }); + Carp::croak("DBD::Switch init failed!") unless ($drh && $inner); + return $drh; + } + sub CLONE { + undef $drh; + } + + sub FETCH { + my($drh, $key) = @_; + return DBI->trace if $key eq 'DebugDispatch'; + return undef if $key eq 'DebugLog'; # not worth fetching, sorry + return $drh->DBD::_::dr::FETCH($key); + undef; + } + sub STORE { + my($drh, $key, $value) = @_; + if ($key eq 'DebugDispatch') { + DBI->trace($value); + } elsif ($key eq 'DebugLog') { + DBI->trace(-1, $value); + } else { + $drh->DBD::_::dr::STORE($key, $value); + } + } +} + + +# -------------------------------------------------------------------- +# === OPTIONAL MINIMAL BASE CLASSES FOR DBI SUBCLASSES === + +# We only define default methods for harmless functions. +# We don't, for example, define a DBD::_::st::prepare() + +{ package # hide from PAUSE + DBD::_::common; # ====== Common base class methods ====== + use strict; + + # methods common to all handle types: + + # generic TIEHASH default methods: + sub FIRSTKEY { } + sub NEXTKEY { } + sub EXISTS { defined($_[0]->FETCH($_[1])) } # XXX undef? + sub CLEAR { Carp::carp "Can't CLEAR $_[0] (DBI)" } + + sub FETCH_many { # XXX should move to C one day + my $h = shift; + # scalar is needed to workaround drivers that return an empty list + # for some attributes + return map { scalar $h->FETCH($_) } @_; + } + + *dump_handle = \&DBI::dump_handle; + + sub install_method { + # special class method called directly by apps and/or drivers + # to install new methods into the DBI dispatcher + # DBD::Foo::db->install_method("foo_mumble", { usage => [...], options => '...' }); + my ($class, $method, $attr) = @_; + Carp::croak("Class '$class' must begin with DBD:: and end with ::db or ::st") + unless $class =~ /^DBD::(\w+)::(dr|db|st)$/; + my ($driver, $subtype) = ($1, $2); + Carp::croak("invalid method name '$method'") + unless $method =~ m/^([a-z][a-z0-9]*_)\w+$/; + my $prefix = $1; + my $reg_info = $dbd_prefix_registry->{$prefix}; + Carp::carp("method name prefix '$prefix' is not associated with a registered driver") unless $reg_info; + + my $full_method = "DBI::${subtype}::$method"; + $DBI::installed_methods{$full_method} = $attr; + + my (undef, $filename, $line) = caller; + # XXX reformat $attr as needed for _install_method + my %attr = %{$attr||{}}; # copy so we can edit + DBI->_install_method("DBI::${subtype}::$method", "$filename at line $line", \%attr); + } + + sub parse_trace_flags { + my ($h, $spec) = @_; + my $level = 0; + my $flags = 0; + my @unknown; + for my $word (split /\s*[|&,]\s*/, $spec) { + if (DBI::looks_like_number($word) && $word <= 0xF && $word >= 0) { + $level = $word; + } elsif ($word eq 'ALL') { + $flags = 0x7FFFFFFF; # XXX last bit causes negative headaches + last; + } elsif (my $flag = $h->parse_trace_flag($word)) { + $flags |= $flag; + } + else { + push @unknown, $word; + } + } + if (@unknown && (ref $h ? $h->FETCH('Warn') : 1)) { + Carp::carp("$h->parse_trace_flags($spec) ignored unknown trace flags: ". + join(" ", map { DBI::neat($_) } @unknown)); + } + $flags |= $level; + return $flags; + } + + sub parse_trace_flag { + my ($h, $name) = @_; + # 0xddDDDDrL (driver, DBI, reserved, Level) + return 0x00000100 if $name eq 'SQL'; + return 0x00000200 if $name eq 'CON'; + return 0x00000400 if $name eq 'ENC'; + return 0x00000800 if $name eq 'DBD'; + return 0x00001000 if $name eq 'TXN'; + return; + } + + sub private_attribute_info { + return undef; + } + + sub visit_child_handles { + my ($h, $code, $info) = @_; + $info = {} if not defined $info; + for my $ch (@{ $h->{ChildHandles} || []}) { + next unless $ch; + my $child_info = $code->($ch, $info) + or next; + $ch->visit_child_handles($code, $child_info); + } + return $info; + } +} + + +{ package # hide from PAUSE + DBD::_::dr; # ====== DRIVER ====== + our @ISA = qw(DBD::_::common); + use strict; + + sub default_user { + my ($drh, $user, $pass, $attr) = @_; + $user = $ENV{DBI_USER} unless defined $user; + $pass = $ENV{DBI_PASS} unless defined $pass; + return ($user, $pass); + } + + sub connect { # normally overridden, but a handy default + my ($drh, $dsn, $user, $auth) = @_; + my ($this) = DBI::_new_dbh($drh, { + 'Name' => $dsn, + }); + # XXX debatable as there's no "server side" here + # (and now many uses would trigger warnings on DESTROY) + # $this->STORE(Active => 1); + # so drivers should set it in their own connect + $this; + } + + + sub connect_cached { + my $drh = shift; + my ($dsn, $user, $auth, $attr) = @_; + + my $cache = $drh->{CachedKids} ||= {}; + my $key = do { no warnings; + join "!\001", $dsn, $user, $auth, DBI::_concat_hash_sorted($attr, "=\001", ",\001", 0, 0) + }; + my $dbh = $cache->{$key}; + $drh->trace_msg(sprintf(" connect_cached: key '$key', cached dbh $dbh\n", DBI::neat($key), DBI::neat($dbh))) + if (($DBI::dbi_debug & 0xF) >= 4); + + my $cb = $attr->{Callbacks}; # take care not to autovivify + if ($dbh && $dbh->FETCH('Active') && eval { $dbh->ping }) { + # If the caller has provided a callback then call it + if ($cb and $cb = $cb->{"connect_cached.reused"}) { + local $_ = "connect_cached.reused"; + $cb->($dbh, $dsn, $user, $auth, $attr); + } + return $dbh; + } + + # If the caller has provided a callback then call it + if ($cb and (my $new_cb = $cb->{"connect_cached.new"})) { + local $_ = "connect_cached.new"; + $new_cb->($dbh, $dsn, $user, $auth, $attr); # $dbh is dead or undef + } + + $dbh = $drh->connect(@_); + $cache->{$key} = $dbh; # replace prev entry, even if connect failed + if ($cb and (my $conn_cb = $cb->{"connect_cached.connected"})) { + local $_ = "connect_cached.connected"; + $conn_cb->($dbh, $dsn, $user, $auth, $attr); + } + return $dbh; + } + +} + + +{ package # hide from PAUSE + DBD::_::db; # ====== DATABASE ====== + our @ISA = qw(DBD::_::common); + use strict; + + sub clone { + my ($old_dbh, $attr) = @_; + + my $closure = $old_dbh->{dbi_connect_closure} + or return $old_dbh->set_err($DBI::stderr, "Can't clone handle"); + + unless ($attr) { # XXX deprecated, caller should always pass a hash ref + # copy attributes visible in the attribute cache + keys %$old_dbh; # reset iterator + while ( my ($k, $v) = each %$old_dbh ) { + # ignore non-code refs, i.e., caches, handles, Err etc + next if ref $v && ref $v ne 'CODE'; # HandleError etc + $attr->{$k} = $v; + } + # explicitly set attributes which are unlikely to be in the + # attribute cache, i.e., boolean's and some others + $attr->{$_} = $old_dbh->FETCH($_) for (qw( + AutoCommit ChopBlanks InactiveDestroy AutoInactiveDestroy + LongTruncOk PrintError PrintWarn Profile RaiseError RaiseWarn + ShowErrorStatement TaintIn TaintOut + )); + } + + # use Data::Dumper; warn Dumper([$old_dbh, $attr]); + my $new_dbh = &$closure($old_dbh, $attr); + unless ($new_dbh) { + # need to copy err/errstr from driver back into $old_dbh + my $drh = $old_dbh->{Driver}; + return $old_dbh->set_err($drh->err, $drh->errstr, $drh->state); + } + $new_dbh->{dbi_connect_closure} = $closure; + return $new_dbh; + } + + sub quote_identifier { + my ($dbh, @id) = @_; + my $attr = (@id > 3 && ref($id[-1])) ? pop @id : undef; + + my $info = $dbh->{dbi_quote_identifier_cache} ||= [ + $dbh->get_info(29) || '"', # SQL_IDENTIFIER_QUOTE_CHAR + $dbh->get_info(41) || '.', # SQL_CATALOG_NAME_SEPARATOR + $dbh->get_info(114) || 1, # SQL_CATALOG_LOCATION + ]; + + my $quote = $info->[0]; + foreach (@id) { # quote the elements + next unless defined; + s/$quote/$quote$quote/g; # escape embedded quotes + $_ = qq{$quote$_$quote}; + } + + # strip out catalog if present for special handling + my $catalog = (@id >= 3) ? shift @id : undef; + + # join the dots, ignoring any null/undef elements (ie schema) + my $quoted_id = join '.', grep { defined } @id; + + if ($catalog) { # add catalog correctly + if ($quoted_id) { + $quoted_id = ($info->[2] == 2) # SQL_CL_END + ? $quoted_id . $info->[1] . $catalog + : $catalog . $info->[1] . $quoted_id; + } else { + $quoted_id = $catalog; + } + } + return $quoted_id; + } + + sub quote { + my ($dbh, $str, $data_type) = @_; + + return "NULL" unless defined $str; + unless ($data_type) { + $str =~ s/'/''/g; # ISO SQL2 + return "'$str'"; + } + + my $dbi_literal_quote_cache = $dbh->{'dbi_literal_quote_cache'} ||= [ {} , {} ]; + my ($prefixes, $suffixes) = @$dbi_literal_quote_cache; + + my $lp = $prefixes->{$data_type}; + my $ls = $suffixes->{$data_type}; + + if ( ! defined $lp || ! defined $ls ) { + my $ti = $dbh->type_info($data_type); + $lp = $prefixes->{$data_type} = $ti ? $ti->{LITERAL_PREFIX} || "" : "'"; + $ls = $suffixes->{$data_type} = $ti ? $ti->{LITERAL_SUFFIX} || "" : "'"; + } + return $str unless $lp || $ls; # no quoting required + + # XXX don't know what the standard says about escaping + # in the 'general case' (where $lp != "'"). + # So we just do this and hope: + $str =~ s/$lp/$lp$lp/g + if $lp && $lp eq $ls && ($lp eq "'" || $lp eq '"'); + return "$lp$str$ls"; + } + + sub rows { -1 } # here so $DBI::rows 'works' after using $dbh + + sub do { + my($dbh, $statement, $attr, @params) = @_; + my $sth = $dbh->prepare($statement, $attr) or return undef; + $sth->execute(@params) or return undef; + my $rows = $sth->rows; + ($rows == 0) ? "0E0" : $rows; + } + + sub _do_selectrow { + my ($method, $dbh, $stmt, $attr, @bind) = @_; + my $sth = ((ref $stmt) ? $stmt : $dbh->prepare($stmt, $attr)) + or return undef; + $sth->execute(@bind) + or return undef; + my $row = $sth->$method() + and $sth->finish; + return $row; + } + + sub selectrow_hashref { return _do_selectrow('fetchrow_hashref', @_); } + + # XXX selectrow_array/ref also have C implementations in Driver.xst + sub selectrow_arrayref { return _do_selectrow('fetchrow_arrayref', @_); } + sub selectrow_array { + my $row = _do_selectrow('fetchrow_arrayref', @_) or return; + return $row->[0] unless wantarray; + return @$row; + } + + sub selectall_array { + return @{ shift->selectall_arrayref(@_) || [] }; + } + + # XXX selectall_arrayref also has C implementation in Driver.xst + # which fallsback to this if a slice is given + sub selectall_arrayref { + my ($dbh, $stmt, $attr, @bind) = @_; + my $sth = (ref $stmt) ? $stmt : $dbh->prepare($stmt, $attr) + or return; + $sth->execute(@bind) || return; + my $slice = $attr->{Slice}; # typically undef, else hash or array ref + if (!$slice and $slice=$attr->{Columns}) { + if (ref $slice eq 'ARRAY') { # map col idx to perl array idx + $slice = [ @{$attr->{Columns}} ]; # take a copy + for (@$slice) { $_-- } + } + } + my $rows = $sth->fetchall_arrayref($slice, my $MaxRows = $attr->{MaxRows}); + $sth->finish if defined $MaxRows; + return $rows; + } + + sub selectall_hashref { + my ($dbh, $stmt, $key_field, $attr, @bind) = @_; + my $sth = (ref $stmt) ? $stmt : $dbh->prepare($stmt, $attr); + return unless $sth; + $sth->execute(@bind) || return; + return $sth->fetchall_hashref($key_field); + } + + sub selectcol_arrayref { + my ($dbh, $stmt, $attr, @bind) = @_; + my $sth = (ref $stmt) ? $stmt : $dbh->prepare($stmt, $attr); + return unless $sth; + $sth->execute(@bind) || return; + my @columns = ($attr->{Columns}) ? @{$attr->{Columns}} : (1); + my @values = (undef) x @columns; + my $idx = 0; + for (@columns) { + $sth->bind_col($_, \$values[$idx++]) || return; + } + my @col; + if (my $max = $attr->{MaxRows}) { + push @col, @values while 0 < $max-- && $sth->fetch; + } + else { + push @col, @values while $sth->fetch; + } + return \@col; + } + + sub prepare_cached { + my ($dbh, $statement, $attr, $if_active) = @_; + + # Needs support at dbh level to clear cache before complaining about + # active children. The XS template code does this. Drivers not using + # the template must handle clearing the cache themselves. + my $cache = $dbh->{CachedKids} ||= {}; + my $key = do { no warnings; + join "!\001", $statement, DBI::_concat_hash_sorted($attr, "=\001", ",\001", 0, 0) + }; + my $sth = $cache->{$key}; + + if ($sth) { + return $sth unless $sth->FETCH('Active'); + Carp::carp("prepare_cached($statement) statement handle $sth still Active") + unless ($if_active ||= 0); + $sth->finish if $if_active <= 1; + return $sth if $if_active <= 2; + } + + $sth = $dbh->prepare($statement, $attr); + $cache->{$key} = $sth if $sth; + + return $sth; + } + + sub ping { + my $dbh = shift; + # "0 but true" is a special kind of true 0 that is used here so + # applications can check if the ping was a real ping or not + ($dbh->FETCH('Active')) ? "0 but true" : 0; + } + + sub begin_work { + my $dbh = shift; + return $dbh->set_err($DBI::stderr, "Already in a transaction") + unless $dbh->FETCH('AutoCommit'); + $dbh->STORE('AutoCommit', 0); # will croak if driver doesn't support it + $dbh->STORE('BegunWork', 1); # trigger post commit/rollback action + return 1; + } + + sub primary_key { + my ($dbh, @args) = @_; + my $sth = $dbh->primary_key_info(@args) or return; + my ($row, @col); + push @col, $row->[3] while ($row = $sth->fetch); + Carp::croak("primary_key method not called in list context") + unless wantarray; # leave us some elbow room + return @col; + } + + sub tables { + my ($dbh, @args) = @_; + my $sth = $dbh->table_info(@args[0,1,2,3,4]) or return; + my $tables = $sth->fetchall_arrayref or return; + my @tables; + if (defined($args[3]) && $args[3] eq '%' # special case for tables('','','','%') + && grep {defined($_) && $_ eq ''} @args[0,1,2] + ) { + @tables = map { $_->[3] } @$tables; + } elsif ($dbh->get_info(29)) { # SQL_IDENTIFIER_QUOTE_CHAR + @tables = map { $dbh->quote_identifier( @{$_}[0,1,2] ) } @$tables; + } + else { # temporary old style hack (yeach) + @tables = map { + my $name = $_->[2]; + if ($_->[1]) { + my $schema = $_->[1]; + # a sad hack (mostly for Informix I recall) + my $quote = ($schema eq uc($schema)) ? '' : '"'; + $name = "$quote$schema$quote.$name" + } + $name; + } @$tables; + } + return @tables; + } + + sub type_info { # this should be sufficient for all drivers + my ($dbh, $data_type) = @_; + my $idx_hash; + my $tia = $dbh->{dbi_type_info_row_cache}; + if ($tia) { + $idx_hash = $dbh->{dbi_type_info_idx_cache}; + } + else { + my $temp = $dbh->type_info_all; + return unless $temp && @$temp; + # we cache here because type_info_all may be expensive to call + # (and we take a copy so the following shift can't corrupt + # the data that may be returned by future calls to type_info_all) + $tia = $dbh->{dbi_type_info_row_cache} = [ @$temp ]; + $idx_hash = $dbh->{dbi_type_info_idx_cache} = shift @$tia; + } + + my $dt_idx = $idx_hash->{DATA_TYPE} || $idx_hash->{data_type}; + Carp::croak("type_info_all returned non-standard DATA_TYPE index value ($dt_idx != 1)") + if $dt_idx && $dt_idx != 1; + + # --- simple DATA_TYPE match filter + my @ti; + my @data_type_list = (ref $data_type) ? @$data_type : ($data_type); + foreach $data_type (@data_type_list) { + if (defined($data_type) && $data_type != DBI::SQL_ALL_TYPES()) { + push @ti, grep { $_->[$dt_idx] == $data_type } @$tia; + } + else { # SQL_ALL_TYPES + push @ti, @$tia; + } + last if @ti; # found at least one match + } + + # --- format results into list of hash refs + my $idx_fields = keys %$idx_hash; + my @idx_names = map { uc($_) } keys %$idx_hash; + my @idx_values = values %$idx_hash; + Carp::croak "type_info_all result has $idx_fields keys but ".(@{$ti[0]})." fields" + if @ti && @{$ti[0]} != $idx_fields; + my @out = map { + my %h; @h{@idx_names} = @{$_}[ @idx_values ]; \%h; + } @ti; + return $out[0] unless wantarray; + return @out; + } + + sub data_sources { + my ($dbh, @other) = @_; + my $drh = $dbh->{Driver}; # XXX proxy issues? + return $drh->data_sources(@other); + } + +} + + +{ package # hide from PAUSE + DBD::_::st; # ====== STATEMENT ====== + our @ISA = qw(DBD::_::common); + use strict; + + sub bind_param { Carp::croak("Can't bind_param, not implement by driver") } + +# +# ******************************************************** +# +# BEGIN ARRAY BINDING +# +# Array binding support for drivers which don't support +# array binding, but have sufficient interfaces to fake it. +# NOTE: mixing scalars and arrayrefs requires using bind_param_array +# for *all* params...unless we modify bind_param for the default +# case... +# +# 2002-Apr-10 D. Arnold + + sub bind_param_array { + my $sth = shift; + my ($p_id, $value_array, $attr) = @_; + + return $sth->set_err($DBI::stderr, "Value for parameter $p_id must be a scalar or an arrayref, not a ".ref($value_array)) + if defined $value_array and ref $value_array and ref $value_array ne 'ARRAY'; + + return $sth->set_err($DBI::stderr, "Can't use named placeholder '$p_id' for non-driver supported bind_param_array") + unless DBI::looks_like_number($p_id); # because we rely on execute(@ary) here + + return $sth->set_err($DBI::stderr, "Placeholder '$p_id' is out of range") + if $p_id <= 0; # can't easily/reliably test for too big + + # get/create arrayref to hold params + my $hash_of_arrays = $sth->{ParamArrays} ||= { }; + + # If the bind has attribs then we rely on the driver conforming to + # the DBI spec in that a single bind_param() call with those attribs + # makes them 'sticky' and apply to all later execute(@values) calls. + # Since we only call bind_param() if we're given attribs then + # applications using drivers that don't support bind_param can still + # use bind_param_array() so long as they don't pass any attribs. + + $$hash_of_arrays{$p_id} = $value_array; + return $sth->bind_param($p_id, undef, $attr) + if $attr; + 1; + } + + sub bind_param_inout_array { + my $sth = shift; + # XXX not supported so we just call bind_param_array instead + # and then return an error + my ($p_num, $value_array, $attr) = @_; + $sth->bind_param_array($p_num, $value_array, $attr); + return $sth->set_err($DBI::stderr, "bind_param_inout_array not supported"); + } + + sub bind_columns { + my $sth = shift; + my $fields = $sth->FETCH('NUM_OF_FIELDS') || 0; + if ($fields <= 0 && !$sth->{Active}) { + return $sth->set_err($DBI::stderr, "Statement has no result columns to bind" + ." (perhaps you need to successfully call execute first, or again)"); + } + # Backwards compatibility for old-style call with attribute hash + # ref as first arg. Skip arg if undef or a hash ref. + my $attr; + $attr = shift if !defined $_[0] or ref($_[0]) eq 'HASH'; + + my $idx = 0; + $sth->bind_col(++$idx, shift, $attr) or return + while (@_ and $idx < $fields); + + return $sth->set_err($DBI::stderr, "bind_columns called with ".($idx+@_)." values but $fields are needed") + if @_ or $idx != $fields; + + return 1; + } + + sub execute_array { + my $sth = shift; + my ($attr, @array_of_arrays) = @_; + my $NUM_OF_PARAMS = $sth->FETCH('NUM_OF_PARAMS'); # may be undef at this point + + # get tuple status array or hash attribute + my $tuple_sts = $attr->{ArrayTupleStatus}; + return $sth->set_err($DBI::stderr, "ArrayTupleStatus attribute must be an arrayref") + if $tuple_sts and ref $tuple_sts ne 'ARRAY'; + + # bind all supplied arrays + if (@array_of_arrays) { + $sth->{ParamArrays} = { }; # clear out old params + return $sth->set_err($DBI::stderr, + @array_of_arrays." bind values supplied but $NUM_OF_PARAMS expected") + if defined ($NUM_OF_PARAMS) && @array_of_arrays != $NUM_OF_PARAMS; + $sth->bind_param_array($_, $array_of_arrays[$_-1]) or return + foreach (1..@array_of_arrays); + } + + my $fetch_tuple_sub; + + if ($fetch_tuple_sub = $attr->{ArrayTupleFetch}) { # fetch on demand + + return $sth->set_err($DBI::stderr, + "Can't use both ArrayTupleFetch and explicit bind values") + if @array_of_arrays; # previous bind_param_array calls will simply be ignored + + if (UNIVERSAL::isa($fetch_tuple_sub,'DBI::st')) { + my $fetch_sth = $fetch_tuple_sub; + return $sth->set_err($DBI::stderr, + "ArrayTupleFetch sth is not Active, need to execute() it first") + unless $fetch_sth->{Active}; + # check column count match to give more friendly message + my $NUM_OF_FIELDS = $fetch_sth->{NUM_OF_FIELDS}; + return $sth->set_err($DBI::stderr, + "$NUM_OF_FIELDS columns from ArrayTupleFetch sth but $NUM_OF_PARAMS expected") + if defined($NUM_OF_FIELDS) && defined($NUM_OF_PARAMS) + && $NUM_OF_FIELDS != $NUM_OF_PARAMS; + $fetch_tuple_sub = sub { $fetch_sth->fetchrow_arrayref }; + } + elsif (!UNIVERSAL::isa($fetch_tuple_sub,'CODE')) { + return $sth->set_err($DBI::stderr, "ArrayTupleFetch '$fetch_tuple_sub' is not a code ref or statement handle"); + } + + } + else { + my $NUM_OF_PARAMS_given = keys %{ $sth->{ParamArrays} || {} }; + return $sth->set_err($DBI::stderr, + "$NUM_OF_PARAMS_given bind values supplied but $NUM_OF_PARAMS expected") + if defined($NUM_OF_PARAMS) && $NUM_OF_PARAMS != $NUM_OF_PARAMS_given; + + # get the length of a bound array + my $maxlen; + my %hash_of_arrays = %{$sth->{ParamArrays}}; + foreach (keys(%hash_of_arrays)) { + my $ary = $hash_of_arrays{$_}; + next unless ref $ary eq 'ARRAY'; + $maxlen = @$ary if !$maxlen || @$ary > $maxlen; + } + # if there are no arrays then execute scalars once + $maxlen = 1 unless defined $maxlen; + my @bind_ids = 1..keys(%hash_of_arrays); + + my $tuple_idx = 0; + $fetch_tuple_sub = sub { + return if $tuple_idx >= $maxlen; + my @tuple = map { + my $a = $hash_of_arrays{$_}; + ref($a) ? $a->[$tuple_idx] : $a + } @bind_ids; + ++$tuple_idx; + return \@tuple; + }; + } + # pass thru the callers scalar or list context + return $sth->execute_for_fetch($fetch_tuple_sub, $tuple_sts); + } + + sub execute_for_fetch { + my ($sth, $fetch_tuple_sub, $tuple_status) = @_; + # start with empty status array + ($tuple_status) ? @$tuple_status = () : $tuple_status = []; + + my $rc_total = 0; + my $err_count; + while ( my $tuple = &$fetch_tuple_sub() ) { + if ( my $rc = $sth->execute(@$tuple) ) { + push @$tuple_status, $rc; + $rc_total = ($rc >= 0 && $rc_total >= 0) ? $rc_total + $rc : -1; + } + else { + $err_count++; + push @$tuple_status, [ $sth->err, $sth->errstr, $sth->state ]; + # XXX drivers implementing execute_for_fetch could opt to "last;" here + # if they know the error code means no further executes will work. + } + } + my $tuples = @$tuple_status; + return $sth->set_err($DBI::stderr, "executing $tuples generated $err_count errors") + if $err_count; + $tuples ||= "0E0"; + return $tuples unless wantarray; + return ($tuples, $rc_total); + } + + sub last_insert_id { + return shift->{Database}->last_insert_id(@_); + } + + sub fetchall_arrayref { # ALSO IN Driver.xst + my ($sth, $slice, $max_rows) = @_; + + # when batch fetching with $max_rows were very likely to try to + # fetch the 'next batch' after the previous batch returned + # <=$max_rows. So don't treat that as an error. + return undef if $max_rows and not $sth->FETCH('Active'); + + my $mode = ref($slice) || 'ARRAY'; + my @rows; + + if ($mode eq 'ARRAY') { + my $row; + # we copy the array here because fetch (currently) always + # returns the same array ref. XXX + if ($slice && @$slice) { + $max_rows = -1 unless defined $max_rows; + push @rows, [ @{$row}[ @$slice] ] + while($max_rows-- and $row = $sth->fetch); + } + elsif (defined $max_rows) { + push @rows, [ @$row ] + while($max_rows-- and $row = $sth->fetch); + } + else { + push @rows, [ @$row ] while($row = $sth->fetch); + } + return \@rows + } + + my %row; + if ($mode eq 'REF' && ref($$slice) eq 'HASH') { # \{ $idx => $name } + keys %$$slice; # reset the iterator + while ( my ($idx, $name) = each %$$slice ) { + $sth->bind_col($idx+1, \$row{$name}); + } + } + elsif ($mode eq 'HASH') { + if (keys %$slice) { # resets the iterator + my $name2idx = $sth->FETCH('NAME_lc_hash'); + while ( my ($name, $unused) = each %$slice ) { + my $idx = $name2idx->{lc $name}; + return $sth->set_err($DBI::stderr, "Invalid column name '$name' for slice") + if not defined $idx; + $sth->bind_col($idx+1, \$row{$name}); + } + } + else { + my @column_names = @{ $sth->FETCH($sth->FETCH('FetchHashKeyName')) || [] }; + return [] if !@column_names; + + $sth->bind_columns( \( @row{@column_names} ) ); + } + } + else { + return $sth->set_err($DBI::stderr, "fetchall_arrayref($mode) invalid"); + } + + if (not defined $max_rows) { + push @rows, { %row } while ($sth->fetch); # full speed ahead! + } + else { + push @rows, { %row } while ($max_rows-- and $sth->fetch); + } + + return \@rows; + } + + sub fetchall_hashref { + my ($sth, $key_field) = @_; + + my $hash_key_name = $sth->{FetchHashKeyName} || 'NAME'; + my $names_hash = $sth->FETCH("${hash_key_name}_hash"); + my @key_fields = (ref $key_field) ? @$key_field : ($key_field); + my @key_indexes; + my $num_of_fields = $sth->FETCH('NUM_OF_FIELDS'); + foreach (@key_fields) { + my $index = $names_hash->{$_}; # perl index not column + $index = $_ - 1 if !defined $index && DBI::looks_like_number($_) && $_>=1 && $_ <= $num_of_fields; + return $sth->set_err($DBI::stderr, "Field '$_' does not exist (not one of @{[keys %$names_hash]})") + unless defined $index; + push @key_indexes, $index; + } + my $rows = {}; + my $NAME = $sth->FETCH($hash_key_name); + my @row = (undef) x $num_of_fields; + $sth->bind_columns(\(@row)); + while ($sth->fetch) { + my $ref = $rows; + $ref = $ref->{$row[$_]} ||= {} for @key_indexes; + @{$ref}{@$NAME} = @row; + } + return $rows; + } + + *dump_results = \&DBI::dump_results; + + sub blob_copy_to_file { # returns length or undef on error + my($self, $field, $filename_or_handleref, $blocksize) = @_; + my $fh = $filename_or_handleref; + my($len, $buf) = (0, ""); + $blocksize ||= 512; # not too ambitious + local(*FH); + unless(ref $fh) { + open(FH, ">$fh") || return undef; + $fh = \*FH; + } + while(defined($self->blob_read($field, $len, $blocksize, \$buf))) { + print $fh $buf; + $len += length $buf; + } + close(FH); + $len; + } + + sub more_results { + shift->{syb_more_results}; # handy grandfathering + } + +} + +unless ($DBI::PurePerl) { # See install_driver + { @DBD::_mem::dr::ISA = qw(DBD::_mem::common); } + { @DBD::_mem::db::ISA = qw(DBD::_mem::common); } + { @DBD::_mem::st::ISA = qw(DBD::_mem::common); } + # DBD::_mem::common::DESTROY is implemented in DBI.xs +} + +1; +__END__ + +=head1 DESCRIPTION + +The DBI is a database access module for the Perl programming language. It defines +a set of methods, variables, and conventions that provide a consistent +database interface, independent of the actual database being used. + +It is important to remember that the DBI is just an interface. +The DBI is a layer +of "glue" between an application and one or more database I +modules. It is the driver modules which do most of the real work. The DBI +provides a standard interface and framework for the drivers to operate +within. + +This document often uses terms like I, I, +I. If you're not familiar with those terms then it would +be a good idea to read at least the following perl manuals first: +L, L, L, and L. + + +=head2 Architecture of a DBI Application + + |<- Scope of DBI ->| + .-. .--------------. .-------------. + .-------. | |---| XYZ Driver |---| XYZ Engine | + | Perl | | | `--------------' `-------------' + | script| |A| |D| .--------------. .-------------. + | using |--|P|--|B|---|Oracle Driver |---|Oracle Engine| + | DBI | |I| |I| `--------------' `-------------' + | API | | |... + |methods| | |... Other drivers + `-------' | |... + `-' + +The API, or Application Programming Interface, defines the +call interface and variables for Perl scripts to use. The API +is implemented by the Perl DBI extension. + +The DBI "dispatches" the method calls to the appropriate driver for +actual execution. The DBI is also responsible for the dynamic loading +of drivers, error checking and handling, providing default +implementations for methods, and many other non-database specific duties. + +Each driver +contains implementations of the DBI methods using the +private interface functions of the corresponding database engine. Only authors +of sophisticated/multi-database applications or generic library +functions need be concerned with drivers. + +=head2 Notation and Conventions + +The following conventions are used in this document: + + $dbh Database handle object + $sth Statement handle object + $drh Driver handle object (rarely seen or used in applications) + $h Any of the handle types above ($dbh, $sth, or $drh) + $rc General Return Code (boolean: true=ok, false=error) + $rv General Return Value (typically an integer) + @ary List of values returned from the database, typically a row of data + $rows Number of rows processed (if available, else -1) + $fh A filehandle + undef NULL values are represented by undefined values in Perl + \%attr Reference to a hash of attribute values passed to methods + +Note that Perl will automatically destroy database and statement handle objects +if all references to them are deleted. + + +=head2 Outline Usage + +To use DBI, +first you need to load the DBI module: + + use DBI; + use strict; + +(The C isn't required but is strongly recommended.) + +Then you need to L to your data source and get a I for that +connection: + + $dbh = DBI->connect($dsn, $user, $password, + { RaiseError => 1, AutoCommit => 0 }); + +Since connecting can be expensive, you generally just connect at the +start of your program and disconnect at the end. + +Explicitly defining the required C behaviour is strongly +recommended and may become mandatory in a later version. This +determines whether changes are automatically committed to the +database when executed, or need to be explicitly committed later. + +The DBI allows an application to "prepare" statements for later +execution. A prepared statement is identified by a statement handle +held in a Perl variable. +We'll call the Perl variable C<$sth> in our examples. + +The typical method call sequence for a C statement is: + + prepare, + execute, + execute, + execute. + +for example: + + $sth = $dbh->prepare("INSERT INTO table(foo,bar,baz) VALUES (?,?,?)"); + + while() { + chomp; + my ($foo,$bar,$baz) = split /,/; + $sth->execute( $foo, $bar, $baz ); + } + +The C method is a wrapper of prepare and execute that can be simpler +for non repeated I-C statement. + +=head1 THE DBI PACKAGE AND CLASS + +In this section, we cover the DBI class methods, utility functions, +and the dynamic attributes associated with generic DBI handles. + +=head2 DBI Constants + +Constants representing the values of the SQL standard types can be +imported individually by name, or all together by importing the +special C<:sql_types> tag. + +The names and values of all the defined SQL standard types can be +produced like this: + + foreach (@{ $DBI::EXPORT_TAGS{sql_types} }) { + printf "%s=%d\n", $_, &{"DBI::$_"}; + } + +These constants are defined by SQL/CLI, ODBC or both. +C has conflicting codes in SQL/CLI and ODBC, +DBI uses the ODBC one. + +See the L, L, and L methods +for possible uses. + +Note that just because the DBI defines a named constant for a given +data type doesn't mean that drivers will support that data type. + + +=head2 DBI Class Methods + +The following methods are provided by the DBI class: + +=head3 C + + ($scheme, $driver, $attr_string, $attr_hash, $driver_dsn) = DBI->parse_dsn($dsn) + or die "Can't parse DBI DSN '$dsn'"; + +Breaks apart a DBI Data Source Name (DSN) and returns the individual +parts. If $dsn doesn't contain a valid DSN then parse_dsn() returns +an empty list. + +$scheme is the first part of the DSN and is currently always 'dbi'. +$driver is the driver name, possibly defaulted to $ENV{DBI_DRIVER}, +and may be undefined. $attr_string is the contents of the optional attribute +string, which may be undefined. If $attr_string is not empty then $attr_hash +is a reference to a hash containing the parsed attribute names and values. +$driver_dsn is the last part of the DBI DSN string. For example: + + ($scheme, $driver, $attr_string, $attr_hash, $driver_dsn) + = DBI->parse_dsn("dbi:MyDriver(RaiseError=>1):db=test;port=42"); + $scheme = 'dbi'; + $driver = 'MyDriver'; + $attr_string = 'RaiseError=>1'; + $attr_hash = { 'RaiseError' => '1' }; + $driver_dsn = 'db=test;port=42'; + +The parse_dsn() method was added in DBI 1.43. + +=head3 C + + $dbh = DBI->connect($data_source, $username, $password) + or die $DBI::errstr; + $dbh = DBI->connect($data_source, $username, $password, \%attr) + or die $DBI::errstr; + +Establishes a database connection, or session, to the requested C<$data_source>. +Returns a database handle object if the connection succeeds. Use +C<$dbh-Edisconnect> to terminate the connection. + +If the connect fails (see below), it returns C and sets both C<$DBI::err> +and C<$DBI::errstr>. (It does I explicitly set C<$!>.) You should generally +test the return status of C and C if it has failed. + +Multiple simultaneous connections to multiple databases through multiple +drivers can be made via the DBI. Simply make one C call for each +database and keep a copy of each returned database handle. + +The C<$data_source> value must begin with "CIC<:>". +The I specifies the driver that will be used to make the +connection. (Letter case is significant.) + +As a convenience, if the C<$data_source> parameter is undefined or empty, +the DBI will substitute the value of the environment variable C. +If just the I part is empty (i.e., the C<$data_source> +prefix is "C"), the environment variable C is +used. If neither variable is set, then C dies. + +Examples of C<$data_source> values are: + + dbi:DriverName:database_name + dbi:DriverName:database_name@hostname:port + dbi:DriverName:database=database_name;host=hostname;port=port + +There is I for the text following the driver name. Each +driver is free to use whatever syntax it wants. The only requirement the +DBI makes is that all the information is supplied in a single string. +You must consult the documentation for the drivers you are using for a +description of the syntax they require. + +It is recommended that drivers support the ODBC style, shown in the +last example above. It is also recommended that they support the +three common names 'C', 'C', and 'C' (plus 'C' +as an alias for C). This simplifies automatic construction +of basic DSNs: C<"dbi:$driver:database=$db;host=$host;port=$port">. +Drivers should aim to 'do something reasonable' when given a DSN +in this form, but if any part is meaningless for that driver (such +as 'port' for Informix) it should generate an error if that part +is not empty. + +If the environment variable C is defined (and the +driver in C<$data_source> is not "C") then the connect request +will automatically be changed to: + + $ENV{DBI_AUTOPROXY};dsn=$data_source + +C is typically set as "C". +If $ENV{DBI_AUTOPROXY} doesn't begin with 'C' then "dbi:Proxy:" +will be prepended to it first. See the DBD::Proxy documentation +for more details. + +If C<$username> or C<$password> are undefined (rather than just empty), +then the DBI will substitute the values of the C and C +environment variables, respectively. The DBI will warn if the +environment variables are not defined. However, the everyday use +of these environment variables is not recommended for security +reasons. The mechanism is primarily intended to simplify testing. +See below for alternative way to specify the username and password. + +Cconnect> automatically installs the driver if it has not been +installed yet. Driver installation either returns a valid driver +handle, or it I with an error message that includes the string +"C" and the underlying problem. So Cconnect> +will die +on a driver installation failure and will only return C on a +connect failure, in which case C<$DBI::errstr> will hold the error message. +Use C if you need to catch the "C" error. + +The C<$data_source> argument (with the "C" prefix removed) and the +C<$username> and C<$password> arguments are then passed to the driver for +processing. The DBI does not define any interpretation for the +contents of these fields. The driver is free to interpret the +C<$data_source>, C<$username>, and C<$password> fields in any way, and supply +whatever defaults are appropriate for the engine being accessed. +(Oracle, for example, uses the ORACLE_SID and TWO_TASK environment +variables if no C<$data_source> is specified.) + +The C and C attributes for each connection +default to "on". (See L and L for more information.) +However, it is strongly recommended that you explicitly define C +rather than rely on the default. The C attribute defaults to true. +The C attribute defaults to false. + +The C<\%attr> parameter can be used to alter the default settings of +C, C, C, and other attributes. For example: + + $dbh = DBI->connect($data_source, $user, $pass, { + PrintError => 0, + AutoCommit => 0 + }); + +The username and password can also be specified using the attributes +C and C, in which case they take precedence +over the C<$username> and C<$password> parameters. + +You can also define connection attribute values within the C<$data_source> +parameter. For example: + + dbi:DriverName(PrintWarn=>0,PrintError=>0,Taint=>1):... + +Individual attributes values specified in this way take precedence over +any conflicting values specified via the C<\%attr> parameter to C. + +The C attribute can be used to specify which driver +method should be called to establish the connection. The only useful +values are 'connect', 'connect_cached', or some specialized case like +'Apache::DBI::connect' (which is automatically the default when running +within Apache). + +Where possible, each session (C<$dbh>) is independent from the transactions +in other sessions. This is useful when you need to hold cursors open +across transactions--for example, if you use one session for your long lifespan +cursors (typically read-only) and another for your short update +transactions. + +For compatibility with old DBI scripts, the driver can be specified by +passing its name as the fourth argument to C (instead of C<\%attr>): + + $dbh = DBI->connect($data_source, $user, $pass, $driver); + +In this "old-style" form of C, the C<$data_source> should not start +with "C". (If it does, the embedded driver_name +will be ignored). Also note that in this older form of C, +the C<$dbh-E{AutoCommit}> attribute is I, the +C<$dbh-E{PrintError}> attribute is off, and the old C +environment variable is +checked if C is not defined. Beware that this "old-style" +C will soon be withdrawn in a future version of DBI. + +=head3 C + + $dbh = DBI->connect_cached($data_source, $username, $password) + or die $DBI::errstr; + $dbh = DBI->connect_cached($data_source, $username, $password, \%attr) + or die $DBI::errstr; + +C is like L, except that the database handle +returned is also +stored in a hash associated with the given parameters. If another call +is made to C with the same parameter values, then the +corresponding cached C<$dbh> will be returned if it is still valid. +The cached database handle is replaced with a new connection if it +has been disconnected or if the C method fails. + +Note that the behaviour of this method differs in several respects from the +behaviour of persistent connections implemented by Apache::DBI. +However, if Apache::DBI is loaded then C will use it. + +Caching connections can be useful in some applications, but it can +also cause problems, such as too many connections, and so should +be used with care. In particular, avoid changing the attributes of +a database handle created via connect_cached() because it will affect +other code that may be using the same handle. When connect_cached() +returns a handle the attributes will be reset to their initial values. +This can cause problems, especially with the C attribute. + +Also, to ensure that the attributes passed are always the same, avoid passing +references inline. For example, the C attribute is specified as a +hash reference. Be sure to declare it external to the call to +connect_cached(), such that the hash reference is not re-created on every +call. A package-level lexical works well: + + package MyDBH; + my $cb = { + 'connect_cached.reused' => sub { delete $_[4]->{AutoCommit} }, + }; + + sub dbh { + DBI->connect_cached( $dsn, $username, $auth, { Callbacks => $cb }); + } + +Where multiple separate parts of a program are using connect_cached() +to connect to the same database with the same (initial) attributes +it is a good idea to add a private attribute to the connect_cached() +call to effectively limit the scope of the caching. For example: + + DBI->connect_cached(..., { private_foo_cachekey => "Bar", ... }); + +Handles returned from that connect_cached() call will only be returned +by other connect_cached() call elsewhere in the code if those other +calls also pass in the same attribute values, including the private one. +(I've used C here as an example, you can use +any attribute name with a C prefix.) + +Taking that one step further, you can limit a particular connect_cached() +call to return handles unique to that one place in the code by setting the +private attribute to a unique value for that place: + + DBI->connect_cached(..., { private_foo_cachekey => __FILE__.__LINE__, ... }); + +By using a private attribute you still get connection caching for +the individual calls to connect_cached() but, by making separate +database connections for separate parts of the code, the database +handles are isolated from any attribute changes made to other handles. + +The cache can be accessed (and cleared) via the L attribute: + + my $CachedKids_hashref = $dbh->{Driver}->{CachedKids}; + %$CachedKids_hashref = () if $CachedKids_hashref; + + +=head3 C + + @ary = DBI->available_drivers; + @ary = DBI->available_drivers($quiet); + +Returns a list of all available drivers by searching for C modules +through the directories in C<@INC>. By default, a warning is given if +some drivers are hidden by others of the same name in earlier +directories. Passing a true value for C<$quiet> will inhibit the warning. + +=head3 C + + %drivers = DBI->installed_drivers(); + +Returns a list of driver name and driver handle pairs for all drivers +'installed' (loaded) into the current process. The driver name does not +include the 'DBD::' prefix. + +To get a list of all drivers available in your perl installation you can use +L. + +Added in DBI 1.49. + +=head3 C + + DBI->installed_versions; + @ary = DBI->installed_versions; + $hash = DBI->installed_versions; + +Calls available_drivers() and attempts to load each of them in turn +using install_driver(). For each load that succeeds the driver +name and version number are added to a hash. When running under +L drivers which appear not be pure-perl are ignored. + +When called in array context the list of successfully loaded drivers +is returned (without the 'DBD::' prefix). + +When called in scalar context an extra entry for the C is added (and +C if appropriate) and a reference to the hash is returned. + +When called in a void context the installed_versions() method will +print out a formatted list of the hash contents, one per line, along with some +other information about the DBI version and OS. + +Due to the potentially high memory cost and unknown risks of loading +in an unknown number of drivers that just happen to be installed +on the system, this method is not recommended for general use. +Use available_drivers() instead. + +The installed_versions() method is primarily intended as a quick +way to see from the command line what's installed. For example: + + perl -MDBI -e 'DBI->installed_versions' + +The installed_versions() method was added in DBI 1.38. + +=head3 C + + @ary = DBI->data_sources($driver); + @ary = DBI->data_sources($driver, \%attr); + +Returns a list of data sources (databases) available via the named +driver. If C<$driver> is empty or C, then the value of the +C environment variable is used. + +The driver will be loaded if it hasn't been already. Note that if the +driver loading fails then data_sources() I with an error message +that includes the string "C" and the underlying problem. + +Data sources are returned in a form suitable for passing to the +L method (that is, they will include the "C" prefix). + +Note that many drivers have no way of knowing what data sources might +be available for it. These drivers return an empty or incomplete list +or may require driver-specific attributes. + +There is also a data_sources() method defined for database handles. + + +=head3 C + + DBI->trace($trace_setting) + DBI->trace($trace_setting, $trace_filename) + DBI->trace($trace_setting, $trace_filehandle) + $trace_setting = DBI->trace; + +The Ctrace> method sets the I trace +settings and returns the I trace settings. It can also +be used to change where the trace output is sent. + +There's a similar method, C<$h-Etrace>, which sets the trace +settings for the specific handle it's called on. + +See the L section for full details about the DBI's powerful +tracing facilities. + + +=head3 C + + DBI->visit_handles( $coderef ); + DBI->visit_handles( $coderef, $info ); + +Where $coderef is a reference to a subroutine and $info is an arbitrary value +which, if undefined, defaults to a reference to an empty hash. Returns $info. + +For each installed driver handle, if any, $coderef is invoked as: + + $coderef->($driver_handle, $info); + +If the execution of $coderef returns a true value then L +is called on that child handle and passed the returned value as $info. + +For example: + + my $info = $dbh->{Driver}->visit_child_handles(sub { + my ($h, $info) = @_; + ++$info->{ $h->{Type} }; # count types of handles (dr/db/st) + return $info; # visit kids + }); + +See also L. + +=head2 DBI Utility Functions + +In addition to the DBI methods listed in the previous section, +the DBI package also provides several utility functions. + +These can be imported into your code by listing them in +the C statement. For example: + + use DBI qw(neat data_diff); + +Alternatively, all these utility functions (except hash) can be +imported using the C<:utils> import tag. For example: + + use DBI qw(:utils); + +=head3 C + + $description = data_string_desc($string); + +Returns an informal description of the string. For example: + + UTF8 off, ASCII, 42 characters 42 bytes + UTF8 off, non-ASCII, 42 characters 42 bytes + UTF8 on, non-ASCII, 4 characters 6 bytes + UTF8 on but INVALID encoding, non-ASCII, 4 characters 6 bytes + UTF8 off, undef + +The initial C on/off refers to Perl's internal SvUTF8 flag. +If $string has the SvUTF8 flag set but the sequence of bytes it +contains are not a valid UTF-8 encoding then data_string_desc() +will report C. + +The C vs C portion shows C if I the +characters in the string are ASCII (have code points <= 127). + +The data_string_desc() function was added in DBI 1.46. + +=head3 C + + $diff = data_string_diff($a, $b); + +Returns an informal description of the first character difference +between the strings. If both $a and $b contain the same sequence +of characters then data_string_diff() returns an empty string. +For example: + + Params a & b Result + ------------ ------ + 'aaa', 'aaa' '' + 'aaa', 'abc' 'Strings differ at index 2: a[2]=a, b[2]=b' + 'aaa', undef 'String b is undef, string a has 3 characters' + 'aaa', 'aa' 'String b truncated after 2 characters' + +Unicode characters are reported in C<\x{XXXX}> format. Unicode +code points in the range U+0800 to U+08FF are unassigned and most +likely to occur due to double-encoding. Characters in this range +are reported as C<\x{08XX}='C'> where C is the corresponding +latin-1 character. + +The data_string_diff() function only considers logical I +and not the underlying encoding. See L for an alternative. + +The data_string_diff() function was added in DBI 1.46. + +=head3 C + + $diff = data_diff($a, $b); + $diff = data_diff($a, $b, $logical); + +Returns an informal description of the difference between two strings. +It calls L and L +and returns the combined results as a multi-line string. + +For example, C will return: + + a: UTF8 off, ASCII, 3 characters 3 bytes + b: UTF8 on, non-ASCII, 3 characters 5 bytes + Strings differ at index 2: a[2]=c, b[2]=\x{263A} + +If $a and $b are identical in both the characters they contain I +their physical encoding then data_diff() returns an empty string. +If $logical is true then physical encoding differences are ignored +(but are still reported if there is a difference in the characters). + +The data_diff() function was added in DBI 1.46. + +=head3 C + + $str = neat($value); + $str = neat($value, $maxlen); + +Return a string containing a neat (and tidy) representation of the +supplied value. + +Strings will be quoted, although internal quotes will I be escaped. +Values known to be numeric will be unquoted. Undefined (NULL) values +will be shown as C (without quotes). + +If the string is flagged internally as utf8 then double quotes will +be used, otherwise single quotes are used and unprintable characters +will be replaced by dot (.). + +For result strings longer than C<$maxlen> the result string will be +truncated to C<$maxlen-4> and "C<...'>" will be appended. If C<$maxlen> is 0 +or C, it defaults to C<$DBI::neat_maxlen> which, in turn, defaults to 400. + +This function is designed to format values for human consumption. +It is used internally by the DBI for L output. It should +typically I be used for formatting values for database use. +(See also L.) + +=head3 C + + $str = neat_list(\@listref, $maxlen, $field_sep); + +Calls C on each element of the list and returns a string +containing the results joined with C<$field_sep>. C<$field_sep> defaults +to C<", ">. + +=head3 C + + @bool = looks_like_number(@array); + +Returns true for each element that looks like a number. +Returns false for each element that does not look like a number. +Returns C for each element that is undefined or empty. + +=head3 C + + $hash_value = DBI::hash($buffer, $type); + +Return a 32-bit integer 'hash' value corresponding to the contents of $buffer. +The $type parameter selects which kind of hash algorithm should be used. + +For the technically curious, type 0 (which is the default if $type +isn't specified) is based on the Perl 5.1 hash except that the value +is forced to be negative (for obscure historical reasons). +Type 1 is the better "Fowler / Noll / Vo" (FNV) hash. See +L for more information. +Both types are implemented in C and are very fast. + +This function doesn't have much to do with databases, except that +it can sometimes be handy to store such values in a database. +It also doesn't have much to do with perl hashes, like %foo. + +=head3 C + + $sts = DBI::sql_type_cast($sv, $sql_type, $flags); + +sql_type_cast attempts to cast C<$sv> to the SQL type (see L) specified in C<$sql_type>. At present only the SQL types +C, C and C are supported. + +For C the effect is similar to using the value in an expression +that requires an integer. It gives the perl scalar an 'integer aspect'. +(Technically the value gains an IV, or possibly a UV or NV if the value is too +large for an IV.) + +For C the effect is similar to using the value in an expression +that requires a general numeric value. It gives the perl scalar a 'numeric +aspect'. (Technically the value gains an NV.) + +C is similar to C or C but more +general and more cautious. It will look at the string first and if it +looks like an integer (that will fit in an IV or UV) it will act like +C, if it looks like a floating point value it will act +like C, if it looks like neither then it will do nothing - +and thereby avoid the warnings that would be generated by +C and C when given non-numeric data. + +C<$flags> may be: + +=over 4 + +=item C + +If this flag is specified then when the driver successfully casts the +bound perl scalar to a non-string type then the string portion of the +scalar will be discarded. + +=item C + +If C<$sv> cannot be cast to the requested C<$sql_type> then by default +it is left untouched and no error is generated. If you specify +C and the cast fails, this will generate an error. + +=back + +The returned C<$sts> value is: + + -2 sql_type is not handled + -1 sv is undef so unchanged + 0 sv could not be cast cleanly and DBIstcf_STRICT was used + 1 sv could not be cast and DBIstcf_STRICT was not used + 2 sv was cast successfully + +This method is exported by the :utils tag and was introduced in DBI +1.611. + +=head2 DBI Dynamic Attributes + +Dynamic attributes are always associated with the I +(that handle is represented by C<$h> in the descriptions below). + +Where an attribute is equivalent to a method call, then refer to +the method call for all related documentation. + +Warning: these attributes are provided as a convenience but they +do have limitations. Specifically, they have a short lifespan: +because they are associated with +the last handle used, they should only be used I after +calling the method that "sets" them. +If in any doubt, use the corresponding method call. + +=head3 C<$DBI::err> + +Equivalent to C<$h-Eerr>. + +=head3 C<$DBI::errstr> + +Equivalent to C<$h-Eerrstr>. + +=head3 C<$DBI::state> + +Equivalent to C<$h-Estate>. + +=head3 C<$DBI::rows> + +Equivalent to C<$h-Erows>. Please refer to the documentation +for the L method. + +=head3 C<$DBI::lasth> + +Returns the DBI object handle used for the most recent DBI method call. +If the last DBI method call was a DESTROY then $DBI::lasth will return +the handle of the parent of the destroyed handle, if there is one. + + +=head1 METHODS COMMON TO ALL HANDLES + +The following methods can be used by all types of DBI handles. + +=head3 C + + $rv = $h->err; + +Returns the I database engine error code from the last driver +method called. The code is typically an integer but you should not +assume that. + +The DBI resets $h->err to undef before almost all DBI method calls, so the +value only has a short lifespan. Also, for most drivers, the statement +handles share the same error variable as the parent database handle, +so calling a method on one handle may reset the error on the +related handles. + +(Methods which don't reset err before being called include err() and errstr(), +obviously, state(), rows(), func(), trace(), trace_msg(), ping(), and the +tied hash attribute FETCH() and STORE() methods.) + +If you need to test for specific error conditions I have your program be +portable to different database engines, then you'll need to determine what the +corresponding error codes are for all those engines and test for all of them. + +The DBI uses the value of $DBI::stderr as the C value for internal errors. +Drivers should also do likewise. The default value for $DBI::stderr is 2000000000. + +A driver may return C<0> from err() to indicate a warning condition +after a method call. Similarly, a driver may return an empty string +to indicate a 'success with information' condition. In both these +cases the value is false but not undef. The errstr() and state() +methods may be used to retrieve extra information in these cases. + +See L for more information. + +=head3 C + + $str = $h->errstr; + +Returns the native database engine error message from the last DBI +method called. This has the same lifespan issues as the L method +described above. + +The returned string may contain multiple messages separated by +newline characters. + +The errstr() method should not be used to test for errors, use err() +for that, because drivers may return 'success with information' or +warning messages via errstr() for methods that have not 'failed'. + +See L for more information. + +=head3 C + + $str = $h->state; + +Returns a state code in the standard SQLSTATE five character format. +Note that the specific success code C<00000> is translated to any empty string +(false). If the driver does not support SQLSTATE (and most don't), +then state() will return C (General Error) for all errors. + +The driver is free to return any value via C, e.g., warning +codes, even if it has not declared an error by returning a true value +via the L method described above. + +The state() method should not be used to test for errors, use err() +for that, because drivers may return a 'success with information' or +warning state code via state() for methods that have not 'failed'. + +=head3 C + + $rv = $h->set_err($err, $errstr); + $rv = $h->set_err($err, $errstr, $state); + $rv = $h->set_err($err, $errstr, $state, $method); + $rv = $h->set_err($err, $errstr, $state, $method, $rv); + +Set the C, C, and C values for the handle. +This method is typically only used by DBI drivers and DBI subclasses. + +If the L attribute holds a reference to a subroutine +it is called first. The subroutine can alter the $err, $errstr, $state, +and $method values. See L for full details. +If the subroutine returns a true value then the handle C, +C, and C values are not altered and set_err() returns +an empty list (it normally returns $rv which defaults to undef, see below). + +Setting C to a I value indicates an error and will trigger +the normal DBI error handling mechanisms, such as C and +C, if they are enabled, when execution returns from +the DBI back to the application. + +Setting C to C<""> indicates an 'information' state, and setting +it to C<"0"> indicates a 'warning' state. Setting C to C +also sets C to undef, and C to C<"">, irrespective +of the values of the $errstr and $state parameters. + +The $method parameter provides an alternate method name for the +C/C/C/C error string instead of +the fairly unhelpful 'C'. + +The C method normally returns undef. The $rv parameter +provides an alternate return value. + +Some special rules apply if the C or C +values for the handle are I set... + +If C is true then: "C< [err was %s now %s]>" is appended if $err is +true and C is already true and the new err value differs from the original +one. Similarly "C< [state was %s now %s]>" is appended if $state is true and C is +already true and the new state value differs from the original one. Finally +"C<\n>" and the new $errstr are appended if $errstr differs from the existing +errstr value. Obviously the C<%s>'s above are replaced by the corresponding values. + +The handle C value is set to $err if: $err is true; or handle +C value is undef; or $err is defined and the length is greater +than the handle C length. The effect is that an 'information' +state only overrides undef; a 'warning' overrides undef or 'information', +and an 'error' state overrides anything. + +The handle C value is set to $state if $state is true and +the handle C value was set (by the rules above). + +Support for warning and information states was added in DBI 1.41. + +=head3 C + + $h->trace($trace_settings); + $h->trace($trace_settings, $trace_filename); + $trace_settings = $h->trace; + +The trace() method is used to alter the trace settings for a handle +(and any future children of that handle). It can also be used to +change where the trace output is sent. + +There's a similar method, Ctrace>, which sets the global +default trace settings. + +See the L section for full details about the DBI's powerful +tracing facilities. + +=head3 C + + $h->trace_msg($message_text); + $h->trace_msg($message_text, $min_level); + +Writes C<$message_text> to the trace file if the trace level is +greater than or equal to $min_level (which defaults to 1). +Can also be called as Ctrace_msg($msg)>. + +See L for more details. + +=head3 C + + $h->func(@func_arguments, $func_name) or die ...; + +The C method can be used to call private non-standard and +non-portable methods implemented by the driver. Note that the function +name is given as the I argument. + +It's also important to note that the func() method does not clear +a previous error ($DBI::err etc.) and it does not trigger automatic +error detection (RaiseError etc.) so you must check the return +status and/or $h->err to detect errors. + +(This method is not directly related to calling stored procedures. +Calling stored procedures is currently not defined by the DBI. +Some drivers, such as DBD::Oracle, support it in non-portable ways. +See driver documentation for more details.) + +See also install_method() in L for how you can avoid needing to +use func() and gain direct access to driver-private methods. + +=head3 C + + $is_implemented = $h->can($method_name); + +Returns true if $method_name is implemented by the driver or a +default method is provided by the DBI's driver base class. +It returns false where a driver hasn't implemented a method and the +default method is provided by the DBI's driver base class is just an empty stub. + +=head3 C + + $trace_settings_integer = $h->parse_trace_flags($trace_settings); + +Parses a string containing trace settings and returns the corresponding +integer value used internally by the DBI and drivers. + +The $trace_settings argument is a string containing a trace level +between 0 and 15 and/or trace flag names separated by vertical bar +("C<|>") or comma ("C<,>") characters. For example: C<"SQL|3|foo">. + +It uses the parse_trace_flag() method, described below, to process +the individual trace flag names. + +The parse_trace_flags() method was added in DBI 1.42. + +=head3 C + + $bit_flag = $h->parse_trace_flag($trace_flag_name); + +Returns the bit flag corresponding to the trace flag name in +$trace_flag_name. Drivers are expected to override this method and +check if $trace_flag_name is a driver specific trace flags and, if +not, then call the DBI's default parse_trace_flag(). + +The parse_trace_flag() method was added in DBI 1.42. + +=head3 C + + $hash_ref = $h->private_attribute_info(); + +Returns a reference to a hash whose keys are the names of driver-private +handle attributes available for the kind of handle (driver, database, statement) +that the method was called on. + +For example, the return value when called with a DBD::Sybase $dbh could look like this: + + { + syb_dynamic_supported => undef, + syb_oc_version => undef, + syb_server_version => undef, + syb_server_version_string => undef, + } + +and when called with a DBD::Sybase $sth they could look like this: + + { + syb_types => undef, + syb_proc_status => undef, + syb_result_type => undef, + } + +The values should be undef. Meanings may be assigned to particular values in future. + +=head3 C + + $rc = $h1->swap_inner_handle( $h2 ); + $rc = $h1->swap_inner_handle( $h2, $allow_reparent ); + +Brain transplants for handles. You don't need to know about this +unless you want to become a handle surgeon. + +A DBI handle is a reference to a tied hash. A tied hash has an +I hash that actually holds the contents. The swap_inner_handle() +method swaps the inner hashes between two handles. The $h1 and $h2 +handles still point to the same tied hashes, but what those hashes +are tied to has been swapped. In effect $h1 I $h2 and +vice-versa. This is powerful stuff, expect problems. Use with care. + +As a small safety measure, the two handles, $h1 and $h2, have to +share the same parent unless $allow_reparent is true. + +The swap_inner_handle() method was added in DBI 1.44. + +Here's a quick kind of 'diagram' as a worked example to help think about what's +happening: + + Original state: + dbh1o -> dbh1i + sthAo -> sthAi(dbh1i) + dbh2o -> dbh2i + + swap_inner_handle dbh1o with dbh2o: + dbh2o -> dbh1i + sthAo -> sthAi(dbh1i) + dbh1o -> dbh2i + + create new sth from dbh1o: + dbh2o -> dbh1i + sthAo -> sthAi(dbh1i) + dbh1o -> dbh2i + sthBo -> sthBi(dbh2i) + + swap_inner_handle sthAo with sthBo: + dbh2o -> dbh1i + sthBo -> sthAi(dbh1i) + dbh1o -> dbh2i + sthAo -> sthBi(dbh2i) + +=head3 C + + $h->visit_child_handles( $coderef ); + $h->visit_child_handles( $coderef, $info ); + +Where $coderef is a reference to a subroutine and $info is an arbitrary value +which, if undefined, defaults to a reference to an empty hash. Returns $info. + +For each child handle of $h, if any, $coderef is invoked as: + + $coderef->($child_handle, $info); + +If the execution of $coderef returns a true value then C +is called on that child handle and passed the returned value as $info. + +For example: + + # count database connections with names (DSN) matching a pattern + my $connections = 0; + $dbh->{Driver}->visit_child_handles(sub { + my ($h, $info) = @_; + ++$connections if $h->{Name} =~ /foo/; + return 0; # don't visit kids + }) + +See also L. + +=head1 ATTRIBUTES COMMON TO ALL HANDLES + +These attributes are common to all types of DBI handles. + +Some attributes are inherited by child handles. That is, the value +of an inherited attribute in a newly created statement handle is the +same as the value in the parent database handle. Changes to attributes +in the new statement handle do not affect the parent database handle +and changes to the database handle do not affect existing statement +handles, only future ones. + +Attempting to set or get the value of an unknown attribute generates a warning, +except for private driver specific attributes (which all have names +starting with a lowercase letter). + +Example: + + $h->{AttributeName} = ...; # set/write + ... = $h->{AttributeName}; # get/read + +=head3 C + +Type: boolean, inherited + +The C attribute enables useful warnings for certain bad +practices. It is enabled by default and should only be disabled in +rare circumstances. Since warnings are generated using the Perl +C function, they can be intercepted using the Perl C<$SIG{__WARN__}> +hook. + +The C attribute is not related to the C attribute. + +=head3 C + +Type: boolean, read-only + +The C attribute is true if the handle object is "active". This is rarely used in +applications. The exact meaning of active is somewhat vague at the +moment. For a database handle it typically means that the handle is +connected to a database (C<$dbh-Edisconnect> sets C off). For +a statement handle it typically means that the handle is a C statements that +either cannot be prepared in advance (due to a limitation of the +driver) or do not need to be executed repeatedly. It should not +be used for C". Drivers using any approach +like this should issue a warning if C is true because +it is generally unsafe - another process may have modified the table +between your insert and the select. For situations where you know +it is safe, such as when you have locked the table, you can silence +the warning by passing C => 0 in \%attr. + +B<*> If no insert has been performed yet, or the last insert failed, +then the value is implementation defined. + +Given all the caveats above, it's clear that this method must be +used with care. + +The C method was added in DBI 1.38. + +=head3 C + + @row_ary = $dbh->selectrow_array($statement); + @row_ary = $dbh->selectrow_array($statement, \%attr); + @row_ary = $dbh->selectrow_array($statement, \%attr, @bind_values); + +This utility method combines L, L and +L into a single call. If called in a list context, it +returns the first row of data from the statement. The C<$statement> +parameter can be a previously prepared statement handle, in which case +the C is skipped. + +If any method fails, and L is not set, C +will return an empty list. + +If called in a scalar context for a statement handle that has more +than one column, it is undefined whether the driver will return +the value of the first column or the last. So don't do that. +Also, in a scalar context, an C is returned if there are no +more rows or if an error occurred. That C can't be distinguished +from an C returned because the first field value was NULL. +For these reasons you should exercise some caution if you use +C in a scalar context, or just don't do that. + + +=head3 C + + $ary_ref = $dbh->selectrow_arrayref($statement); + $ary_ref = $dbh->selectrow_arrayref($statement, \%attr); + $ary_ref = $dbh->selectrow_arrayref($statement, \%attr, @bind_values); + +This utility method combines L, L and +L into a single call. It returns the first row of +data from the statement. The C<$statement> parameter can be a previously +prepared statement handle, in which case the C is skipped. + +If any method fails, and L is not set, C +will return undef. + + +=head3 C + + $hash_ref = $dbh->selectrow_hashref($statement); + $hash_ref = $dbh->selectrow_hashref($statement, \%attr); + $hash_ref = $dbh->selectrow_hashref($statement, \%attr, @bind_values); + +This utility method combines L, L and +L into a single call. It returns the first row of +data from the statement. The C<$statement> parameter can be a previously +prepared statement handle, in which case the C is skipped. + +If any method fails, and L is not set, C +will return undef. + + +=head3 C + + $ary_ref = $dbh->selectall_arrayref($statement); + $ary_ref = $dbh->selectall_arrayref($statement, \%attr); + $ary_ref = $dbh->selectall_arrayref($statement, \%attr, @bind_values); + +This utility method combines L, L and +L into a single call. It returns a reference to an +array containing a reference to an array (or hash, see below) for each row of +data fetched. + +The C<$statement> parameter can be a previously prepared statement handle, +in which case the C is skipped. This is recommended if the +statement is going to be executed many times. + +If L is not set and any method except C +fails then C will return C; if +C fails then it will return with whatever data +has been fetched thus far. You should check C<$dbh-Eerr> +afterwards (or use the C attribute) to discover if the data is +complete or was truncated due to an error. + +The L method called by C +supports a $max_rows parameter. You can specify a value for $max_rows +by including a 'C' attribute in \%attr. In which case finish() +is called for you after fetchall_arrayref() returns. + +The L method called by C +also supports a $slice parameter. You can specify a value for $slice by +including a 'C' or 'C' attribute in \%attr. The only +difference between the two is that if C is not defined and +C is an array ref, then the array is assumed to contain column +index values (which count from 1), rather than perl array index values. +In which case the array is copied and each value decremented before +passing to C. + +You may often want to fetch an array of rows where each row is stored as a +hash. That can be done simply using: + + my $emps = $dbh->selectall_arrayref( + "SELECT ename FROM emp ORDER BY ename", + { Slice => {} } + ); + foreach my $emp ( @$emps ) { + print "Employee: $emp->{ename}\n"; + } + +Or, to fetch into an array instead of an array ref: + + @result = @{ $dbh->selectall_arrayref($sql, { Slice => {} }) }; + +See L method for more details. + +=head3 C + + @ary = $dbh->selectall_array($statement); + @ary = $dbh->selectall_array($statement, \%attr); + @ary = $dbh->selectall_array($statement, \%attr, @bind_values); + +This is a convenience wrapper around L that returns +the rows directly as a list, rather than a reference to an array of rows. + +Note that if L is not set then you can't tell the difference +between returning no rows and an error. Using RaiseError is best practice. + +The C method was added in DBI 1.635. + +=head3 C + + $hash_ref = $dbh->selectall_hashref($statement, $key_field); + $hash_ref = $dbh->selectall_hashref($statement, $key_field, \%attr); + $hash_ref = $dbh->selectall_hashref($statement, $key_field, \%attr, @bind_values); + +This utility method combines L, L and +L into a single call. It returns a reference to a +hash containing one entry, at most, for each row, as returned by fetchall_hashref(). + +The C<$statement> parameter can be a previously prepared statement handle, +in which case the C is skipped. This is recommended if the +statement is going to be executed many times. + +The C<$key_field> parameter defines which column, or columns, are used as keys +in the returned hash. It can either be the name of a single field, or a +reference to an array containing multiple field names. Using multiple names +yields a tree of nested hashes. + +If a row has the same key as an earlier row then it replaces the earlier row. + +If any method except C fails, and L is not set, +C will return C. If C fails and +L is not set, then it will return with whatever data it +has fetched thus far. $DBI::err should be checked to catch that. + +See fetchall_hashref() for more details. + +=head3 C + + $ary_ref = $dbh->selectcol_arrayref($statement); + $ary_ref = $dbh->selectcol_arrayref($statement, \%attr); + $ary_ref = $dbh->selectcol_arrayref($statement, \%attr, @bind_values); + +This utility method combines L, L, and fetching one +column from all the rows, into a single call. It returns a reference to +an array containing the values of the first column from each row. + +The C<$statement> parameter can be a previously prepared statement handle, +in which case the C is skipped. This is recommended if the +statement is going to be executed many times. + +If any method except C fails, and L is not set, +C will return C. If C fails and +L is not set, then it will return with whatever data it +has fetched thus far. $DBI::err should be checked to catch that. + +The C method defaults to pushing a single column +value (the first) from each row into the result array. However, it can +also push another column, or even multiple columns per row, into the +result array. This behaviour can be specified via a 'C' +attribute which must be a ref to an array containing the column number +or numbers to use. For example: + + # get array of id and name pairs: + my $ary_ref = $dbh->selectcol_arrayref("select id, name from table", { Columns=>[1,2] }); + my %hash = @$ary_ref; # build hash from key-value pairs so $hash{$id} => name + +You can specify a maximum number of rows to fetch by including a +'C' attribute in \%attr. + +=head3 C + + $sth = $dbh->prepare($statement) or die $dbh->errstr; + $sth = $dbh->prepare($statement, \%attr) or die $dbh->errstr; + +Prepares a statement for later execution by the database +engine and returns a reference to a statement handle object. + +The returned statement handle can be used to get attributes of the +statement and invoke the L method. See L. + +Drivers for engines without the concept of preparing a +statement will typically just store the statement in the returned +handle and process it when C<$sth-Eexecute> is called. Such drivers are +unlikely to give much useful information about the +statement, such as C<$sth-E{NUM_OF_FIELDS}>, until after C<$sth-Eexecute> +has been called. Portable applications should take this into account. + +In general, DBI drivers do not parse the contents of the statement +(other than simply counting any L). +The statement is +passed directly to the database engine, sometimes known as pass-thru +mode. This has advantages and disadvantages. On the plus side, you can +access all the functionality of the engine being used. On the downside, +you're limited if you're using a simple engine, and you need to take extra care if +writing applications intended to be portable between engines. + +Portable applications should not assume that a new statement can be +prepared and/or executed while still fetching results from a previous +statement. + +Some command-line SQL tools use statement terminators, like a semicolon, +to indicate the end of a statement. Such terminators should not normally +be used with the DBI. + + +=head3 C + + $sth = $dbh->prepare_cached($statement) + $sth = $dbh->prepare_cached($statement, \%attr) + $sth = $dbh->prepare_cached($statement, \%attr, $if_active) + +Like L except that the statement handle returned will be +stored in a hash associated with the C<$dbh>. If another call is made to +C with the same C<$statement> and C<%attr> parameter values, +then the corresponding cached C<$sth> will be returned without contacting the +database server. Be sure to understand the cautions and caveats noted below. + +The C<$if_active> parameter lets you adjust the behaviour if an +already cached statement handle is still Active. There are several +alternatives: + +=over 4 + +=item B<0>: A warning will be generated, and finish() will be called on +the statement handle before it is returned. This is the default +behaviour if $if_active is not passed. + +=item B<1>: finish() will be called on the statement handle, but the +warning is suppressed. + +=item B<2>: Disables any checking. + +=item B<3>: The existing active statement handle will be removed from the +cache and a new statement handle prepared and cached in its place. +This is the safest option because it doesn't affect the state of the +old handle, it just removes it from the cache. [Added in DBI 1.40] + +=back + +Here are some examples of C: + + sub insert_hash { + my ($table, $field_values) = @_; + # sort to keep field order, and thus sql, stable for prepare_cached + my @fields = sort keys %$field_values; + my @values = @{$field_values}{@fields}; + my $sql = sprintf "insert into %s (%s) values (%s)", + $table, join(",", @fields), join(",", ("?")x@fields); + my $sth = $dbh->prepare_cached($sql); + return $sth->execute(@values); + } + + sub search_hash { + my ($table, $field_values) = @_; + # sort to keep field order, and thus sql, stable for prepare_cached + my @fields = sort keys %$field_values; + my @values = @{$field_values}{@fields}; + my $qualifier = ""; + $qualifier = "where ".join(" and ", map { "$_=?" } @fields) if @fields; + $sth = $dbh->prepare_cached("SELECT * FROM $table $qualifier"); + return $dbh->selectall_arrayref($sth, {}, @values); + } + +I This caching can be useful in some applications, +but it can also cause problems and should be used with care. Here +is a contrived case where caching would cause a significant problem: + + my $sth = $dbh->prepare_cached('SELECT * FROM foo WHERE bar=?'); + $sth->execute(...); + while (my $data = $sth->fetchrow_hashref) { + + # later, in some other code called within the loop... + my $sth2 = $dbh->prepare_cached('SELECT * FROM foo WHERE bar=?'); + $sth2->execute(...); + while (my $data2 = $sth2->fetchrow_arrayref) { + do_stuff(...); + } + } + +In this example, since both handles are preparing the exact same statement, +C<$sth2> will not be its own statement handle, but a duplicate of C<$sth> +returned from the cache. The results will certainly not be what you expect. +Typically the inner fetch loop will work normally, fetching all +the records and terminating when there are no more, but now that $sth +is the same as $sth2 the outer fetch loop will also terminate. + +You'll know if you run into this problem because prepare_cached() +will generate a warning by default (when $if_active is false). + +The cache used by prepare_cached() is keyed by both the statement +and any attributes so you can also avoid this issue by doing something +like: + + $sth = $dbh->prepare_cached("...", { dbi_dummy => __FILE__.__LINE__ }); + +which will ensure that prepare_cached only returns statements cached +by that line of code in that source file. + +Also, to ensure the attributes passed are always the same, avoid passing +references inline. For example, the Slice attribute is specified as a +reference. Be sure to declare it external to the call to prepare_cached(), such +that a new hash reference is not created on every call. See L +for more details and examples. + +If you'd like the cache to managed intelligently, you can tie the +hashref returned by C to an appropriate caching module, +such as L: + + my $cache; + tie %$cache, 'Tie::Cache::LRU', 500; + $dbh->{CachedKids} = $cache; + +=head3 C + + $rc = $dbh->commit or die $dbh->errstr; + +Commit (make permanent) the most recent series of database changes +if the database supports transactions and AutoCommit is off. + +If C is on, then calling +C will issue a "commit ineffective with AutoCommit" warning. + +See also L in the L section below. + +=head3 C + + $rc = $dbh->rollback or die $dbh->errstr; + +Rollback (undo) the most recent series of uncommitted database +changes if the database supports transactions and AutoCommit is off. + +If C is on, then calling +C will issue a "rollback ineffective with AutoCommit" warning. + +See also L in the L section below. + +=head3 C + + $rc = $dbh->begin_work or die $dbh->errstr; + +Enable transactions (by turning C off) until the next call +to C or C. After the next C or C, +C will automatically be turned on again. + +If C is already off when C is called then +it does nothing except return an error. If the driver does not support +transactions then when C attempts to set C off +the driver will trigger a fatal error. + +See also L in the L section below. + + +=head3 C + + $rc = $dbh->disconnect or warn $dbh->errstr; + +Disconnects the database from the database handle. C is typically only used +before exiting the program. The handle is of little use after disconnecting. + +The transaction behaviour of the C method is, sadly, +undefined. Some database systems (such as Oracle and Ingres) will +automatically commit any outstanding changes, but others (such as +Informix) will rollback any outstanding changes. Applications not +using C should explicitly call C or C before +calling C. + +The database is automatically disconnected by the C method if +still connected when there are no longer any references to the handle. +The C method for each driver should implicitly call C to +undo any uncommitted changes. This is vital behaviour to ensure that +incomplete transactions don't get committed simply because Perl calls +C on every object before exiting. Also, do not rely on the order +of object destruction during "global destruction", as it is undefined. + +Generally, if you want your changes to be committed or rolled back when +you disconnect, then you should explicitly call L or L +before disconnecting. + +If you disconnect from a database while you still have active +statement handles (e.g., SELECT statement handles that may have +more data to fetch), you will get a warning. The warning may indicate +that a fetch loop terminated early, perhaps due to an uncaught error. +To avoid the warning call the C method on the active handles. + + +=head3 C + + $rc = $dbh->ping; + +Attempts to determine, in a reasonably efficient way, if the database +server is still running and the connection to it is still working. +Individual drivers should implement this function in the most suitable +manner for their database engine. + +The current I implementation always returns true without +actually doing anything. Actually, it returns "C<0 but true>" which is +true but zero. That way you can tell if the return value is genuine or +just the default. Drivers should override this method with one that +does the right thing for their type of database. + +Few applications would have direct use for this method. See the specialized +Apache::DBI module for one example usage. + + +=head3 C + + $value = $dbh->get_info( $info_type ); + +Returns information about the implementation, i.e. driver and data +source capabilities, restrictions etc. It returns C for +unknown or unimplemented information types. For example: + + $database_version = $dbh->get_info( 18 ); # SQL_DBMS_VER + $max_select_tables = $dbh->get_info( 106 ); # SQL_MAXIMUM_TABLES_IN_SELECT + +See L for more detailed information +about the information types and their meanings and possible return values. + +The L module exports a %GetInfoType hash that +can be used to map info type names to numbers. For example: + + $database_version = $dbh->get_info( $GetInfoType{SQL_DBMS_VER} ); + +The names are a merging of the ANSI and ODBC standards (which differ +in some cases). See L for more details. + +Because some DBI methods make use of get_info(), drivers are strongly +encouraged to support I the following very minimal set +of information types to ensure the DBI itself works properly: + + Type Name Example A Example B + ---- -------------------------- ------------ ---------------- + 17 SQL_DBMS_NAME 'ACCESS' 'Oracle' + 18 SQL_DBMS_VER '03.50.0000' '08.01.0721 ...' + 29 SQL_IDENTIFIER_QUOTE_CHAR '`' '"' + 41 SQL_CATALOG_NAME_SEPARATOR '.' '@' + 114 SQL_CATALOG_LOCATION 1 2 + +Values from 9000 to 9999 for get_info are officially reserved for use by Perl DBI. +Values in that range which have been assigned a meaning are defined here: + +C<9000>: true if a backslash character (C<\>) before placeholder-like text +(e.g. C, C<:foo>) will prevent it being treated as a placeholder by the driver. +The backslash will be removed before the text is passed to the backend. + +=head3 C + + $sth = $dbh->table_info( $catalog, $schema, $table, $type ); + $sth = $dbh->table_info( $catalog, $schema, $table, $type, \%attr ); + + # then $sth->fetchall_arrayref or $sth->fetchall_hashref etc + +Returns an active statement handle that can be used to fetch +information about tables and views that exist in the database. + +The arguments $catalog, $schema and $table may accept search patterns +according to the database/driver, for example: $table = '%FOO%'; +Remember that the underscore character ('C<_>') is a search pattern +that means match any character, so 'FOO_%' is the same as 'FOO%' +and 'FOO_BAR%' will match names like 'FOO1BAR'. + +The value of $type is a comma-separated list of one or more types of +tables to be returned in the result set. Each value may optionally be +quoted, e.g.: + + $type = "TABLE"; + $type = "'TABLE','VIEW'"; + +In addition the following special cases may also be supported by some drivers: + +=over 4 + +=item * +If the value of $catalog is '%' and $schema and $table name +are empty strings, the result set contains a list of catalog names. +For example: + + $sth = $dbh->table_info('%', '', ''); + +=item * +If the value of $schema is '%' and $catalog and $table are empty +strings, the result set contains a list of schema names. + +=item * +If the value of $type is '%' and $catalog, $schema, and $table are all +empty strings, the result set contains a list of table types. + +=back + +If your driver doesn't support one or more of the selection filter +parameters then you may get back more than you asked for and can +do the filtering yourself. + +This method can be expensive, and can return a large amount of data. +(For example, small Oracle installation returns over 2000 rows.) +So it's a good idea to use the filters to limit the data as much as possible. + +The statement handle returned has at least the following fields in the +order show below. Other fields, after these, may also be present. + +B: Table catalog identifier. This field is NULL (C) if not +applicable to the data source, which is usually the case. This field +is empty if not applicable to the table. + +B: The name of the schema containing the TABLE_NAME value. +This field is NULL (C) if not applicable to data source, and +empty if not applicable to the table. + +B: Name of the table (or view, synonym, etc). + +B: One of the following: "TABLE", "VIEW", "SYSTEM TABLE", +"GLOBAL TEMPORARY", "LOCAL TEMPORARY", "ALIAS", "SYNONYM" or a type +identifier that is specific to the data +source. + +B: A description of the table. May be NULL (C). + +Note that C might not return records for all tables. +Applications can use any valid table regardless of whether it's +returned by C. + +See also L, L and +L. + +=head3 C + + $sth = $dbh->column_info( $catalog, $schema, $table, $column ); + + # then $sth->fetchall_arrayref or $sth->fetchall_hashref etc + +Returns an active statement handle that can be used to fetch +information about columns in specified tables. + +The arguments $schema, $table and $column may accept search patterns +according to the database/driver, for example: $table = '%FOO%'; + +Note: The support for the selection criteria is driver specific. If the +driver doesn't support one or more of them then you may get back more +than you asked for and can do the filtering yourself. + +Note: If your driver does not support column_info an undef is +returned. This is distinct from asking for something which does not +exist in a driver which supports column_info as a valid statement +handle to an empty result-set will be returned in this case. + +If the arguments don't match any tables then you'll still get a statement +handle, it'll just return no rows. + +The statement handle returned has at least the following fields in the +order shown below. Other fields, after these, may also be present. + +B: The catalog identifier. +This field is NULL (C) if not applicable to the data source, +which is often the case. This field is empty if not applicable to the +table. + +B: The schema identifier. +This field is NULL (C) if not applicable to the data source, +and empty if not applicable to the table. + +B: The table identifier. +Note: A driver may provide column metadata not only for base tables, but +also for derived objects like SYNONYMS etc. + +B: The column identifier. + +B: The concise data type code. + +B: A data source dependent data type name. + +B: The column size. +This is the maximum length in characters for character data types, +the number of digits or bits for numeric data types or the length +in the representation of temporal types. +See the relevant specifications for detailed information. + +B: The length in bytes of transferred data. + +B: The total number of significant digits to the right of +the decimal point. + +B: The radix for numeric precision. +The value is 10 or 2 for numeric data types and NULL (C) if not +applicable. + +B: Indicates if a column can accept NULLs. +The following values are defined: + + SQL_NO_NULLS 0 + SQL_NULLABLE 1 + SQL_NULLABLE_UNKNOWN 2 + +B: A description of the column. + +B: The default value of the column, in a format that can be used +directly in an SQL statement. + +Note that this may be an expression and not simply the text used for the +default value in the original CREATE TABLE statement. For example, given: + + col1 char(30) default current_user -- a 'function' + col2 char(30) default 'string' -- a string literal + +where "current_user" is the name of a function, the corresponding C +values would be: + + Database col1 col2 + -------- ---- ---- + Oracle: current_user 'string' + Postgres: "current_user"() 'string'::text + MS SQL: (user_name()) ('string') + +B: The SQL data type. + +B: The subtype code for datetime and interval data types. + +B: The maximum length in bytes of a character or binary +data type column. + +B: The column sequence number (starting with 1). + +B: Indicates if the column can accept NULLs. +Possible values are: 'NO', 'YES' and ''. + +SQL/CLI defines the following additional columns: + + CHAR_SET_CAT + CHAR_SET_SCHEM + CHAR_SET_NAME + COLLATION_CAT + COLLATION_SCHEM + COLLATION_NAME + UDT_CAT + UDT_SCHEM + UDT_NAME + DOMAIN_CAT + DOMAIN_SCHEM + DOMAIN_NAME + SCOPE_CAT + SCOPE_SCHEM + SCOPE_NAME + MAX_CARDINALITY + DTD_IDENTIFIER + IS_SELF_REF + +Drivers capable of supplying any of those values should do so in +the corresponding column and supply undef values for the others. + +Drivers wishing to provide extra database/driver specific information +should do so in extra columns beyond all those listed above, and +use lowercase field names with the driver-specific prefix (i.e., +'ora_...'). Applications accessing such fields should do so by name +and not by column number. + +The result set is ordered by TABLE_CAT, TABLE_SCHEM, TABLE_NAME +and ORDINAL_POSITION. + +Note: There is some overlap with statement handle attributes (in perl) and +SQLDescribeCol (in ODBC). However, SQLColumns provides more metadata. + +See also L and L. + +=head3 C + + $sth = $dbh->primary_key_info( $catalog, $schema, $table ); + + # then $sth->fetchall_arrayref or $sth->fetchall_hashref etc + +Returns an active statement handle that can be used to fetch information +about columns that make up the primary key for a table. +The arguments don't accept search patterns (unlike table_info()). + +The statement handle will return one row per column, ordered by +TABLE_CAT, TABLE_SCHEM, TABLE_NAME, and KEY_SEQ. +If there is no primary key then the statement handle will fetch no rows. + +Note: The support for the selection criteria, such as $catalog, is +driver specific. If the driver doesn't support catalogs and/or +schemas, it may ignore these criteria. + +The statement handle returned has at least the following fields in the +order shown below. Other fields, after these, may also be present. + +B: The catalog identifier. +This field is NULL (C) if not applicable to the data source, +which is often the case. This field is empty if not applicable to the +table. + +B: The schema identifier. +This field is NULL (C) if not applicable to the data source, +and empty if not applicable to the table. + +B: The table identifier. + +B: The column identifier. + +B: The column sequence number (starting with 1). +Note: This field is named B in SQL/CLI. + +B: The primary key constraint identifier. +This field is NULL (C) if not applicable to the data source. + +See also L and L. + +=head3 C + + @key_column_names = $dbh->primary_key( $catalog, $schema, $table ); + +Simple interface to the primary_key_info() method. Returns a list of +the column names that comprise the primary key of the specified table. +The list is in primary key column sequence order. +If there is no primary key then an empty list is returned. + +=head3 C + + $sth = $dbh->foreign_key_info( $pk_catalog, $pk_schema, $pk_table + , $fk_catalog, $fk_schema, $fk_table ); + + $sth = $dbh->foreign_key_info( $pk_catalog, $pk_schema, $pk_table + , $fk_catalog, $fk_schema, $fk_table + , \%attr ); + + # then $sth->fetchall_arrayref or $sth->fetchall_hashref etc + +Returns an active statement handle that can be used to fetch information +about foreign keys in and/or referencing the specified table(s). +The arguments don't accept search patterns (unlike table_info()). + +C<$pk_catalog>, C<$pk_schema>, C<$pk_table> +identify the primary (unique) key table (B). + +C<$fk_catalog>, C<$fk_schema>, C<$fk_table> +identify the foreign key table (B). + +If both B and B are given, the function returns the foreign key, if +any, in table B that refers to the primary (unique) key of table B. +(Note: In SQL/CLI, the result is implementation-defined.) + +If only B is given, then the result set contains the primary key +of that table and all foreign keys that refer to it. + +If only B is given, then the result set contains all foreign keys +in that table and the primary keys to which they refer. +(Note: In SQL/CLI, the result includes unique keys too.) + +For example: + + $sth = $dbh->foreign_key_info( undef, $user, 'master'); + $sth = $dbh->foreign_key_info( undef, undef, undef , undef, $user, 'detail'); + $sth = $dbh->foreign_key_info( undef, $user, 'master', undef, $user, 'detail'); + + # then $sth->fetchall_arrayref or $sth->fetchall_hashref etc + +Note: The support for the selection criteria, such as C<$catalog>, is +driver specific. If the driver doesn't support catalogs and/or +schemas, it may ignore these criteria. + +The statement handle returned has the following fields in the order shown below. +Because ODBC never includes unique keys, they define different columns in the +result set than SQL/CLI. SQL/CLI column names are shown in parentheses. + +B: +The primary (unique) key table catalog identifier. +This field is NULL (C) if not applicable to the data source, +which is often the case. This field is empty if not applicable to the +table. + +B: +The primary (unique) key table schema identifier. +This field is NULL (C) if not applicable to the data source, +and empty if not applicable to the table. + +B: +The primary (unique) key table identifier. + +B: +The primary (unique) key column identifier. + +B: +The foreign key table catalog identifier. +This field is NULL (C) if not applicable to the data source, +which is often the case. This field is empty if not applicable to the +table. + +B: +The foreign key table schema identifier. +This field is NULL (C) if not applicable to the data source, +and empty if not applicable to the table. + +B: +The foreign key table identifier. + +B: +The foreign key column identifier. + +B: +The column sequence number (starting with 1). + +B: +The referential action for the UPDATE rule. +The following codes are defined: + + CASCADE 0 + RESTRICT 1 + SET NULL 2 + NO ACTION 3 + SET DEFAULT 4 + +B: +The referential action for the DELETE rule. +The codes are the same as for UPDATE_RULE. + +B: +The foreign key name. + +B: +The primary (unique) key name. + +B: +The deferrability of the foreign key constraint. +The following codes are defined: + + INITIALLY DEFERRED 5 + INITIALLY IMMEDIATE 6 + NOT DEFERRABLE 7 + +B< ( UNIQUE_OR_PRIMARY )>: +This column is necessary if a driver includes all candidate (i.e. primary and +alternate) keys in the result set (as specified by SQL/CLI). +The value of this column is UNIQUE if the foreign key references an alternate +key and PRIMARY if the foreign key references a primary key, or it +may be undefined if the driver doesn't have access to the information. + +See also L and L. + +=head3 C + + $sth = $dbh->statistics_info( $catalog, $schema, $table, $unique_only, $quick ); + + # then $sth->fetchall_arrayref or $sth->fetchall_hashref etc + +Returns an active statement handle that can be used to fetch statistical +information about a table and its indexes. + +The arguments don't accept search patterns (unlike L). + +If the boolean argument $unique_only is true, only UNIQUE indexes will be +returned in the result set, otherwise all indexes will be returned. + +If the boolean argument $quick is set, the actual statistical information +columns (CARDINALITY and PAGES) will only be returned if they are readily +available from the server, and might not be current. Some databases may +return stale statistics or no statistics at all with this flag set. + +The statement handle will return at most one row per column name per index, +plus at most one row for the entire table itself, ordered by NON_UNIQUE, TYPE, +INDEX_QUALIFIER, INDEX_NAME, and ORDINAL_POSITION. + +Note: The support for the selection criteria, such as $catalog, is +driver specific. If the driver doesn't support catalogs and/or +schemas, it may ignore these criteria. + +The statement handle returned has at least the following fields in the +order shown below. Other fields, after these, may also be present. + +B: The catalog identifier. +This field is NULL (C) if not applicable to the data source, +which is often the case. This field is empty if not applicable to the +table. + +B: The schema identifier. +This field is NULL (C) if not applicable to the data source, +and empty if not applicable to the table. + +B: The table identifier. + +B: Unique index indicator. +Returns 0 for unique indexes, 1 for non-unique indexes + +B: Index qualifier identifier. +The identifier that is used to qualify the index name when doing a +C; NULL (C) is returned if an index qualifier is not +supported by the data source. +If a non-NULL (defined) value is returned in this column, it must be used +to qualify the index name on a C statement; otherwise, +the TABLE_SCHEM should be used to qualify the index name. + +B: The index identifier. + +B: The type of information being returned. Can be any of the +following values: 'table', 'btree', 'clustered', 'content', 'hashed', +or 'other'. + +In the case that this field is 'table', all fields +other than TABLE_CAT, TABLE_SCHEM, TABLE_NAME, TYPE, +CARDINALITY, and PAGES will be NULL (C). + +B: Column sequence number (starting with 1). + +B: The column identifier. + +B: Column sort sequence. +C for Ascending, C for Descending, or NULL (C) if +not supported for this index. + +B: Cardinality of the table or index. +For indexes, this is the number of unique values in the index. +For tables, this is the number of rows in the table. +If not supported, the value will be NULL (C). + +B: Number of storage pages used by this table or index. +If not supported, the value will be NULL (C). + +B: The index filter condition as a string. +If the index is not a filtered index, or it cannot be determined +whether the index is a filtered index, this value is NULL (C). +If the index is a filtered index, but the filter condition +cannot be determined, this value is the empty string C<''>. +Otherwise it will be the literal filter condition as a string, +such as C. + +See also L and L. + +=head3 C + + @names = $dbh->tables( $catalog, $schema, $table, $type ); + @names = $dbh->tables; # deprecated + +Simple interface to table_info(). Returns a list of matching +table names, possibly including a catalog/schema prefix. + +See L for a description of the parameters. + +If C<$dbh-Eget_info(29)> returns true (29 is SQL_IDENTIFIER_QUOTE_CHAR) +then the table names are constructed and quoted by L +to ensure they are usable even if they contain whitespace or reserved +words etc. This means that the table names returned will include +quote characters. + +=head3 C + + $type_info_all = $dbh->type_info_all; + +Returns a reference to an array which holds information about each data +type variant supported by the database and driver. The array and its +contents should be treated as read-only. + +The first item is a reference to an 'index' hash of CE C pairs. +The items following that are references to arrays, one per supported data +type variant. The leading index hash defines the names and order of the +fields within the arrays that follow it. +For example: + + $type_info_all = [ + { TYPE_NAME => 0, + DATA_TYPE => 1, + COLUMN_SIZE => 2, # was PRECISION originally + LITERAL_PREFIX => 3, + LITERAL_SUFFIX => 4, + CREATE_PARAMS => 5, + NULLABLE => 6, + CASE_SENSITIVE => 7, + SEARCHABLE => 8, + UNSIGNED_ATTRIBUTE=> 9, + FIXED_PREC_SCALE => 10, # was MONEY originally + AUTO_UNIQUE_VALUE => 11, # was AUTO_INCREMENT originally + LOCAL_TYPE_NAME => 12, + MINIMUM_SCALE => 13, + MAXIMUM_SCALE => 14, + SQL_DATA_TYPE => 15, + SQL_DATETIME_SUB => 16, + NUM_PREC_RADIX => 17, + INTERVAL_PRECISION=> 18, + }, + [ 'VARCHAR', SQL_VARCHAR, + undef, "'","'", undef,0, 1,1,0,0,0,undef,1,255, undef + ], + [ 'INTEGER', SQL_INTEGER, + undef, "", "", undef,0, 0,1,0,0,0,undef,0, 0, 10 + ], + ]; + +More than one row may have the same value in the C +field if there are different ways to spell the type name and/or there +are variants of the type with different attributes (e.g., with and +without C set, with and without C, etc). + +The rows are ordered by C first and then by how closely each +type maps to the corresponding ODBC SQL data type, closest first. + +The meaning of the fields is described in the documentation for +the L method. + +An 'index' hash is provided so you don't need to rely on index +values defined above. However, using DBD::ODBC with some old ODBC +drivers may return older names, shown as comments in the example above. +Another issue with the index hash is that the lettercase of the +keys is not defined. It is usually uppercase, as show here, but +drivers may return names with any lettercase. + +Drivers are also free to return extra driver-specific columns of +information - though it's recommended that they start at column +index 50 to leave room for expansion of the DBI/ODBC specification. + +The type_info_all() method is not normally used directly. +The L method provides a more usable and useful interface +to the data. + +=head3 C + + @type_info = $dbh->type_info($data_type); + +Returns a list of hash references holding information about one or more +variants of $data_type. The list is ordered by C first and +then by how closely each type maps to the corresponding ODBC SQL data +type, closest first. If called in a scalar context then only the first +(best) element is returned. + +If $data_type is undefined or C, then the list will +contain hashes for all data type variants supported by the database and driver. + +If $data_type is an array reference then C returns the +information for the I type in the array that has any matches. + +The keys of the hash follow the same letter case conventions as the +rest of the DBI (see L). The +following uppercase items should always exist, though may be undef: + +=over 4 + +=item TYPE_NAME (string) + +Data type name for use in CREATE TABLE statements etc. + +=item DATA_TYPE (integer) + +SQL data type number. + +=item COLUMN_SIZE (integer) + +For numeric types, this is either the total number of digits (if the +NUM_PREC_RADIX value is 10) or the total number of bits allowed in the +column (if NUM_PREC_RADIX is 2). + +For string types, this is the maximum size of the string in characters. + +For date and interval types, this is the maximum number of characters +needed to display the value. + +=item LITERAL_PREFIX (string) + +Characters used to prefix a literal. A typical prefix is "C<'>" for characters, +or possibly "C<0x>" for binary values passed as hexadecimal. NULL (C) is +returned for data types for which this is not applicable. + + +=item LITERAL_SUFFIX (string) + +Characters used to suffix a literal. Typically "C<'>" for characters. +NULL (C) is returned for data types where this is not applicable. + +=item CREATE_PARAMS (string) + +Parameter names for data type definition. For example, C for a +C would be "C" if the DECIMAL type should be +declared as CIC<)> where I and I +are integer values. For a C it would be "C". +NULL (C) is returned for data types for which this is not applicable. + +=item NULLABLE (integer) + +Indicates whether the data type accepts a NULL value: +C<0> or an empty string = no, C<1> = yes, C<2> = unknown. + +=item CASE_SENSITIVE (boolean) + +Indicates whether the data type is case sensitive in collations and +comparisons. + +=item SEARCHABLE (integer) + +Indicates how the data type can be used in a WHERE clause, as +follows: + + 0 - Cannot be used in a WHERE clause + 1 - Only with a LIKE predicate + 2 - All comparison operators except LIKE + 3 - Can be used in a WHERE clause with any comparison operator + +=item UNSIGNED_ATTRIBUTE (boolean) + +Indicates whether the data type is unsigned. NULL (C) is returned +for data types for which this is not applicable. + +=item FIXED_PREC_SCALE (boolean) + +Indicates whether the data type always has the same precision and scale +(such as a money type). NULL (C) is returned for data types +for which +this is not applicable. + +=item AUTO_UNIQUE_VALUE (boolean) + +Indicates whether a column of this data type is automatically set to a +unique value whenever a new row is inserted. NULL (C) is returned +for data types for which this is not applicable. + +=item LOCAL_TYPE_NAME (string) + +Localized version of the C for use in dialog with users. +NULL (C) is returned if a localized name is not available (in which +case C should be used). + +=item MINIMUM_SCALE (integer) + +The minimum scale of the data type. If a data type has a fixed scale, +then C holds the same value. NULL (C) is returned for +data types for which this is not applicable. + +=item MAXIMUM_SCALE (integer) + +The maximum scale of the data type. If a data type has a fixed scale, +then C holds the same value. NULL (C) is returned for +data types for which this is not applicable. + +=item SQL_DATA_TYPE (integer) + +This column is the same as the C column, except for interval +and datetime data types. For interval and datetime data types, the +C field will return C or C, and the +C field below will return the subcode for the specific +interval or datetime data type. If this field is NULL, then the driver +does not support or report on interval or datetime subtypes. + +=item SQL_DATETIME_SUB (integer) + +For interval or datetime data types, where the C +field above is C or C, this field will +hold the I for the specific interval or datetime data type. +Otherwise it will be NULL (C). + +Although not mentioned explicitly in the standards, it seems there +is a simple relationship between these values: + + DATA_TYPE == (10 * SQL_DATA_TYPE) + SQL_DATETIME_SUB + +=item NUM_PREC_RADIX (integer) + +The radix value of the data type. For approximate numeric types, +C +contains the value 2 and C holds the number of bits. For +exact numeric types, C contains the value 10 and C holds +the number of decimal digits. NULL (C) is returned either for data types +for which this is not applicable or if the driver cannot report this information. + +=item INTERVAL_PRECISION (integer) + +The interval leading precision for interval types. NULL is returned +either for data types for which this is not applicable or if the driver +cannot report this information. + +=back + +For example, to find the type name for the fields in a select statement +you can do: + + @names = map { scalar $dbh->type_info($_)->{TYPE_NAME} } @{ $sth->{TYPE} } + +Since DBI and ODBC drivers vary in how they map their types into the +ISO standard types you may need to search for more than one type. +Here's an example looking for a usable type to store a date: + + $my_date_type = $dbh->type_info( [ SQL_DATE, SQL_TIMESTAMP ] ); + +Similarly, to more reliably find a type to store small integers, you could +use a list starting with C, C, C, etc. + +See also L. + + +=head3 C + + $sql = $dbh->quote($value); + $sql = $dbh->quote($value, $data_type); + +Quote a string literal for use as a literal value in an SQL statement, +by escaping any special characters (such as quotation marks) +contained within the string and adding the required type of outer +quotation marks. + + $sql = sprintf "SELECT foo FROM bar WHERE baz = %s", + $dbh->quote("Don't"); + +For most database types, at least those that conform to SQL standards, quote +would return C<'Don''t'> (including the outer quotation marks). For others it +may return something like C<'Don\'t'> + +An undefined C<$value> value will be returned as the string C (without +single quotation marks) to match how NULLs are represented in SQL. + +If C<$data_type> is supplied, it is used to try to determine the required +quoting behaviour by using the information returned by L. +As a special case, the standard numeric types are optimized to return +C<$value> without calling C. + +Quote will probably I be able to deal with all possible input +(such as binary data or data containing newlines), and is not related in +any way with escaping or quoting shell meta-characters. + +It is valid for the quote() method to return an SQL expression that +evaluates to the desired string. For example: + + $quoted = $dbh->quote("one\ntwo\0three") + +may return something like: + + CONCAT('one', CHAR(12), 'two', CHAR(0), 'three') + +The quote() method should I be used with L. + +=head3 C + + $sql = $dbh->quote_identifier( $name ); + $sql = $dbh->quote_identifier( $catalog, $schema, $table, \%attr ); + +Quote an identifier (table name etc.) for use in an SQL statement, +by escaping any special characters (such as double quotation marks) +it contains and adding the required type of outer quotation marks. + +Undefined names are ignored and the remainder are quoted and then +joined together, typically with a dot (C<.>) character. For example: + + $id = $dbh->quote_identifier( undef, 'Her schema', 'My table' ); + +would, for most database types, return C<"Her schema"."My table"> +(including all the double quotation marks). + +If three names are supplied then the first is assumed to be a +catalog name and special rules may be applied based on what L +returns for SQL_CATALOG_NAME_SEPARATOR (41) and SQL_CATALOG_LOCATION (114). +For example, for Oracle: + + $id = $dbh->quote_identifier( 'link', 'schema', 'table' ); + +would return C<"schema"."table"@"link">. + +=head3 C + + $imp_data = $dbh->take_imp_data; + +Leaves the $dbh in an almost dead, zombie-like, state and returns +a binary string of raw implementation data from the driver which +describes the current database connection. Effectively it detaches +the underlying database API connection data from the DBI handle. +After calling take_imp_data(), all other methods except C +will generate a warning and return undef. + +Why would you want to do this? You don't, forget I even mentioned it. +Unless, that is, you're implementing something advanced like a +multi-threaded connection pool like C. + +The returned $imp_data can be passed as a C attribute +to a later connect() call, even in a separate thread in the same +process, where the driver can use it to 'adopt' the existing +connection that the implementation data was taken from. + +Some things to keep in mind... + +B<*> the $imp_data holds the only reference to the underlying +database API connection data. That connection is still 'live' and +won't be cleaned up properly unless the $imp_data is used to create +a new $dbh which is then allowed to disconnect() normally. + +B<*> using the same $imp_data to create more than one other new +$dbh at a time may well lead to unpleasant problems. Don't do that. + +Any child statement handles are effectively destroyed when take_imp_data() is +called. + +The C method was added in DBI 1.36 but wasn't useful till 1.49. + + +=head2 Database Handle Attributes + +This section describes attributes specific to database handles. + +Changes to these database handle attributes do not affect any other +existing or future database handles. + +Attempting to set or get the value of an unknown attribute generates a warning, +except for private driver-specific attributes (which all have names +starting with a lowercase letter). + +Example: + + $h->{AutoCommit} = ...; # set/write + ... = $h->{AutoCommit}; # get/read + +=head3 C + +Type: boolean + +If true, then database changes cannot be rolled-back (undone). If false, +then database changes automatically occur within a "transaction", which +must either be committed or rolled back using the C or C +methods. + +Drivers should always default to C mode (an unfortunate +choice largely forced on the DBI by ODBC and JDBC conventions.) + +Attempting to set C to an unsupported value is a fatal error. +This is an important feature of the DBI. Applications that need +full transaction behaviour can set C<$dbh-E{AutoCommit} = 0> (or +set C to 0 via L) +without having to check that the value was assigned successfully. + +For the purposes of this description, we can divide databases into three +categories: + + Databases which don't support transactions at all. + Databases in which a transaction is always active. + Databases in which a transaction must be explicitly started (C<'BEGIN WORK'>). + +B<* Databases which don't support transactions at all> + +For these databases, attempting to turn C off is a fatal error. +C and C both issue warnings about being ineffective while +C is in effect. + +B<* Databases in which a transaction is always active> + +These are typically mainstream commercial relational databases with +"ANSI standard" transaction behaviour. +If C is off, then changes to the database won't have any +lasting effect unless L is called (but see also +L). If L is called then any changes since the +last commit are undone. + +If C is on, then the effect is the same as if the DBI +called C automatically after every successful database +operation. So calling C or C explicitly while +C is on would be ineffective because the changes would +have already been committed. + +Changing C from off to on will trigger a L. + +For databases which don't support a specific auto-commit mode, the +driver has to commit each statement automatically using an explicit +C after it completes successfully (and roll it back using an +explicit C if it fails). The error information reported to the +application will correspond to the statement which was executed, unless +it succeeded and the commit or rollback failed. + +B<* Databases in which a transaction must be explicitly started> + +For these databases, the intention is to have them act like databases in +which a transaction is always active (as described above). + +To do this, the driver will automatically begin an explicit transaction +when C is turned off, or after a L or +L (or when the application issues the next database +operation after one of those events). + +In this way, the application does not have to treat these databases +as a special case. + +See L, L and L for other important +notes about transactions. + + +=head3 C + +Type: handle + +Holds the handle of the parent driver. The only recommended use for this +is to find the name of the driver using: + + $dbh->{Driver}->{Name} + + +=head3 C + +Type: string + +Holds the "name" of the database. Usually (and recommended to be) the +same as the "C" string used to connect to the database, +but with the leading "C" removed. + + +=head3 C + +Type: string, read-only + +Returns the statement string passed to the most recent L or +L method called in this database handle, even if that method +failed. This is especially useful where C is enabled and +the exception handler checks $@ and sees that a 'prepare' method call +failed. + + +=head3 C + +Type: integer + +A hint to the driver indicating the size of the local row cache that the +application would like the driver to use for future C + 1 - Disable the local row cache + >1 - Cache this many rows + <0 - Cache as many rows that will fit into this much memory for each C statement, C returns the number of rows +affected, if known. If no rows were affected, then C returns +"C<0E0>", which Perl will treat as 0 but will regard as true. Note that it +is I an error for no rows to be affected by a statement. If the +number of rows affected is not known, then C returns -1. + +For C statement by checking if +C<$sth-E{NUM_OF_FIELDS}> is greater than zero after calling C. + +If any arguments are given, then C will effectively call +L for each value before executing the statement. Values +bound in this way are usually treated as C types unless +the driver can determine the correct type (which is rare), or unless +C (or C) has already been used to +specify the type. + +Note that passing C an empty array is the same as passing no arguments +at all, which will execute the statement with previously bound values. +That's probably not what you want. + +If execute() is called on a statement handle that's still active +($sth->{Active} is true) then it should effectively call finish() +to tidy up the previous execution results before starting this new +execution. + +=head3 C + + $tuples = $sth->execute_array(\%attr) or die $sth->errstr; + $tuples = $sth->execute_array(\%attr, @bind_values) or die $sth->errstr; + + ($tuples, $rows) = $sth->execute_array(\%attr) or die $sth->errstr; + ($tuples, $rows) = $sth->execute_array(\%attr, @bind_values) or die $sth->errstr; + +Execute the prepared statement once for each parameter tuple +(group of values) provided either in the @bind_values, or by prior +calls to L, or via a reference passed in \%attr. + +When called in scalar context the execute_array() method returns the +number of tuples executed, or C if an error occurred. Like +execute(), a successful execute_array() always returns true regardless +of the number of tuples executed, even if it's zero. If there were any +errors the ArrayTupleStatus array can be used to discover which tuples +failed and with what errors. + +When called in list context the execute_array() method returns two scalars; +$tuples is the same as calling execute_array() in scalar context and $rows is +the number of rows affected for each tuple, if available or +-1 if the driver cannot determine this. NOTE, some drivers cannot determine +the number of rows affected per tuple but can provide the number of rows +affected for the batch. +If you are doing an update operation the returned rows affected may not be what +you expect if, for instance, one or more of the tuples affected the same row +multiple times. Some drivers may not yet support list context, in which case +$rows will be undef, or may not be able to provide the number of rows affected +when performing this batch operation, in which case $rows will be -1. + +Bind values for the tuples to be executed may be supplied row-wise +by an C attribute, or else column-wise in the +C<@bind_values> argument, or else column-wise by prior calls to +L. + +Where column-wise binding is used (via the C<@bind_values> argument +or calls to bind_param_array()) the maximum number of elements in +any one of the bound value arrays determines the number of tuples +executed. Placeholders with fewer values in their parameter arrays +are treated as if padded with undef (NULL) values. + +If a scalar value is bound, instead of an array reference, it is +treated as a I length array with all elements having the +same value. It does not influence the number of tuples executed, +so if all bound arrays have zero elements then zero tuples will +be executed. If I bound values are scalars then one tuple +will be executed, making execute_array() act just like execute(). + +The C attribute can be used to specify a reference +to a subroutine that will be called to provide the bind values for +each tuple execution. The subroutine should return an reference to +an array which contains the appropriate number of bind values, or +return an undef if there is no more data to execute. + +As a convenience, the C attribute can also be +used to specify a statement handle. In which case the fetchrow_arrayref() +method will be called on the given statement handle in order to +provide the bind values for each tuple execution. + +The values specified via bind_param_array() or the @bind_values +parameter may be either scalars, or arrayrefs. If any C<@bind_values> +are given, then C will effectively call L +for each value before executing the statement. Values bound in +this way are usually treated as C types unless the +driver can determine the correct type (which is rare), or unless +C, C, C, or +C has already been used to specify the type. +See L for details. + +The C attribute can be used to specify a +reference to an array which will receive the execute status of each +executed parameter tuple. Note the C attribute was +mandatory until DBI 1.38. + +For tuples which are successfully executed, the element at the same +ordinal position in the status array is the resulting rowcount (or -1 +if unknown). +If the execution of a tuple causes an error, then the corresponding +status array element will be set to a reference to an array containing +L, L and L set by the failed execution. + +If B tuple execution returns an error, C will +return C. In that case, the application should inspect the +status array to determine which parameter tuples failed. +Some databases may not continue executing tuples beyond the first +failure. In this case the status array will either hold fewer +elements, or the elements beyond the failure will be undef. + +If all parameter tuples are successfully executed, C +returns the number tuples executed. If no tuples were executed, +then execute_array() returns "C<0E0>", just like execute() does, +which Perl will treat as 0 but will regard as true. + +For example: + + $sth = $dbh->prepare("INSERT INTO staff (first_name, last_name) VALUES (?, ?)"); + my $tuples = $sth->execute_array( + { ArrayTupleStatus => \my @tuple_status }, + \@first_names, + \@last_names, + ); + if ($tuples) { + print "Successfully inserted $tuples records\n"; + } + else { + for my $tuple (0..@last_names-1) { + my $status = $tuple_status[$tuple]; + $status = [0, "Skipped"] unless defined $status; + next unless ref $status; + printf "Failed to insert (%s, %s): %s\n", + $first_names[$tuple], $last_names[$tuple], $status->[1]; + } + } + +Support for data returning statements such as SELECT is driver-specific +and subject to change. At present, the default implementation +provided by DBI only supports non-data returning statements. + +Transaction semantics when using array binding are driver and +database specific. If C is on, the default DBI +implementation will cause each parameter tuple to be individually +committed (or rolled back in the event of an error). If C +is off, the application is responsible for explicitly committing +the entire set of bound parameter tuples. Note that different +drivers and databases may have different behaviours when some +parameter tuples cause failures. In some cases, the driver or +database may automatically rollback the effect of all prior parameter +tuples that succeeded in the transaction; other drivers or databases +may retain the effect of prior successfully executed parameter +tuples. Be sure to check your driver and database for its specific +behaviour. + +Note that, in general, performance will usually be better with +C turned off, and using explicit C after each +C call. + +The C method was added in DBI 1.22, and ArrayTupleFetch +was added in 1.36. + +=head3 C + + $tuples = $sth->execute_for_fetch($fetch_tuple_sub); + $tuples = $sth->execute_for_fetch($fetch_tuple_sub, \@tuple_status); + + ($tuples, $rows) = $sth->execute_for_fetch($fetch_tuple_sub); + ($tuples, $rows) = $sth->execute_for_fetch($fetch_tuple_sub, \@tuple_status); + +The execute_for_fetch() method is used to perform bulk operations and +although it is most often used via the execute_array() method you can +use it directly. The main difference between execute_array and +execute_for_fetch is the former does column or row-wise binding and +the latter uses row-wise binding. + +The fetch subroutine, referenced by $fetch_tuple_sub, is expected +to return a reference to an array (known as a 'tuple') or undef. + +The execute_for_fetch() method calls $fetch_tuple_sub, without any +parameters, until it returns a false value. Each tuple returned is +used to provide bind values for an $sth->execute(@$tuple) call. + +In scalar context execute_for_fetch() returns C if there were any +errors and the number of tuples executed otherwise. Like execute() and +execute_array() a zero is returned as "0E0" so execute_for_fetch() is +only false on error. If there were any errors the @tuple_status array +can be used to discover which tuples failed and with what errors. + +When called in list context execute_for_fetch() returns two scalars; +$tuples is the same as calling execute_for_fetch() in scalar context and $rows is +the sum of the number of rows affected for each tuple, if available or -1 +if the driver cannot determine this. +If you are doing an update operation the returned rows affected may not be what +you expect if, for instance, one or more of the tuples affected the same row +multiple times. Some drivers may not yet support list context, in which case +$rows will be undef, or may not be able to provide the number of rows affected +when performing this batch operation, in which case $rows will be -1. + +If \@tuple_status is passed then the execute_for_fetch method uses +it to return status information. The tuple_status array holds one +element per tuple. If the corresponding execute() did not fail then +the element holds the return value from execute(), which is typically +a row count. If the execute() did fail then the element holds a +reference to an array containing ($sth->err, $sth->errstr, $sth->state). + +If the driver detects an error that it knows means no further tuples can be +executed then it may return, with an error status, even though $fetch_tuple_sub +may still have more tuples to be executed. + +Although each tuple returned by $fetch_tuple_sub is effectively used +to call $sth->execute(@$tuple_array_ref) the exact timing may vary. +Drivers are free to accumulate sets of tuples to pass to the +database server in bulk group operations for more efficient execution. +However, the $fetch_tuple_sub is specifically allowed to return +the same array reference each time (which is what fetchrow_arrayref() +usually does). + +For example: + + my $sel = $dbh1->prepare("select foo, bar from table1"); + $sel->execute; + + my $ins = $dbh2->prepare("insert into table2 (foo, bar) values (?,?)"); + my $fetch_tuple_sub = sub { $sel->fetchrow_arrayref }; + + my @tuple_status; + $rc = $ins->execute_for_fetch($fetch_tuple_sub, \@tuple_status); + my @errors = grep { ref $_ } @tuple_status; + +Similarly, if you already have an array containing the data rows +to be processed you'd use a subroutine to shift off and return +each array ref in turn: + + $ins->execute_for_fetch( sub { shift @array_of_arrays }, \@tuple_status); + +The C method was added in DBI 1.38. + +=head3 C + + $rv = $sth->last_insert_id(); + $rv = $sth->last_insert_id($catalog, $schema, $table, $field); + $rv = $sth->last_insert_id($catalog, $schema, $table, $field, \%attr); + +Returns a value 'identifying' the row inserted by last execution of the +statement C<$sth>, if possible. + +For some drivers the value may be 'identifying' the row inserted by the +last executed statement, not by C<$sth>. + +See database handle method last_insert_id for all details. + +The C statement method was added in DBI 1.642. + +=head3 C + + $ary_ref = $sth->fetchrow_arrayref; + $ary_ref = $sth->fetch; # alias + +Fetches the next row of data and returns a reference to an array +holding the field values. Null fields are returned as C +values in the array. +This is the fastest way to fetch data, particularly if used with +C<$sth-Ebind_columns>. + +If there are no more rows or if an error occurs, then C +returns an C. You should check C<$sth-Eerr> afterwards (or use the +C attribute) to discover if the C returned was due to an +error. + +Note that the same array reference is returned for each fetch, so don't +store the reference and then use it after a later fetch. Also, the +elements of the array are also reused for each row, so take care if you +want to take a reference to an element. See also L. + +=head3 C + + @ary = $sth->fetchrow_array; + +An alternative to C. Fetches the next row of data +and returns it as a list containing the field values. Null fields +are returned as C values in the list. + +If there are no more rows or if an error occurs, then C +returns an empty list. You should check C<$sth-Eerr> afterwards (or use +the C attribute) to discover if the empty list returned was +due to an error. + +If called in a scalar context for a statement handle that has more +than one column, it is undefined whether the driver will return +the value of the first column or the last. So don't do that. +Also, in a scalar context, an C is returned if there are no +more rows or if an error occurred. That C can't be distinguished +from an C returned because the first field value was NULL. +For these reasons you should exercise some caution if you use +C in a scalar context. + +=head3 C + + $hash_ref = $sth->fetchrow_hashref; + $hash_ref = $sth->fetchrow_hashref($name); + +An alternative to C. Fetches the next row of data +and returns it as a reference to a hash containing field name and field +value pairs. Null fields are returned as C values in the hash. + +If there are no more rows or if an error occurs, then C +returns an C. You should check C<$sth-Eerr> afterwards (or use the +C attribute) to discover if the C returned was due to an +error. + +The optional C<$name> parameter specifies the name of the statement handle +attribute. For historical reasons it defaults to "C", however using +either "C" or "C" is recommended for portability. + +The keys of the hash are the same names returned by C<$sth-E{$name}>. If +more than one field has the same name, there will only be one entry in the +returned hash for those fields, so statements like "C" +or "C statement, the driver will +automatically call C for you. So you should I call it explicitly +I when you know that you've not fetched all the data from a statement +handle I the handle won't be destroyed soon. + +The most common example is when you only want to fetch just one row, +but in that case the C methods are usually better anyway. + +Consider a query like: + + SELECT foo FROM table WHERE bar=? ORDER BY baz + +on a very large table. When executed, the database server will have to use +temporary buffer space to store the sorted rows. If, after executing +the handle and selecting just a few rows, the handle won't be re-executed for +some time and won't be destroyed, the C method can be used to tell +the server that the buffer space can be freed. + +Calling C resets the L attribute for the statement. It +may also make some statement handle attributes (such as C and C) +unavailable if they have not already been accessed (and thus cached). + +The C method does not affect the transaction status of the +database connection. It has nothing to do with transactions. It's mostly an +internal "housekeeping" method that is rarely needed. +See also L and the L attribute. + +The C method should have been called C. + + +=head3 C + + $rv = $sth->rows; + +Returns the number of rows affected by the last row affecting command, +or -1 if the number of rows is not known or not available. + +Generally, you can only rely on a row count after a I-C statement. + +For C statements is not +recommended. + +One alternative method to get a row count for a C statement. Column numbers count up from 1. +You do not need to bind output columns in order to fetch data. +For maximum portability between drivers, bind_col() should be called +after execute() and not before. +See also L for an example. + +The binding is performed at a low level using Perl aliasing. +Whenever a row is fetched from the database $var_to_bind appears +to be automatically updated simply because it now refers to the same +memory location as the corresponding column value. This makes using +bound variables very efficient. +Binding a tied variable doesn't work, currently. + +The L method +performs a similar, but opposite, function for input variables. + +B + +The C<\%attr> parameter can be used to hint at the data type +formatting the column should have. For example, you can use: + + $sth->bind_col(1, undef, { TYPE => SQL_DATETIME }); + +to specify that you'd like the column (which presumably is some +kind of datetime type) to be returned in the standard format for +SQL_DATETIME, which is 'YYYY-MM-DD HH:MM:SS', rather than the +native formatting the database would normally use. + +There's no $var_to_bind in that example to emphasize the point +that bind_col() works on the underlying column and not just +a particular bound variable. + +As a short-cut for the common case, the data type can be passed +directly, in place of the C<\%attr> hash reference. This example is +equivalent to the one above: + + $sth->bind_col(1, undef, SQL_DATETIME); + +The C value indicates the standard (non-driver-specific) type for +this parameter. To specify the driver-specific type, the driver may +support a driver-specific attribute, such as C<{ ora_type =E 97 }>. + +The SQL_DATETIME and other related constants can be imported using + + use DBI qw(:sql_types); + +See L for more information. + +Few drivers support specifying a data type via a C call +(most will simply ignore the data type). Fewer still allow the data +type to be altered once set. If you do set a column type the type +should remain sticky through further calls to bind_col for the same +column if the type is not overridden (this is important for instance +when you are using a slice in fetchall_arrayref). + +The TYPE attribute for bind_col() was first specified in DBI 1.41. + +From DBI 1.611, drivers can use the C attribute to attempt to +cast the bound scalar to a perl type which more closely matches +C. At present DBI supports C, C and +C. See L for details of how types are +cast. + +B + +The C<\%attr> parameter may also contain the following attributes: + +=over + +=item C + +If a C attribute is passed to bind_col, then the driver will +attempt to change the bound perl scalar to match the type more +closely. If the bound value cannot be cast to the requested C +then by default it is left untouched and no error is generated. If you +specify C as 1 and the cast fails, this will generate +an error. + +This attribute was first added in DBI 1.611. When 1.611 was released +few drivers actually supported this attribute but DBD::Oracle and +DBD::ODBC should from versions 1.24. + +=item C + +When the C attribute is passed to L and the driver +successfully casts the bound perl scalar to a non-string type +then if C is set to 1, the string portion of the +scalar will be discarded. By default, C is not set. + +This attribute was first added in DBI 1.611. When 1.611 was released +few drivers actually supported this attribute but DBD::Oracle and +DBD::ODBC should from versions 1.24. + +=back + + +=head3 C + + $rc = $sth->bind_columns(@list_of_refs_to_vars_to_bind); + +Calls L for each column of the C statement. If it doesn't then C will +bind the elements given, up to the number of columns, and then return an error. + +For maximum portability between drivers, bind_columns() should be called +after execute() and not before. + +For example: + + $dbh->{RaiseError} = 1; # do this, or check every call for errors + $sth = $dbh->prepare(q{ SELECT region, sales FROM sales_by_region }); + $sth->execute; + my ($region, $sales); + + # Bind Perl variables to columns: + $rv = $sth->bind_columns(\$region, \$sales); + + # you can also use Perl's \(...) syntax (see perlref docs): + # $sth->bind_columns(\($region, $sales)); + + # Column binding is the most efficient way to fetch data + while ($sth->fetch) { + print "$region: $sales\n"; + } + +For compatibility with old scripts, the first parameter will be +ignored if it is C or a hash reference. + +Here's a more fancy example that binds columns to the values I +a hash (thanks to H.Merijn Brand): + + $sth->execute; + my %row; + $sth->bind_columns (\( @row{ @{$sth->{NAME_lc} }} )); + while ($sth->fetch) { + print "$row{region}: $row{sales}\n"; + } + +but has a small drawback: If data already fetched call to L +will flush current values. If you want to bind_columns after you have fetched +you can use: + + use feature "refaliasing"; + no warnings "experimental::refaliasing"; + while (my $row = $sth->fetchrow_arrayref) { + \(@$data{ $sth->{NAME_lc}->@* }) = \(@$row); + } + +or, with older perl versions: + + use Data::Alias; + alias @$data{ $sth->{NAME_lc}->@* } = @$row; + +This is useful in situations when you have many left joins, but wanna to join +your %$data hash to only subset of fetched values. + +=head3 C + + $rows = $sth->dump_results($maxlen, $lsep, $fsep, $fh); + +Fetches all the rows from C<$sth>, calls C for each row, and +prints the results to C<$fh> (defaults to C) separated by C<$lsep> +(default C<"\n">). C<$fsep> defaults to C<", "> and C<$maxlen> defaults to 35. + +This method is designed as a handy utility for prototyping and +testing queries. Since it uses L to +format and edit the string for reading by humans, it is not recommended +for data transfer applications. + + +=head2 Statement Handle Attributes + +This section describes attributes specific to statement handles. Most +of these attributes are read-only. + +Changes to these statement handle attributes do not affect any other +existing or future statement handles. + +Attempting to set or get the value of an unknown attribute generates a warning, +except for private driver specific attributes (which all have names +starting with a lowercase letter). + +Example: + + ... = $h->{NUM_OF_FIELDS}; # get/read + +Some drivers cannot provide valid values for some or all of these +attributes until after C<$sth-Eexecute> has been successfully +called. Typically the attribute will be C in these situations. + +Some attributes, like NAME, are not appropriate to some types of +statement, like SELECT. Typically the attribute will be C +in these situations. + +For drivers which support stored procedures and multiple result sets +(see L) these attributes relate to the I result set. + +See also L to learn more about the effect it +may have on some attributes. + +=head3 C + +Type: integer, read-only + +Number of fields (columns) in the data the prepared statement may return. +Statements that don't return rows of data, like C and C +set C to 0 (though it may be undef in some drivers). + + +=head3 C + +Type: integer, read-only + +The number of parameters (placeholders) in the prepared statement. +See SUBSTITUTION VARIABLES below for more details. + + +=head3 C + +Type: array-ref, read-only + +Returns a reference to an array of field names for each column. The +names may contain spaces but should not be truncated or have any +trailing space. Note that the names have the letter case (upper, lower +or mixed) as returned by the driver being used. Portable applications +should use L or L. + + print "First column name: $sth->{NAME}->[0]\n"; + +Also note that the name returned for (aggregate) functions like C +or C is determined by the database server and not by C or +the C backend. + +=head3 C + +Type: array-ref, read-only + +Like C but always returns lowercase names. + +=head3 C + +Type: array-ref, read-only + +Like C but always returns uppercase names. + +=head3 C + +Type: hash-ref, read-only + +=head3 C + +Type: hash-ref, read-only + +=head3 C + +Type: hash-ref, read-only + +The C, C, and C attributes +return column name information as a reference to a hash. + +The keys of the hash are the names of the columns. The letter case of +the keys corresponds to the letter case returned by the C, +C, and C attributes respectively (as described above). + +The value of each hash entry is the perl index number of the +corresponding column (counting from 0). For example: + + $sth = $dbh->prepare("select Id, Name from table"); + $sth->execute; + @row = $sth->fetchrow_array; + print "Name $row[ $sth->{NAME_lc_hash}{name} ]\n"; + + +=head3 C + +Type: array-ref, read-only + +Returns a reference to an array of integer values for each +column. The value indicates the data type of the corresponding column. + +The values correspond to the international standards (ANSI X3.135 +and ISO/IEC 9075) which, in general terms, means ODBC. Driver-specific +types that don't exactly match standard types should generally return +the same values as an ODBC driver supplied by the makers of the +database. That might include private type numbers in ranges the vendor +has officially registered with the ISO working group: + + ftp://sqlstandards.org/SC32/SQL_Registry/ + +Where there's no vendor-supplied ODBC driver to be compatible with, +the DBI driver can use type numbers in the range that is now +officially reserved for use by the DBI: -9999 to -9000. + +All possible values for C should have at least one entry in the +output of the C method (see L). + +=head3 C + +Type: array-ref, read-only + +Returns a reference to an array of integer values for each column. + +For numeric columns, the value is the maximum number of digits +(without considering a sign character or decimal point). Note that +the "display size" for floating point types (REAL, FLOAT, DOUBLE) +can be up to 7 characters greater than the precision (for the +sign + decimal point + the letter E + a sign + 2 or 3 digits). + +For any character type column the value is the OCTET_LENGTH, +in other words the number of bytes, not characters. + +(More recent standards refer to this as COLUMN_SIZE but we stick +with PRECISION for backwards compatibility.) + +=head3 C + +Type: array-ref, read-only + +Returns a reference to an array of integer values for each column. +NULL (C) values indicate columns where scale is not applicable. + +=head3 C + +Type: array-ref, read-only + +Returns a reference to an array indicating the possibility of each +column returning a null. Possible values are C<0> +(or an empty string) = no, C<1> = yes, C<2> = unknown. + + print "First column may return NULL\n" if $sth->{NULLABLE}->[0]; + + +=head3 C + +Type: string, read-only + +Returns the name of the cursor associated with the statement handle, if +available. If not available or if the database driver does not support the +C<"where current of ..."> SQL syntax, then it returns C. + + +=head3 C + +Type: dbh, read-only + +Returns the parent $dbh of the statement handle. + + +=head3 C + +Type: string, read-only + +Returns the statement string passed to the L method. + + +=head3 C + +Type: hash ref, read-only + +Returns a reference to a hash containing the values currently bound +to placeholders. The keys of the hash are the 'names' of the +placeholders, typically integers starting at 1. Returns undef if +not supported by the driver. + +See L for an example of how this is used. + +* Keys: + +If the driver supports C but no values have been bound +yet then the driver should return a hash with placeholders names +in the keys but all the values undef, but some drivers may return +a ref to an empty hash because they can't pre-determine the names. + +It is possible that the keys in the hash returned by C +are not exactly the same as those implied by the prepared statement. +For example, DBD::Oracle translates 'C' placeholders into 'C<:pN>' +where N is a sequence number starting at 1. + +* Values: + +It is possible that the values in the hash returned by C +are not I the same as those passed to bind_param() or execute(). +The driver may have slightly modified values in some way based on the +TYPE the value was bound with. For example a floating point value +bound as an SQL_INTEGER type may be returned as an integer. +The values returned by C can be passed to another +bind_param() method with the same TYPE and will be seen by the +database as the same value. See also L below. + +The C attribute was added in DBI 1.28. + +=head3 C + +Type: hash ref, read-only + +Returns a reference to a hash containing the type information +currently bound to placeholders. +Returns undef if not supported by the driver. + +* Keys: + +See L above. + +* Values: + +The hash values are hashrefs of type information in the same form as that +passed to the various bind_param() methods (See L for the format +and values). + +It is possible that the values in the hash returned by C +are not exactly the same as those passed to bind_param() or execute(). +Param attributes specified using the abbreviated form, like this: + + $sth->bind_param(1, SQL_INTEGER); + +are returned in the expanded form, as if called like this: + + $sth->bind_param(1, { TYPE => SQL_INTEGER }); + +The driver may have modified the type information in some way based +on the bound values, other hints provided by the prepare()'d +SQL statement, or alternate type mappings required by the driver or target +database system. The driver may also add private keys (with names beginning +with the drivers reserved prefix, e.g., odbc_xxx). + +* Example: + +The keys and values in the returned hash can be passed to the various +bind_param() methods to effectively reproduce a previous param binding. +For example: + + # assuming $sth1 is a previously prepared statement handle + my $sth2 = $dbh->prepare( $sth1->{Statement} ); + my $ParamValues = $sth1->{ParamValues} || {}; + my $ParamTypes = $sth1->{ParamTypes} || {}; + $sth2->bind_param($_, $ParamValues->{$_}, $ParamTypes->{$_}) + for keys %{ {%$ParamValues, %$ParamTypes} }; + $sth2->execute(); + +The C attribute was added in DBI 1.49. Implementation +is the responsibility of individual drivers; the DBI layer default +implementation simply returns undef. + + +=head3 C + +Type: hash ref, read-only + +Returns a reference to a hash containing the values currently bound to +placeholders with L or L. The +keys of the hash are the 'names' of the placeholders, typically +integers starting at 1. Returns undef if not supported by the driver +or no arrays of parameters are bound. + +Each key value is an array reference containing a list of the bound +parameters for that column. + +For example: + + $sth = $dbh->prepare("INSERT INTO staff (id, name) values (?,?)"); + $sth->execute_array({},[1,2], ['fred','dave']); + if ($sth->{ParamArrays}) { + foreach $param (keys %{$sth->{ParamArrays}}) { + printf "Parameters for %s : %s\n", $param, + join(",", @{$sth->{ParamArrays}->{$param}}); + } + } + +It is possible that the values in the hash returned by C +are not I the same as those passed to L or +L. The driver may have slightly modified values in some +way based on the TYPE the value was bound with. For example a floating +point value bound as an SQL_INTEGER type may be returned as an +integer. + +It is also possible that the keys in the hash returned by +C are not exactly the same as those implied by the +prepared statement. For example, DBD::Oracle translates 'C' +placeholders into 'C<:pN>' where N is a sequence number starting at 1. + +=head3 C + +Type: integer, read-only + +If the driver supports a local row cache for C statement handle that's a child +of the same database handle. A typical way round this is to connect the +the database twice and use one connection for C statement (unlike other data +types), some special handling is required. + +In this situation, the value of the C<$h-E{LongReadLen}> +attribute is used to determine how much buffer space to allocate +when fetching such fields. The C<$h-E{LongTruncOk}> attribute +is used to determine how to behave if a fetched value can't fit +into the buffer. + +See the description of L for more information. + +When trying to insert long or binary values, placeholders should be used +since there are often limits on the maximum size of an C +statement and the L method generally can't cope with binary +data. See L. + + +=head2 Simple Examples + +Here's a complete example program to select and fetch some data: + + my $data_source = "dbi::DriverName:db_name"; + my $dbh = DBI->connect($data_source, $user, $password) + or die "Can't connect to $data_source: $DBI::errstr"; + + my $sth = $dbh->prepare( q{ + SELECT name, phone + FROM mytelbook + }) or die "Can't prepare statement: $DBI::errstr"; + + my $rc = $sth->execute + or die "Can't execute statement: $DBI::errstr"; + + print "Query will return $sth->{NUM_OF_FIELDS} fields.\n\n"; + print "Field names: @{ $sth->{NAME} }\n"; + + while (($name, $phone) = $sth->fetchrow_array) { + print "$name: $phone\n"; + } + # check for problems which may have terminated the fetch early + die $sth->errstr if $sth->err; + + $dbh->disconnect; + +Here's a complete example program to insert some data from a file. +(This example uses C to avoid needing to check each call). + + my $dbh = DBI->connect("dbi:DriverName:db_name", $user, $password, { + RaiseError => 1, AutoCommit => 0 + }); + + my $sth = $dbh->prepare( q{ + INSERT INTO table (name, phone) VALUES (?, ?) + }); + + open FH, ") { + chomp; + my ($name, $phone) = split /,/; + $sth->execute($name, $phone); + } + close FH; + + $dbh->commit; + $dbh->disconnect; + +Here's how to convert fetched NULLs (undefined values) into empty strings: + + while($row = $sth->fetchrow_arrayref) { + # this is a fast and simple way to deal with nulls: + foreach (@$row) { $_ = '' unless defined } + print "@$row\n"; + } + +The C style quoting used in these examples avoids clashing with +quotes that may be used in the SQL statement. Use the double-quote like +C operator if you want to interpolate variables into the string. +See L for more details. + +=head2 Threads and Thread Safety + +Perl 5.7 and later support a new threading model called iThreads. +(The old "5.005 style" threads are not supported by the DBI.) + +In the iThreads model each thread has its own copy of the perl +interpreter. When a new thread is created the original perl +interpreter is 'cloned' to create a new copy for the new thread. + +If the DBI and drivers are loaded and handles created before the +thread is created then it will get a cloned copy of the DBI, the +drivers and the handles. + +However, the internal pointer data within the handles will refer +to the DBI and drivers in the original interpreter. Using those +handles in the new interpreter thread is not safe, so the DBI detects +this and croaks on any method call using handles that don't belong +to the current thread (except for DESTROY). + +Because of this (possibly temporary) restriction, newly created +threads must make their own connections to the database. Handles +can't be shared across threads. + +But BEWARE, some underlying database APIs (the code the DBD driver +uses to talk to the database, often supplied by the database vendor) +are not thread safe. If it's not thread safe, then allowing more +than one thread to enter the code at the same time may cause +subtle/serious problems. In some cases allowing more than +one thread to enter the code, even if I at the same time, +can cause problems. You have been warned. + +Using DBI with perl threads is not yet recommended for production +environments. For more information see +L + +Note: There is a bug in perl 5.8.2 when configured with threads and +debugging enabled (bug #24463) which would cause some DBI tests to fail. +These tests have been disabled for perl-5.8.2 and below. + +Tests for inner method cache are disabled for perl-5.10.x + +=head2 Signal Handling and Canceling Operations + +[The following only applies to systems with unix-like signal handling. +I'd welcome additions for other systems, especially Windows.] + +The first thing to say is that signal handling in Perl versions less +than 5.8 is I safe. There is always a small risk of Perl +crashing and/or core dumping when, or after, handling a signal +because the signal could arrive and be handled while internal data +structures are being changed. If the signal handling code +used those same internal data structures it could cause all manner +of subtle and not-so-subtle problems. The risk was reduced with +5.4.4 but was still present in all perls up through 5.8.0. + +Beginning in perl 5.8.0 perl implements 'safe' signal handling if +your system has the POSIX sigaction() routine. Now when a signal +is delivered perl just makes a note of it but does I run the +%SIG handler. The handling is 'deferred' until a 'safe' moment. + +Although this change made signal handling safe, it also lead to +a problem with signals being deferred for longer than you'd like. +If a signal arrived while executing a system call, such as waiting +for data on a network connection, the signal is noted and then the +system call that was executing returns with an EINTR error code +to indicate that it was interrupted. All fine so far. + +The problem comes when the code that made the system call sees the +EINTR code and decides it's going to call it again. Perl doesn't +do that, but database code sometimes does. If that happens then the +signal handler doesn't get called until later. Maybe much later. + +Fortunately there are ways around this which we'll discuss below. +Unfortunately they make signals unsafe again. + +The two most common uses of signals in relation to the DBI are for +canceling operations when the user types Ctrl-C (interrupt), and for +implementing a timeout using C and C<$SIG{ALRM}>. + +=over 4 + +=item Cancel + +The DBI provides a C method for statement handles. The +C method should abort the current operation and is designed +to be called from a signal handler. For example: + + $SIG{INT} = sub { $sth->cancel }; + +However, few drivers implement this (the DBI provides a default +method that just returns C) and, even if implemented, there +is still a possibility that the statement handle, and even the +parent database handle, will not be usable afterwards. + +If C returns true, then it has successfully +invoked the database engine's own cancel function. If it returns false, +then C failed. If it returns C, then the database +driver does not have cancel implemented - very few do. + +=item Timeout + +The traditional way to implement a timeout is to set C<$SIG{ALRM}> +to refer to some code that will be executed when an ALRM signal +arrives and then to call alarm($seconds) to schedule an ALRM signal +to be delivered $seconds in the future. For example: + + my $failed; + eval { + local $SIG{ALRM} = sub { die "TIMEOUT\n" }; # N.B. \n required + eval { + alarm($seconds); + ... code to execute with timeout here (which may die) ... + 1; + } or $failed = 1; + # outer eval catches alarm that might fire JUST before this alarm(0) + alarm(0); # cancel alarm (if code ran fast) + die "$@" if $failed; + 1; + } or $failed = 1; + if ( $failed ) { + if ( defined $@ and $@ eq "TIMEOUT\n" ) { ... } + else { ... } # some other error + } + +The first (outer) eval is used to avoid the unlikely but possible +chance that the "code to execute" dies and the alarm fires before it +is cancelled. Without the outer eval, if this happened your program +will die if you have no ALRM handler or a non-local alarm handler +will be called. + +Unfortunately, as described above, this won't always work as expected, +depending on your perl version and the underlying database code. + +With Oracle for instance (DBD::Oracle), if the system which hosts +the database is down the DBI->connect() call will hang for several +minutes before returning an error. + +=back + +The solution on these systems is to use the C +routine to gain low level access to how the signal handler is installed. + +The code would look something like this (for the DBD-Oracle connect()): + + use POSIX qw(:signal_h); + + my $mask = POSIX::SigSet->new( SIGALRM ); # signals to mask in the handler + my $action = POSIX::SigAction->new( + sub { die "connect timeout\n" }, # the handler code ref + $mask, + # not using (perl 5.8.2 and later) 'safe' switch or sa_flags + ); + my $oldaction = POSIX::SigAction->new(); + sigaction( SIGALRM, $action, $oldaction ); + my $dbh; + my $failed; + eval { + eval { + alarm(5); # seconds before time out + $dbh = DBI->connect("dbi:Oracle:$dsn" ... ); + 1; + } or $failed = 1; + alarm(0); # cancel alarm (if connect worked fast) + die "$@\n" if $failed; # connect died + 1; + } or $failed = 1; + sigaction( SIGALRM, $oldaction ); # restore original signal handler + if ( $failed ) { + if ( defined $@ and $@ eq "connect timeout\n" ) {...} + else { # connect died } + } + +See previous example for the reasoning around the double eval. + +Similar techniques can be used for canceling statement execution. + +Unfortunately, this solution is somewhat messy, and it does I work with +perl versions less than perl 5.8 where C appears to be broken. + +For a cleaner implementation that works across perl versions, see Lincoln Baxter's +Sys::SigAction module at L. +The documentation for Sys::SigAction includes an longer discussion +of this problem, and a DBD::Oracle test script. + +Be sure to read all the signal handling sections of the L manual. + +And finally, two more points to keep firmly in mind. Firstly, +remember that what we've done here is essentially revert to old +style I handling of these signals. So do as little as +possible in the handler. Ideally just die(). Secondly, the handles +in use at the time the signal is handled may not be safe to use +afterwards. + + +=head2 Subclassing the DBI + +DBI can be subclassed and extended just like any other object +oriented module. Before we talk about how to do that, it's important +to be clear about the various DBI classes and how they work together. + +By default C<$dbh = DBI-Econnect(...)> returns a $dbh blessed +into the C class. And the C<$dbh-Eprepare> method +returns an $sth blessed into the C class (actually it +simply changes the last four characters of the calling handle class +to be C<::st>). + +The leading 'C' is known as the 'root class' and the extra +'C<::db>' or 'C<::st>' are the 'handle type suffixes'. If you want +to subclass the DBI you'll need to put your overriding methods into +the appropriate classes. For example, if you want to use a root class +of C and override the do(), prepare() and execute() methods, +then your do() and prepare() methods should be in the C +class and the execute() method should be in the C class. + +To setup the inheritance hierarchy the @ISA variable in C +should include C and the @ISA variable in C +should include C. The C root class itself isn't +currently used for anything visible and so, apart from setting @ISA +to include C, it can be left empty. + +So, having put your overriding methods into the right classes, and +setup the inheritance hierarchy, how do you get the DBI to use them? +You have two choices, either a static method call using the name +of your subclass: + + $dbh = MySubDBI->connect(...); + +or specifying a C attribute: + + $dbh = DBI->connect(..., { RootClass => 'MySubDBI' }); + +If both forms are used then the attribute takes precedence. + +The only differences between the two are that using an explicit +RootClass attribute will a) make the DBI automatically attempt to load +a module by that name if the class doesn't exist, and b) won't call +your MySubDBI::connect() method, if you have one. + +When subclassing is being used then, after a successful new +connect, the DBI->connect method automatically calls: + + $dbh->connected($dsn, $user, $pass, \%attr); + +The default method does nothing. The call is made just to simplify +any post-connection setup that your subclass may want to perform. +The parameters are the same as passed to DBI->connect. +If your subclass supplies a connected method, it should be part of the +MySubDBI::db package. + +One more thing to note: you must let the DBI do the handle creation. If you +want to override the connect() method in your *::dr class then it must still +call SUPER::connect to get a $dbh to work with. Similarly, an overridden +prepare() method in *::db must still call SUPER::prepare to get a $sth. +If you try to create your own handles using bless() then you'll find the DBI +will reject them with an "is not a DBI handle (has no magic)" error. + +Here's a brief example of a DBI subclass. A more thorough example +can be found in F in the DBI distribution. + + package MySubDBI; + + use strict; + + use DBI; + our @ISA = qw(DBI); + + package MySubDBI::db; + our @ISA = qw(DBI::db); + + sub prepare { + my ($dbh, @args) = @_; + my $sth = $dbh->SUPER::prepare(@args) + or return; + $sth->{private_mysubdbi_info} = { foo => 'bar' }; + return $sth; + } + + package MySubDBI::st; + our @ISA = qw(DBI::st); + + sub fetch { + my ($sth, @args) = @_; + my $row = $sth->SUPER::fetch(@args) + or return; + do_something_magical_with_row_data($row) + or return $sth->set_err(1234, "The magic failed", undef, "fetch"); + return $row; + } + +When calling a SUPER::method that returns a handle, be careful to +check the return value before trying to do other things with it in +your overridden method. This is especially important if you want to +set a hash attribute on the handle, as Perl's autovivification will +bite you by (in)conveniently creating an unblessed hashref, which your +method will then return with usually baffling results later on like +the error "dbih_getcom handle HASH(0xa4451a8) is not a DBI handle (has +no magic". It's best to check right after the call and return undef +immediately on error, just like DBI would and just like the example +above. + +If your method needs to record an error it should call the set_err() +method with the error code and error string, as shown in the example +above. The error code and error string will be recorded in the +handle and available via C<$h-Eerr> and C<$DBI::errstr> etc. +The set_err() method always returns an undef or empty list as +appropriate. Since your method should nearly always return an undef +or empty list as soon as an error is detected it's handy to simply +return what set_err() returns, as shown in the example above. + +If the handle has C, C, or C +etc. set then the set_err() method will honour them. This means +that if C is set then set_err() won't return in the +normal way but will 'throw an exception' that can be caught with +an C block. + +You can stash private data into DBI handles +via C<$h-E{private_..._*}>. See the entry under L for info and important caveats. + +=head2 Memory Leaks + +When tracking down memory leaks using tools like L +you'll find that some DBI internals are reported as 'leaking' memory. +This is very unlikely to be a real leak. The DBI has various caches to improve +performance and the apparrent leaks are simply the normal operation of these +caches. + +The most frequent sources of the apparrent leaks are L, +L and L. + +For example http://stackoverflow.com/questions/13338308/perl-dbi-memory-leak + +Given how widely the DBI is used, you can rest assured that if a new release of +the DBI did have a real leak it would be discovered, reported, and fixed +immediately. The leak you're looking for is probably elsewhere. Good luck! + + +=head1 TRACING + +The DBI has a powerful tracing mechanism built in. It enables you +to see what's going on 'behind the scenes', both within the DBI and +the drivers you're using. + +=head2 Trace Settings + +Which details are written to the trace output is controlled by a +combination of a I, an integer from 0 to 15, and a set +of I that are either on or off. Together these are known +as the I and are stored together in a single integer. +For normal use you only need to set the trace level, and generally +only to a value between 1 and 4. + +Each handle has its own trace settings, and so does the DBI. +When you call a method the DBI merges the handles settings into its +own for the duration of the call: the trace flags of the handle are +OR'd into the trace flags of the DBI, and if the handle has a higher +trace level then the DBI trace level is raised to match it. +The previous DBI trace settings are restored when the called method +returns. + +=head2 Trace Levels + +Trace I are as follows: + + 0 - Trace disabled. + 1 - Trace top-level DBI method calls returning with results or errors. + 2 - As above, adding tracing of top-level method entry with parameters. + 3 - As above, adding some high-level information from the driver + and some internal information from the DBI. + 4 - As above, adding more detailed information from the driver. + This is the first level to trace all the rows being fetched. + 5 to 15 - As above but with more and more internal information. + +Trace level 1 is best for a simple overview of what's happening. +Trace levels 2 thru 4 a good choice for general purpose tracing. +Levels 5 and above are best reserved for investigating a specific +problem, when you need to see "inside" the driver and DBI. + +The trace output is detailed and typically very useful. Much of the +trace output is formatted using the L function, so strings +in the trace output may be edited and truncated by that function. + +=head2 Trace Flags + +Trace I are used to enable tracing of specific activities +within the DBI and drivers. The DBI defines some trace flags and +drivers can define others. DBI trace flag names begin with a capital +letter and driver specific names begin with a lowercase letter, as +usual. + +Currently the DBI defines these trace flags: + + ALL - turn on all DBI and driver flags (not recommended) + SQL - trace SQL statements executed + (not yet implemented in DBI but implemented in some DBDs) + CON - trace connection process + ENC - trace encoding (unicode translations etc) + (not yet implemented in DBI but implemented in some DBDs) + DBD - trace only DBD messages + (not implemented by all DBDs yet) + TXN - trace transactions + (not implemented in all DBDs yet) + +The L and L methods are used +to convert trace flag names into the corresponding integer bit flags. + +=head2 Enabling Trace + +The C<$h-Etrace> method sets the trace settings for a handle +and Ctrace> does the same for the DBI. + +In addition to the L method, you can enable the same trace +information, and direct the output to a file, by setting the +C environment variable before starting Perl. +See L for more information. + +Finally, you can set, or get, the trace settings for a handle using +the C attribute. + +All of those methods use parse_trace_flags() and so allow you set +both the trace level and multiple trace flags by using a string +containing the trace level and/or flag names separated by vertical +bar ("C<|>") or comma ("C<,>") characters. For example: + + local $h->{TraceLevel} = "3|SQL|foo"; + +=head2 Trace Output + +Initially trace output is written to C. Both the +C<$h-Etrace> and Ctrace> methods take an optional +$trace_file parameter, which may be either the name of a file to be +opened by DBI in append mode, or a reference to an existing writable +(possibly layered) filehandle. If $trace_file is a filename, +and can be opened in append mode, or $trace_file is a writable +filehandle, then I trace output (currently including that from +other handles) is redirected to that file. A warning is generated +if $trace_file can't be opened or is not writable. + +Further calls to trace() without $trace_file do not alter where +the trace output is sent. If $trace_file is undefined, then +trace output is sent to C and, if the prior trace was opened with +$trace_file as a filename, the previous trace file is closed; if $trace_file was +a filehandle, the filehandle is B closed. + +B: If $trace_file is specified as a filehandle, the filehandle +should not be closed until all DBI operations are completed, or the +application has reset the trace file via another call to +C that changes the trace file. + +=head2 Tracing to Layered Filehandles + +B: + +=over 4 + +=item * +Tied filehandles are not currently supported, as +tie operations are not available to the PerlIO +methods used by the DBI. + +=item * +PerlIO layer support requires Perl version 5.8 or higher. + +=back + +As of version 5.8, Perl provides the ability to layer various +"disciplines" on an open filehandle via the L module. + +A simple example of using PerlIO layers is to use a scalar as the output: + + my $scalar = ''; + open( my $fh, "+>:scalar", \$scalar ); + $dbh->trace( 2, $fh ); + +Now all trace output is simply appended to $scalar. + +A more complex application of tracing to a layered filehandle is the +use of a custom layer (IL I). Consider an application with the +following logger module: + + package MyFancyLogger; + + sub new + { + my $self = {}; + my $fh; + open $fh, '>', 'fancylog.log'; + $self->{_fh} = $fh; + $self->{_buf} = ''; + return bless $self, shift; + } + + sub log + { + my $self = shift; + return unless exists $self->{_fh}; + my $fh = $self->{_fh}; + $self->{_buf} .= shift; + # + # DBI feeds us pieces at a time, so accumulate a complete line + # before outputting + # + print $fh "At ", scalar localtime(), ':', $self->{_buf}, "\n" and + $self->{_buf} = '' + if $self->{_buf}=~tr/\n//; + } + + sub close { + my $self = shift; + return unless exists $self->{_fh}; + my $fh = $self->{_fh}; + print $fh "At ", scalar localtime(), ':', $self->{_buf}, "\n" and + $self->{_buf} = '' + if $self->{_buf}; + close $fh; + delete $self->{_fh}; + } + + 1; + +To redirect DBI traces to this logger requires creating +a package for the layer: + + package PerlIO::via::MyFancyLogLayer; + + sub PUSHED + { + my ($class,$mode,$fh) = @_; + my $logger; + return bless \$logger,$class; + } + + sub OPEN { + my ($self, $path, $mode, $fh) = @_; + # + # $path is actually our logger object + # + $$self = $path; + return 1; + } + + sub WRITE + { + my ($self, $buf, $fh) = @_; + $$self->log($buf); + return length($buf); + } + + sub CLOSE { + my $self = shift; + $$self->close(); + return 0; + } + + 1; + + +The application can then cause DBI traces to be routed to the +logger using + + use PerlIO::via::MyFancyLogLayer; + + open my $fh, '>:via(MyFancyLogLayer)', MyFancyLogger->new(); + + $dbh->trace('SQL', $fh); + +Now all trace output will be processed by MyFancyLogger's +log() method. + +=head2 Trace Content + +Many of the values embedded in trace output are formatted using the neat() +utility function. This means they may be quoted, sanitized, and possibly +truncated if longer than C<$DBI::neat_maxlen>. See L for more details. + +=head2 Tracing Tips + +You can add tracing to your own application code using the L method. + +It can sometimes be handy to compare trace files from two different runs of the +same script. However using a tool like C on the original log output +doesn't work well because the trace file is full of object addresses that may +differ on each run. + +The DBI includes a handy utility called dbilogstrip that can be used to +'normalize' the log content. It can be used as a filter like this: + + DBI_TRACE=2 perl yourscript.pl ...args1... 2>&1 | dbilogstrip > dbitrace1.log + DBI_TRACE=2 perl yourscript.pl ...args2... 2>&1 | dbilogstrip > dbitrace2.log + diff -u dbitrace1.log dbitrace2.log + +See L for more information. + +=head1 DBI ENVIRONMENT VARIABLES + +The DBI module recognizes a number of environment variables, but most of +them should not be used most of the time. +It is better to be explicit about what you are doing to avoid the need +for environment variables, especially in a web serving system where web +servers are stingy about which environment variables are available. + +=head2 DBI_DSN + +The DBI_DSN environment variable is used by DBI->connect if you do not +specify a data source when you issue the connect. +It should have a format such as "dbi:Driver:databasename". + +=head2 DBI_DRIVER + +The DBI_DRIVER environment variable is used to fill in the database +driver name in DBI->connect if the data source string starts "dbi::" +(thereby omitting the driver). +If DBI_DSN omits the driver name, DBI_DRIVER can fill the gap. + +=head2 DBI_AUTOPROXY + +The DBI_AUTOPROXY environment variable takes a string value that starts +"dbi:Proxy:" and is typically followed by "hostname=...;port=...". +It is used to alter the behaviour of DBI->connect. +For full details, see DBI::Proxy documentation. + +=head2 DBI_USER + +The DBI_USER environment variable takes a string value that is used as +the user name if the DBI->connect call is given undef (as distinct from +an empty string) as the username argument. +Be wary of the security implications of using this. + +=head2 DBI_PASS + +The DBI_PASS environment variable takes a string value that is used as +the password if the DBI->connect call is given undef (as distinct from +an empty string) as the password argument. +Be extra wary of the security implications of using this. + +=head2 DBI_DBNAME (obsolete) + +The DBI_DBNAME environment variable takes a string value that is used only when the +obsolescent style of DBI->connect (with driver name as fourth parameter) is used, and +when no value is provided for the first (database name) argument. + +=head2 DBI_TRACE + +The DBI_TRACE environment variable specifies the global default +trace settings for the DBI at startup. Can also be used to direct +trace output to a file. When the DBI is loaded it does: + + DBI->trace(split /=/, $ENV{DBI_TRACE}, 2) if $ENV{DBI_TRACE}; + +So if C contains an "C<=>" character then what follows +it is used as the name of the file to append the trace to. + +output appended to that file. If the name begins with a number +followed by an equal sign (C<=>), then the number and the equal sign are +stripped off from the name, and the number is used to set the trace +level. For example: + + DBI_TRACE=1=dbitrace.log perl your_test_script.pl + +On Unix-like systems using a Bourne-like shell, you can do this easily +on the command line: + + DBI_TRACE=2 perl your_test_script.pl + +See L for more information. + +=head2 PERL_DBI_DEBUG (obsolete) + +An old variable that should no longer be used; equivalent to DBI_TRACE. + +=head2 DBI_PROFILE + +The DBI_PROFILE environment variable can be used to enable profiling +of DBI method calls. See L for more information. + +=head2 DBI_PUREPERL + +The DBI_PUREPERL environment variable can be used to enable the +use of DBI::PurePerl. See L for more information. + +=head1 WARNING AND ERROR MESSAGES + +=head2 Fatal Errors + +=over 4 + +=item Can't call method "prepare" without a package or object reference + +The C<$dbh> handle you're using to call C is probably undefined because +the preceding C failed. You should always check the return status of +DBI methods, or use the L attribute. + +=item Can't call method "execute" without a package or object reference + +The C<$sth> handle you're using to call C is probably undefined because +the preceding C failed. You should always check the return status of +DBI methods, or use the L attribute. + +=item DBI/DBD internal version mismatch + +The DBD driver module was built with a different version of DBI than +the one currently being used. You should rebuild the DBD module under +the current version of DBI. + +(Some rare platforms require "static linking". On those platforms, there +may be an old DBI or DBD driver version actually embedded in the Perl +executable being used.) + +=item DBD driver has not implemented the AutoCommit attribute + +The DBD driver implementation is incomplete. Consult the author. + +=item Can't [sg]et %s->{%s}: unrecognised attribute + +You attempted to set or get an unknown attribute of a handle. Make +sure you have spelled the attribute name correctly; case is significant +(e.g., "Autocommit" is not the same as "AutoCommit"). + +=back + +=head1 Pure-Perl DBI + +A pure-perl emulation of the DBI is included in the distribution +for people using pure-perl drivers who, for whatever reason, can't +install the compiled DBI. See L. + +=head1 SEE ALSO + +=head2 Driver and Database Documentation + +Refer to the documentation for the DBD driver that you are using. + +Refer to the SQL Language Reference Manual for the database engine that you are using. + +=head2 ODBC and SQL/CLI Standards Reference Information + +More detailed information about the semantics of certain DBI methods +that are based on ODBC and SQL/CLI standards is available on-line +via microsoft.com, for ODBC, and www.jtc1sc32.org for the SQL/CLI +standard: + + DBI method ODBC function SQL/CLI Working Draft + ---------- ------------- --------------------- + column_info SQLColumns Page 124 + foreign_key_info SQLForeignKeys Page 163 + get_info SQLGetInfo Page 214 + primary_key_info SQLPrimaryKeys Page 254 + table_info SQLTables Page 294 + type_info SQLGetTypeInfo Page 239 + statistics_info SQLStatistics + +To find documentation on the ODBC function you can use +the MSDN search facility at: + + http://msdn.microsoft.com/Search + +and search for something like C<"SQLColumns returns">. + +And for SQL/CLI standard information on SQLColumns you'd read page 124 of +the (very large) SQL/CLI Working Draft available from: + + http://jtc1sc32.org/doc/N0701-0750/32N0744T.pdf + +=head2 Standards Reference Information + +A hyperlinked, browsable version of the BNF syntax for SQL92 (plus +Oracle 7 SQL and PL/SQL) is available here: + + http://cui.unige.ch/db-research/Enseignement/analyseinfo/SQL92/BNFindex.html + +You can find more information about SQL standards online by searching for the +appropriate standard names and numbers. For example, searching for +"ANSI/ISO/IEC International Standard (IS) Database Language SQL - Part 1: +SQL/Framework" you'll find a copy at: + + ftp://ftp.iks-jena.de/mitarb/lutz/standards/sql/ansi-iso-9075-1-1999.pdf + +=head2 Books and Articles + +Programming the Perl DBI, by Alligator Descartes and Tim Bunce. +L + +Programming Perl 3rd Ed. by Larry Wall, Tom Christiansen & Jon Orwant. +L + +Learning Perl by Randal Schwartz. +L + +Details of many other books related to perl can be found at L + +=head2 Perl Modules + +Index of DBI related modules available from CPAN: + + L + L + L + +For a good comparison of RDBMS-OO mappers and some OO-RDBMS mappers +(including Class::DBI, Alzabo, and DBIx::RecordSet in the former +category and Tangram and SPOPS in the latter) see the Perl +Object-Oriented Persistence project pages at: + + http://poop.sourceforge.net + +A similar page for Java toolkits can be found at: + + http://c2.com/cgi-bin/wiki?ObjectRelationalToolComparison + +=head2 Mailing List + +The I mailing list is the primary means of communication among +users of the DBI and its related modules. For details send email to: + + L + +There are typically between 700 and 900 messages per month. You have +to subscribe in order to be able to post. However you can opt for a +'post-only' subscription. + +Mailing list archives (of variable quality) are held at: + + http://groups.google.com/groups?group=perl.dbi.users + http://www.xray.mpe.mpg.de/mailing-lists/dbi/ + http://www.mail-archive.com/dbi-users%40perl.org/ + +=head2 Assorted Related Links + +The DBI "Home Page": + + http://dbi.perl.org/ + +Other DBI related links: + + http://www.perlmonks.org/?node=DBI%20recipes + http://www.perlmonks.org/?node=Speeding%20up%20the%20DBI + +Other database related links: + + http://www.connectionstrings.com/ + +Security, especially the "SQL Injection" attack: + + http://bobby-tables.com/ + http://online.securityfocus.com/infocus/1644 + + +=head2 FAQ + +See L + +=head1 AUTHORS + +DBI by Tim Bunce (1994-2024), The DBI developer group (2024..) + +This pod text by Tim Bunce, J. Douglas Dunlop, Jonathan Leffler and others. +Perl by Larry Wall and the C. + +=head1 COPYRIGHT + +The DBI module is Copyright (c) 1994-2024 Tim Bunce. Ireland. +The DBI developer group (2024-2024) All rights reserved. + +You may distribute under the terms of either the GNU General Public +License or the Artistic License, as specified in the Perl 5.10.0 README file. + +=head1 SUPPORT / WARRANTY + +The DBI is free Open Source software. IT COMES WITHOUT WARRANTY OF ANY KIND. + +=head2 Support + +My consulting company, Data Plan Services, offers annual and +multi-annual support contracts for the DBI. These provide sustained +support for DBI development, and sustained value for you in return. +Contact me for details. + +=head2 Sponsor Enhancements + +If your company would benefit from a specific new DBI feature, +please consider sponsoring its development. Work is performed +rapidly, and usually on a fixed-price payment-on-delivery basis. +Contact me for details. + +Using such targeted financing allows you to contribute to DBI +development, and rapidly get something specific and valuable in return. + +=head1 ACKNOWLEDGEMENTS + +I would like to acknowledge the valuable contributions of the many +people I have worked with on the DBI project, especially in the early +years (1992-1994). In no particular order: Kevin Stock, Buzz Moschetti, +Kurt Andersen, Ted Lemon, William Hails, Garth Kennedy, Michael Peppler, +Neil S. Briscoe, Jeff Urlwin, David J. Hughes, Jeff Stander, +Forrest D Whitcher, Larry Wall, Jeff Fried, Roy Johnson, Paul Hudson, +Georg Rehfeld, Steve Sizemore, Ron Pool, Jon Meek, Tom Christiansen, +Steve Baumgarten, Randal Schwartz, and a whole lot more. + +Then, of course, there are the poor souls who have struggled through +untold and undocumented obstacles to actually implement DBI drivers. +Among their ranks are Jochen Wiedmann, Alligator Descartes, Jonathan +Leffler, Jeff Urlwin, Michael Peppler, Henrik Tougaard, Edwin Pratomo, +Davide Migliavacca, Jan Pazdziora, Peter Haworth, Edmund Mergl, Steve +Williams, Thomas Lowery, and Phlip Plumlee. Without them, the DBI would +not be the practical reality it is today. I'm also especially grateful +to Alligator Descartes for starting work on the first edition of the +"Programming the Perl DBI" book and letting me jump on board. + +The DBI and DBD::Oracle were originally developed while I was Technical +Director (CTO) of the Paul Ingram Group in the UK. So I'd especially like +to thank Paul for his generosity and vision in supporting this work for many years. + +A couple of specific DBI features have been sponsored by enlightened companies: + +The development of the swap_inner_handle() method was sponsored by BizRate.com (L) + +The development of DBD::Gofer and related modules was sponsored by Shopzilla.com (L). + +=head1 CONTRIBUTING + +As you can see above, many people have contributed to the DBI and +drivers in many ways over many years. + +If you'd like to help then see L. + +If you'd like the DBI to do something new or different then a good way +to make that happen is to do it yourself and send me a patch to the +source code that shows the changes. (But read "Speak before you patch" +below.) + +=head2 Browsing the source code repository + +Use https://github.com/perl5-dbi/dbi + +=head2 How to create a patch using Git + +The DBI source code is maintained using Git. To access the source +you'll need to install a Git client. Then, to get the source code, do: + + git clone https://github.com/perl5-dbi/dbi.git DBI-git + +The source code will now be available in the new subdirectory C. + +When you want to synchronize later, issue the command + + git pull --all + +Make your changes, test them, test them again until everything passes. +If there are no tests for the new feature you added or a behaviour change, +the change should include a new test. Then commit the changes. Either use + + git gui + +or + + git commit -a -m 'Message to my changes' + +If you get any conflicts reported you'll need to fix them first. + +Then generate the patch file to be mailed: + + git format-patch -1 --attach + +which will create a file 0001-*.patch (where * relates to the commit message). +Read the patch file, as a sanity check, and then email it to dbi-dev@perl.org. + +If you have a L account, you can also fork the +repository, commit your changes to the forked repository and then do a +pull request. + +=head2 How to create a patch without Git + +Unpack a fresh copy of the distribution: + + wget http://cpan.metacpan.org/authors/id/T/TI/TIMB/DBI-1.627.tar.gz + tar xfz DBI-1.627.tar.gz + +Rename the newly created top level directory: + + mv DBI-1.627 DBI-1.627.your_foo + +Edit the contents of DBI-1.627.your_foo/* till it does what you want. + +Test your changes and then remove all temporary files: + + make test && make distclean + +Go back to the directory you originally unpacked the distribution: + + cd .. + +Unpack I copy of the original distribution you started with: + + tar xfz DBI-1.627.tar.gz + +Then create a patch file by performing a recursive C on the two +top level directories: + + diff -purd DBI-1.627 DBI-1.627.your_foo > DBI-1.627.your_foo.patch + +=head2 Speak before you patch + +For anything non-trivial or possibly controversial it's a good idea +to discuss (on dbi-dev@perl.org) the changes you propose before +actually spending time working on them. Otherwise you run the risk +of them being rejected because they don't fit into some larger plans +you may not be aware of. + +You can also reach the developers on IRC (chat). If they are on-line, +the most likely place to talk to them is the #dbi channel on irc.perl.org + +=head1 TRANSLATIONS + +A German translation of this manual (possibly slightly out of date) is +available, thanks to O'Reilly, at: + + http://www.oreilly.de/catalog/perldbiger/ + +=head1 OTHER RELATED WORK AND PERL MODULES + +=over 4 + +=item L + +To be used with the Apache daemon together with an embedded Perl +interpreter like C. Establishes a database connection which +remains open for the lifetime of the HTTP daemon. This way the CGI +connect and disconnect for every database access becomes superfluous. + +=item SQL Parser + +See also the L module, SQL parser and engine. + +=back + +=head1 TODO + +=head2 Documentation + +These entries are still to be written: + +=over 2 + + +=item DBIf_TRACE_CON + +=item DBIf_TRACE_DBD + +=item DBIf_TRACE_ENC + +=item DBIf_TRACE_SQL + +=item DBIf_TRACE_TXN + +=item DBIpp_cm_XX + +=item DBIpp_cm_br + +=item DBIpp_cm_cs + +=item DBIpp_cm_dd + +=item DBIpp_cm_dw + +=item DBIpp_cm_hs + +=item DBIpp_ph_XX + +=item DBIpp_ph_cn + +=item DBIpp_ph_cs + +=item DBIpp_ph_qm + +=item DBIpp_ph_sp + +=item DBIpp_st_XX + +=item DBIpp_st_bs + +=item DBIpp_st_qq + +=item SQL_ALL_TYPES + +=item SQL_ARRAY + +=item SQL_ARRAY_LOCATOR + +=item SQL_BIGINT + +=item SQL_BINARY + +=item SQL_BIT + +=item SQL_BLOB + +=item SQL_BLOB_LOCATOR + +=item SQL_BOOLEAN + +=item SQL_CHAR + +=item SQL_CLOB + +=item SQL_CLOB_LOCATOR + +=item SQL_CURSOR_DYNAMIC + +=item SQL_CURSOR_FORWARD_ONLY + +=item SQL_CURSOR_KEYSET_DRIVEN + +=item SQL_CURSOR_STATIC + +=item SQL_CURSOR_TYPE_DEFAULT + +=item SQL_DATE + +=item SQL_DATETIME + +=item SQL_DECIMAL + +=item SQL_DOUBLE + +=item SQL_FLOAT + +=item SQL_GUID + +=item SQL_INTEGER + +=item SQL_INTERVAL + +=item SQL_INTERVAL_DAY + +=item SQL_INTERVAL_DAY_TO_HOUR + +=item SQL_INTERVAL_DAY_TO_MINUTE + +=item SQL_INTERVAL_DAY_TO_SECOND + +=item SQL_INTERVAL_HOUR + +=item SQL_INTERVAL_HOUR_TO_MINUTE + +=item SQL_INTERVAL_HOUR_TO_SECOND + +=item SQL_INTERVAL_MINUTE + +=item SQL_INTERVAL_MINUTE_TO_SECOND + +=item SQL_INTERVAL_MONTH + +=item SQL_INTERVAL_SECOND + +=item SQL_INTERVAL_YEAR + +=item SQL_INTERVAL_YEAR_TO_MONTH + +=item SQL_LONGVARBINARY + +=item SQL_LONGVARCHAR + +=item SQL_MULTISET + +=item SQL_MULTISET_LOCATOR + +=item SQL_NUMERIC + +=item SQL_REAL + +=item SQL_REF + +=item SQL_ROW + +=item SQL_SMALLINT + +=item SQL_TIME + +=item SQL_TIMESTAMP + +=item SQL_TINYINT + +=item SQL_TYPE_DATE + +=item SQL_TYPE_TIME + +=item SQL_TYPE_TIMESTAMP + +=item SQL_TYPE_TIMESTAMP_WITH_TIMEZONE + +=item SQL_TYPE_TIME_WITH_TIMEZONE + +=item SQL_UDT + +=item SQL_UDT_LOCATOR + +=item SQL_UNKNOWN_TYPE + +=item SQL_VARBINARY + +=item SQL_VARCHAR + +=item SQL_WCHAR + +=item SQL_WLONGVARCHAR + +=item SQL_WVARCHAR + +=item connect_test_perf + +=item constant + +=item dbi_profile + +=item dbi_profile_merge + +=item dbi_profile_merge_nodes + +=item dbi_time + +=item disconnect_all + +=item driver_prefix + +=item dump_dbd_registry + +=item dump_handle + +=item init_rootclass + +=item install_driver + +=item installed_methods + +=item setup_driver + +=back + +=cut + +# LocalWords: DBI diff --git a/src/main/perl/lib/DBI/PurePerl.pm b/src/main/perl/lib/DBI/PurePerl.pm new file mode 100644 index 000000000..36a94e20b --- /dev/null +++ b/src/main/perl/lib/DBI/PurePerl.pm @@ -0,0 +1,1279 @@ +######################################################################## +package # hide from PAUSE + DBI; +# vim: ts=8:sw=4 +######################################################################## +# +# Copyright (c) 2002,2003 Tim Bunce Ireland. +# +# See COPYRIGHT section in DBI.pm for usage and distribution rights. +# +######################################################################## +# +# Please send patches and bug reports to +# +# Jeff Zucker with cc to +# +######################################################################## + +use strict; +use warnings; +use Carp; +require Symbol; + +$DBI::PurePerl = $ENV{DBI_PUREPERL} || 1; +$DBI::PurePerl::VERSION = "2.014286"; + +$DBI::neat_maxlen ||= 400; + +$DBI::tfh = Symbol::gensym(); +open $DBI::tfh, ">&STDERR" or warn "Can't dup STDERR: $!"; +select( (select($DBI::tfh), $| = 1)[0] ); # autoflush + +# check for weaken support, used by ChildHandles +my $HAS_WEAKEN = eval { + require Scalar::Util; + # this will croak() if this Scalar::Util doesn't have a working weaken(). + Scalar::Util::weaken( my $test = [] ); + 1; +}; + +%DBI::last_method_except = map { $_=>1 } qw(DESTROY _set_fbav set_err); + +use constant SQL_ALL_TYPES => 0; +use constant SQL_ARRAY => 50; +use constant SQL_ARRAY_LOCATOR => 51; +use constant SQL_BIGINT => (-5); +use constant SQL_BINARY => (-2); +use constant SQL_BIT => (-7); +use constant SQL_BLOB => 30; +use constant SQL_BLOB_LOCATOR => 31; +use constant SQL_BOOLEAN => 16; +use constant SQL_CHAR => 1; +use constant SQL_CLOB => 40; +use constant SQL_CLOB_LOCATOR => 41; +use constant SQL_DATE => 9; +use constant SQL_DATETIME => 9; +use constant SQL_DECIMAL => 3; +use constant SQL_DOUBLE => 8; +use constant SQL_FLOAT => 6; +use constant SQL_GUID => (-11); +use constant SQL_INTEGER => 4; +use constant SQL_INTERVAL => 10; +use constant SQL_INTERVAL_DAY => 103; +use constant SQL_INTERVAL_DAY_TO_HOUR => 108; +use constant SQL_INTERVAL_DAY_TO_MINUTE => 109; +use constant SQL_INTERVAL_DAY_TO_SECOND => 110; +use constant SQL_INTERVAL_HOUR => 104; +use constant SQL_INTERVAL_HOUR_TO_MINUTE => 111; +use constant SQL_INTERVAL_HOUR_TO_SECOND => 112; +use constant SQL_INTERVAL_MINUTE => 105; +use constant SQL_INTERVAL_MINUTE_TO_SECOND => 113; +use constant SQL_INTERVAL_MONTH => 102; +use constant SQL_INTERVAL_SECOND => 106; +use constant SQL_INTERVAL_YEAR => 101; +use constant SQL_INTERVAL_YEAR_TO_MONTH => 107; +use constant SQL_LONGVARBINARY => (-4); +use constant SQL_LONGVARCHAR => (-1); +use constant SQL_MULTISET => 55; +use constant SQL_MULTISET_LOCATOR => 56; +use constant SQL_NUMERIC => 2; +use constant SQL_REAL => 7; +use constant SQL_REF => 20; +use constant SQL_ROW => 19; +use constant SQL_SMALLINT => 5; +use constant SQL_TIME => 10; +use constant SQL_TIMESTAMP => 11; +use constant SQL_TINYINT => (-6); +use constant SQL_TYPE_DATE => 91; +use constant SQL_TYPE_TIME => 92; +use constant SQL_TYPE_TIMESTAMP => 93; +use constant SQL_TYPE_TIMESTAMP_WITH_TIMEZONE => 95; +use constant SQL_TYPE_TIME_WITH_TIMEZONE => 94; +use constant SQL_UDT => 17; +use constant SQL_UDT_LOCATOR => 18; +use constant SQL_UNKNOWN_TYPE => 0; +use constant SQL_VARBINARY => (-3); +use constant SQL_VARCHAR => 12; +use constant SQL_WCHAR => (-8); +use constant SQL_WLONGVARCHAR => (-10); +use constant SQL_WVARCHAR => (-9); + +# for Cursor types +use constant SQL_CURSOR_FORWARD_ONLY => 0; +use constant SQL_CURSOR_KEYSET_DRIVEN => 1; +use constant SQL_CURSOR_DYNAMIC => 2; +use constant SQL_CURSOR_STATIC => 3; +use constant SQL_CURSOR_TYPE_DEFAULT => SQL_CURSOR_FORWARD_ONLY; + +use constant IMA_HAS_USAGE => 0x0001; #/* check parameter usage */ +use constant IMA_FUNC_REDIRECT => 0x0002; #/* is $h->func(..., "method")*/ +use constant IMA_KEEP_ERR => 0x0004; #/* don't reset err & errstr */ +use constant IMA_KEEP_ERR_SUB => 0x0008; #/* '' if in nested call */ +use constant IMA_NO_TAINT_IN => 0x0010; #/* don't check for tainted args*/ +use constant IMA_NO_TAINT_OUT => 0x0020; #/* don't taint results */ +use constant IMA_COPY_UP_STMT => 0x0040; #/* copy sth Statement to dbh */ +use constant IMA_END_WORK => 0x0080; #/* set on commit & rollback */ +use constant IMA_STUB => 0x0100; #/* do nothing eg $dbh->connected */ +use constant IMA_CLEAR_STMT => 0x0200; #/* clear Statement before call */ +use constant IMA_UNRELATED_TO_STMT=> 0x0400; #/* profile as empty Statement */ +use constant IMA_NOT_FOUND_OKAY => 0x0800; #/* not error if not found */ +use constant IMA_EXECUTE => 0x1000; #/* do/execute: DBIcf_Executed */ +use constant IMA_SHOW_ERR_STMT => 0x2000; #/* dbh meth relates to Statement*/ +use constant IMA_HIDE_ERR_PARAMVALUES => 0x4000; #/* ParamValues are not relevant */ +use constant IMA_IS_FACTORY => 0x8000; #/* new h ie connect & prepare */ +use constant IMA_CLEAR_CACHED_KIDS => 0x10000; #/* clear CachedKids before call */ + +use constant DBIstcf_STRICT => 0x0001; +use constant DBIstcf_DISCARD_STRING => 0x0002; + +my %is_flag_attribute = map {$_ =>1 } qw( + Active + AutoCommit + ChopBlanks + CompatMode + Executed + Taint + TaintIn + TaintOut + InactiveDestroy + AutoInactiveDestroy + LongTruncOk + MultiThread + PrintError + PrintWarn + RaiseError + RaiseWarn + ShowErrorStatement + Warn +); +my %is_valid_attribute = map {$_ =>1 } (keys %is_flag_attribute, qw( + ActiveKids + Attribution + BegunWork + CachedKids + Callbacks + ChildHandles + CursorName + Database + DebugDispatch + Driver + Err + Errstr + ErrCount + FetchHashKeyName + HandleError + HandleSetErr + ImplementorClass + Kids + LongReadLen + NAME NAME_uc NAME_lc NAME_uc_hash NAME_lc_hash + NULLABLE + NUM_OF_FIELDS + NUM_OF_PARAMS + Name + PRECISION + ParamValues + Profile + Provider + ReadOnly + RootClass + RowCacheSize + RowsInCache + SCALE + State + Statement + TYPE + Type + TraceLevel + Username + Version +)); + +sub valid_attribute { + my $attr = shift; + return 1 if $is_valid_attribute{$attr}; + return 1 if $attr =~ m/^[a-z]/; # starts with lowercase letter + return 0 +} + +my $initial_setup; +sub initial_setup { + $initial_setup = 1; + print $DBI::tfh __FILE__ . " version " . $DBI::PurePerl::VERSION . "\n" + if $DBI::dbi_debug & 0xF; + untie $DBI::err; + untie $DBI::errstr; + untie $DBI::state; + untie $DBI::rows; + #tie $DBI::lasth, 'DBI::var', '!lasth'; # special case: return boolean +} + +sub _install_method { + my ( $caller, $method, $from, $param_hash ) = @_; + initial_setup() unless $initial_setup; + + my ($class, $method_name) = $method =~ /^[^:]+::(.+)::(.+)$/; + my $bitmask = $param_hash->{'O'} || 0; + my @pre_call_frag; + + return if $method_name eq 'can'; + + push @pre_call_frag, q{ + delete $h->{CachedKids}; + # ignore DESTROY for outer handle (DESTROY for inner likely to follow soon) + return if $h_inner; + # handle AutoInactiveDestroy and InactiveDestroy + $h->{InactiveDestroy} = 1 + if $h->{AutoInactiveDestroy} and $$ != $h->{dbi_pp_pid}; + $h->{Active} = 0 + if $h->{InactiveDestroy}; + # copy err/errstr/state up to driver so $DBI::err etc still work + if ($h->{err} and my $drh = $h->{Driver}) { + $drh->{$_} = $h->{$_} for ('err','errstr','state'); + } + } if $method_name eq 'DESTROY'; + + push @pre_call_frag, q{ + return $h->{$_[0]} if exists $h->{$_[0]}; + } if $method_name eq 'FETCH' && !exists $ENV{DBI_TRACE}; # XXX ? + + push @pre_call_frag, "return;" + if IMA_STUB & $bitmask; + + push @pre_call_frag, q{ + $method_name = pop @_; + } if IMA_FUNC_REDIRECT & $bitmask; + + push @pre_call_frag, q{ + my $parent_dbh = $h->{Database}; + } if (IMA_COPY_UP_STMT|IMA_EXECUTE) & $bitmask; + + push @pre_call_frag, q{ + warn "No Database set for $h on $method_name!" unless $parent_dbh; # eg proxy problems + $parent_dbh->{Statement} = $h->{Statement} if $parent_dbh; + } if IMA_COPY_UP_STMT & $bitmask; + + push @pre_call_frag, q{ + $h->{Executed} = 1; + $parent_dbh->{Executed} = 1 if $parent_dbh; + } if IMA_EXECUTE & $bitmask; + + push @pre_call_frag, q{ + %{ $h->{CachedKids} } = () if $h->{CachedKids}; + } if IMA_CLEAR_CACHED_KIDS & $bitmask; + + if (IMA_KEEP_ERR & $bitmask) { + push @pre_call_frag, q{ + my $keep_error = DBI::_err_hash($h); + }; + } + else { + my $ke_init = (IMA_KEEP_ERR_SUB & $bitmask) + ? q{= ($h->{dbi_pp_parent}->{dbi_pp_call_depth} && DBI::_err_hash($h)) } + : ""; + push @pre_call_frag, qq{ + my \$keep_error $ke_init; + }; + my $clear_error_code = q{ + #warn "$method_name cleared err"; + $h->{err} = $DBI::err = undef; + $h->{errstr} = $DBI::errstr = undef; + $h->{state} = $DBI::state = ''; + }; + $clear_error_code = q{ + printf $DBI::tfh " !! %s: %s CLEARED by call to }.$method_name.q{ method\n". + $h->{err}, $h->{err} + if defined $h->{err} && $DBI::dbi_debug & 0xF; + }. $clear_error_code + if exists $ENV{DBI_TRACE}; + push @pre_call_frag, ($ke_init) + ? qq{ unless (\$keep_error) { $clear_error_code }} + : $clear_error_code + unless $method_name eq 'set_err'; + } + + push @pre_call_frag, q{ + my $ErrCount = $h->{ErrCount}; + }; + + push @pre_call_frag, q{ + if (($DBI::dbi_debug & 0xF) >= 2) { + no warnings; + my $args = join " ", map { DBI::neat($_) } ($h, @_); + printf $DBI::tfh " > $method_name in $imp ($args) [$@]\n"; + } + } if exists $ENV{DBI_TRACE}; # note use of 'exists' + + push @pre_call_frag, q{ + $h->{'dbi_pp_last_method'} = $method_name; + } unless exists $DBI::last_method_except{$method_name}; + + # --- post method call code fragments --- + my @post_call_frag; + + push @post_call_frag, q{ + if (my $trace_level = ($DBI::dbi_debug & 0xF)) { + if ($h->{err}) { + printf $DBI::tfh " !! ERROR: %s %s\n", $h->{err}, $h->{errstr}; + } + my $ret = join " ", map { DBI::neat($_) } @ret; + my $msg = " < $method_name= $ret"; + $msg = ($trace_level >= 2) ? Carp::shortmess($msg) : "$msg\n"; + print $DBI::tfh $msg; + } + } if exists $ENV{DBI_TRACE}; # note use of exists + + push @post_call_frag, q{ + $h->{Executed} = 0; + if ($h->{BegunWork}) { + $h->{BegunWork} = 0; + $h->{AutoCommit} = 1; + } + } if IMA_END_WORK & $bitmask; + + push @post_call_frag, q{ + if ( ref $ret[0] and + UNIVERSAL::isa($ret[0], 'DBI::_::common') and + defined( (my $h_new = tied(%{$ret[0]})||$ret[0])->{err} ) + ) { + # copy up info/warn to drh so PrintWarn on connect is triggered + $h->set_err($h_new->{err}, $h_new->{errstr}, $h_new->{state}) + } + } if IMA_IS_FACTORY & $bitmask; + + push @post_call_frag, q{ + if ($keep_error) { + $keep_error = 0 + if $h->{ErrCount} > $ErrCount + or DBI::_err_hash($h) ne $keep_error; + } + + $DBI::err = $h->{err}; + $DBI::errstr = $h->{errstr}; + $DBI::state = $h->{state}; + + if ( !$keep_error + && defined(my $err = $h->{err}) + && ($call_depth <= 1 && !$h->{dbi_pp_parent}{dbi_pp_call_depth}) + ) { + + my($pe,$pw,$re,$rw,$he) = @{$h}{qw(PrintError PrintWarn RaiseError RaiseWarn HandleError)}; + my $msg; + + if ($err && ($pe || $re || $he) # error + or (!$err && length($err) && ($pw || $rw)) # warning + ) { + my $last = ($DBI::last_method_except{$method_name}) + ? ($h->{'dbi_pp_last_method'}||$method_name) : $method_name; + my $errstr = $h->{errstr} || $DBI::errstr || $err || ''; + my $msg = sprintf "%s %s %s: %s", $imp, $last, + ($err eq "0") ? "warning" : "failed", $errstr; + + if ($h->{'ShowErrorStatement'} and my $Statement = $h->{Statement}) { + $msg .= ' [for Statement "' . $Statement; + if (my $ParamValues = $h->FETCH('ParamValues')) { + $msg .= '" with ParamValues: '; + $msg .= DBI::_concat_hash_sorted($ParamValues, "=", ", ", 1, undef); + $msg .= "]"; + } + else { + $msg .= '"]'; + } + } + if ($err eq "0") { # is 'warning' (not info) + carp $msg if $pw; + my $do_croak = $rw; + if ((my $subsub = $h->{'HandleError'}) && $do_croak) { + $do_croak = 0 if &$subsub($msg,$h,$ret[0]); + } + die $msg if $do_croak; + } + else { + my $do_croak = 1; + if (my $subsub = $h->{'HandleError'}) { + $do_croak = 0 if &$subsub($msg,$h,$ret[0]); + } + if ($do_croak) { + printf $DBI::tfh " $method_name has failed ($h->{PrintError},$h->{RaiseError})\n" + if ($DBI::dbi_debug & 0xF) >= 4; + carp $msg if $pe; + die $msg if $h->{RaiseError}; + } + } + } + } + }; + + + my $method_code = q[ + sub { + my $h = shift; + my $h_inner = tied(%$h); + $h = $h_inner if $h_inner; + + my $imp; + if ($method_name eq 'DESTROY') { + # during global destruction, $h->{...} can trigger "Can't call FETCH on an undef value" + # implying that tied() above lied to us, so we need to use eval + local $@; # protect $@ + $imp = eval { $h->{"ImplementorClass"} } or return; # probably global destruction + } + else { + $imp = $h->{"ImplementorClass"} or do { + warn "Can't call $method_name method on handle $h after take_imp_data()\n" + if not exists $h->{Active}; + return; # or, more likely, global destruction + }; + } + + ] . join("\n", '', @pre_call_frag, '') . q[ + + my $call_depth = $h->{'dbi_pp_call_depth'} + 1; + local ($h->{'dbi_pp_call_depth'}) = $call_depth; + + my @ret; + my $sub = $imp->can($method_name); + if (!$sub and IMA_FUNC_REDIRECT & $bitmask and $sub = $imp->can('func')) { + push @_, $method_name; + } + if ($sub) { + (wantarray) ? (@ret = &$sub($h,@_)) : (@ret = scalar &$sub($h,@_)); + } + else { + # XXX could try explicit fallback to $imp->can('AUTOLOAD') etc + # which would then let Multiplex pass PurePerl tests, but some + # hook into install_method may be better. + croak "Can't locate DBI object method \"$method_name\" via package \"$imp\"" + if ] . ((IMA_NOT_FOUND_OKAY & $bitmask) ? 0 : 1) . q[; + } + + ] . join("\n", '', @post_call_frag, '') . q[ + + return (wantarray) ? @ret : $ret[0]; + } + ]; + no strict qw(refs); + my $code_ref = eval qq{#line 1 "DBI::PurePerl $method"\n$method_code}; + warn "$@\n$method_code\n" if $@; + die "$@\n$method_code\n" if $@; + *$method = $code_ref; + if (0 && $method =~ /\b(connect|FETCH)\b/) { # debuging tool + my $l=0; # show line-numbered code for method + warn "*$method code:\n".join("\n", map { ++$l.": $_" } split/\n/,$method_code); + } +} + + +sub _new_handle { + my ($class, $parent, $attr, $imp_data, $imp_class) = @_; + + DBI->trace_msg(" New $class (for $imp_class, parent=$parent, id=".($imp_data||'').")\n") + if $DBI::dbi_debug >= 3; + + $attr->{ImplementorClass} = $imp_class + or Carp::croak("_new_handle($class): 'ImplementorClass' attribute not given"); + + # This is how we create a DBI style Object: + # %outer gets tied to %$attr (which becomes the 'inner' handle) + my (%outer, $i, $h); + $i = tie %outer, $class, $attr; # ref to inner hash (for driver) + $h = bless \%outer, $class; # ref to outer hash (for application) + # The above tie and bless may migrate down into _setup_handle()... + # Now add magic so DBI method dispatch works + DBI::_setup_handle($h, $imp_class, $parent, $imp_data); + return $h unless wantarray; + return ($h, $i); +} + +sub _setup_handle { + my($h, $imp_class, $parent, $imp_data) = @_; + my $h_inner = tied(%$h) || $h; + if (($DBI::dbi_debug & 0xF) >= 4) { + no warnings; + print $DBI::tfh " _setup_handle(@_)\n"; + } + $h_inner->{"imp_data"} = $imp_data; + $h_inner->{"ImplementorClass"} = $imp_class; + $h_inner->{"Kids"} = $h_inner->{"ActiveKids"} = 0; # XXX not maintained + if ($parent) { + foreach (qw( + RaiseError PrintError RaiseWarn PrintWarn HandleError HandleSetErr + Warn LongTruncOk ChopBlanks AutoCommit ReadOnly + ShowErrorStatement FetchHashKeyName LongReadLen CompatMode + )) { + $h_inner->{$_} = $parent->{$_} + if exists $parent->{$_} && !exists $h_inner->{$_}; + } + if (ref($parent) =~ /::db$/) { # is sth + $h_inner->{Database} = $parent; + $parent->{Statement} = $h_inner->{Statement}; + $h_inner->{NUM_OF_PARAMS} = 0; + $h_inner->{Active} = 0; # driver sets true when there's data to fetch + } + elsif (ref($parent) =~ /::dr$/){ # is dbh + $h_inner->{Driver} = $parent; + $h_inner->{Active} = 0; + } + else { + warn "panic: ".ref($parent); # should never happen + } + $h_inner->{dbi_pp_parent} = $parent; + + # add to the parent's ChildHandles + if ($HAS_WEAKEN) { + my $handles = $parent->{ChildHandles} ||= []; + push @$handles, $h; + Scalar::Util::weaken($handles->[-1]); + # purge destroyed handles occasionally + if (@$handles % 120 == 0) { + @$handles = grep { defined } @$handles; + Scalar::Util::weaken($_) for @$handles; # re-weaken after grep + } + } + } + else { # setting up a driver handle + $h_inner->{Warn} = 1; + $h_inner->{PrintWarn} = 1; + $h_inner->{AutoCommit} = 1; + $h_inner->{TraceLevel} = 0; + $h_inner->{CompatMode} = (1==0); + $h_inner->{FetchHashKeyName} ||= 'NAME'; + $h_inner->{LongReadLen} ||= 80; + $h_inner->{ChildHandles} ||= [] if $HAS_WEAKEN; + $h_inner->{Type} ||= 'dr'; + $h_inner->{Active} = 1; + } + $h_inner->{"dbi_pp_call_depth"} = 0; + $h_inner->{"dbi_pp_pid"} = $$; + $h_inner->{ErrCount} = 0; +} + +sub constant { + warn "constant(@_) called unexpectedly"; return undef; +} + +sub trace { + my ($h, $level, $file) = @_; + $level = $h->parse_trace_flags($level) + if defined $level and !DBI::looks_like_number($level); + my $old_level = $DBI::dbi_debug; + _set_trace_file($file) if $level; + if (defined $level) { + $DBI::dbi_debug = $level; + print $DBI::tfh " DBI $DBI::VERSION (PurePerl) " + . "dispatch trace level set to $DBI::dbi_debug\n" + if $DBI::dbi_debug & 0xF; + } + _set_trace_file($file) if !$level; + return $old_level; +} + +sub _set_trace_file { + my ($file) = @_; + # + # DAA add support for filehandle inputs + # + # DAA required to avoid closing a prior fh trace() + $DBI::tfh = undef unless $DBI::tfh_needs_close; + + if (ref $file eq 'GLOB') { + $DBI::tfh = $file; + select((select($DBI::tfh), $| = 1)[0]); + $DBI::tfh_needs_close = 0; + return 1; + } + if ($file && ref \$file eq 'GLOB') { + $DBI::tfh = *{$file}{IO}; + select((select($DBI::tfh), $| = 1)[0]); + $DBI::tfh_needs_close = 0; + return 1; + } + $DBI::tfh_needs_close = 1; + if (!$file || $file eq 'STDERR') { + open $DBI::tfh, ">&STDERR" or carp "Can't dup STDERR: $!"; + } + elsif ($file eq 'STDOUT') { + open $DBI::tfh, ">&STDOUT" or carp "Can't dup STDOUT: $!"; + } + else { + open $DBI::tfh, ">>$file" or carp "Can't open $file: $!"; + } + select((select($DBI::tfh), $| = 1)[0]); + return 1; +} +sub _get_imp_data { shift->{"imp_data"}; } +sub _svdump { } +sub dump_handle { + my ($h,$msg,$level) = @_; + $msg||="dump_handle $h"; + print $DBI::tfh "$msg:\n"; + for my $attrib (sort keys %$h) { + print $DBI::tfh "\t$attrib => ".DBI::neat($h->{$attrib})."\n"; + } +} + +sub _handles { + my $h = shift; + my $h_inner = tied %$h; + if ($h_inner) { # this is okay + return $h unless wantarray; + return ($h, $h_inner); + } + # XXX this isn't okay... we have an inner handle but + # currently have no way to get at its outer handle, + # so we just warn and return the inner one for both... + Carp::carp("Can't return outer handle from inner handle using DBI::PurePerl"); + return $h unless wantarray; + return ($h,$h); +} + +sub hash { + my ($key, $type) = @_; + my ($hash); + if (!$type) { + $hash = 0; + # XXX The C version uses the "char" type, which could be either + # signed or unsigned. I use signed because so do the two + # compilers on my system. + for my $char (unpack ("c*", $key)) { + $hash = $hash * 33 + $char; + } + $hash &= 0x7FFFFFFF; # limit to 31 bits + $hash |= 0x40000000; # set bit 31 + return -$hash; # return negative int + } + elsif ($type == 1) { # Fowler/Noll/Vo hash + # see http://www.isthe.com/chongo/tech/comp/fnv/ + require Math::BigInt; # feel free to reimplement w/o BigInt! + (my $version = $Math::BigInt::VERSION || 0) =~ s/_.*//; # eg "1.70_01" + if ($version >= 1.56) { + $hash = Math::BigInt->new(0x811c9dc5); + for my $uchar (unpack ("C*", $key)) { + # multiply by the 32 bit FNV magic prime mod 2^64 + $hash = ($hash * 0x01000193) & 0xffffffff; + # xor the bottom with the current octet + $hash ^= $uchar; + } + # cast to int + return unpack "i", pack "i", $hash; + } + croak("DBI::PurePerl doesn't support hash type 1 without Math::BigInt >= 1.56 (available on CPAN)"); + } + else { + croak("bad hash type $type"); + } +} + +sub looks_like_number { + my @new = (); + for my $thing(@_) { + if (!defined $thing or $thing eq '') { + push @new, undef; + } + else { + push @new, ($thing =~ /^([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/) ? 1 : 0; + } + } + return (@_ >1) ? @new : $new[0]; +} + +sub neat { + my $v = shift; + return "undef" unless defined $v; + my $quote = q{"}; + if (not utf8::is_utf8($v)) { + return $v if (($v & ~ $v) eq "0"); # is SvNIOK + $quote = q{'}; + } + my $maxlen = shift || $DBI::neat_maxlen; + if ($maxlen && $maxlen < length($v) + 2) { + $v = substr($v,0,$maxlen-5); + $v .= '...'; + } + $v =~ s/[^[:print:]]/./g; + return "$quote$v$quote"; +} + +sub sql_type_cast { + my (undef, $sql_type, $flags) = @_; + + return -1 unless defined $_[0]; + + my $cast_ok = 1; + + my $evalret = eval { + use warnings FATAL => qw(numeric); + if ($sql_type == SQL_INTEGER) { + my $dummy = $_[0] + 0; + return 1; + } + elsif ($sql_type == SQL_DOUBLE) { + my $dummy = $_[0] + 0.0; + return 1; + } + elsif ($sql_type == SQL_NUMERIC) { + my $dummy = $_[0] + 0.0; + return 1; + } + else { + return -2; + } + } or $^W && warn $@; # XXX warnings::warnif("numeric", $@) ? + + return $evalret if defined($evalret) && ($evalret == -2); + $cast_ok = 0 unless $evalret; + + # DBIstcf_DISCARD_STRING not supported for PurePerl currently + + return 2 if $cast_ok; + return 0 if $flags & DBIstcf_STRICT; + return 1; +} + +sub dbi_time { + return time(); +} + +sub DBI::st::TIEHASH { bless $_[1] => $_[0] }; + +sub _concat_hash_sorted { + my ( $hash_ref, $kv_separator, $pair_separator, $use_neat, $num_sort ) = @_; + # $num_sort: 0=lexical, 1=numeric, undef=try to guess + + return undef unless defined $hash_ref; + die "hash is not a hash reference" unless ref $hash_ref eq 'HASH'; + my $keys = _get_sorted_hash_keys($hash_ref, $num_sort); + my $string = ''; + for my $key (@$keys) { + $string .= $pair_separator if length $string > 0; + my $value = $hash_ref->{$key}; + if ($use_neat) { + $value = DBI::neat($value, 0); + } + else { + $value = (defined $value) ? "'$value'" : 'undef'; + } + $string .= $key . $kv_separator . $value; + } + return $string; +} + +sub _get_sorted_hash_keys { + my ($hash_ref, $num_sort) = @_; + if (not defined $num_sort) { + my $sort_guess = 1; + $sort_guess = (not looks_like_number($_)) ? 0 : $sort_guess + for keys %$hash_ref; + $num_sort = $sort_guess; + } + + my @keys = keys %$hash_ref; + no warnings 'numeric'; + my @sorted = ($num_sort) + ? sort { $a <=> $b or $a cmp $b } @keys + : sort @keys; + return \@sorted; +} + +sub _err_hash { + return 1 unless defined $_[0]->{err}; + return "$_[0]->{err} $_[0]->{errstr}" +} + + +package + DBI::var; + +sub FETCH { + my($key)=shift; + return $DBI::err if $$key eq '*err'; + return $DBI::errstr if $$key eq '&errstr'; + Carp::confess("FETCH $key not supported when using DBI::PurePerl"); +} + +package + DBD::_::common; + +sub swap_inner_handle { + my ($h1, $h2) = @_; + # can't make this work till we can get the outer handle from the inner one + # probably via a WeakRef + return $h1->set_err($DBI::stderr, "swap_inner_handle not currently supported by DBI::PurePerl"); +} + +sub trace { # XXX should set per-handle level, not global + my ($h, $level, $file) = @_; + $level = $h->parse_trace_flags($level) + if defined $level and !DBI::looks_like_number($level); + my $old_level = $DBI::dbi_debug; + DBI::_set_trace_file($file) if defined $file; + if (defined $level) { + $DBI::dbi_debug = $level; + if ($DBI::dbi_debug) { + printf $DBI::tfh + " %s trace level set to %d in DBI $DBI::VERSION (PurePerl)\n", + $h, $DBI::dbi_debug; + print $DBI::tfh " Full trace not available because DBI_TRACE is not in environment\n" + unless exists $ENV{DBI_TRACE}; + } + } + return $old_level; +} +*debug = \&trace; *debug = \&trace; # twice to avoid typo warning + +sub FETCH { + my($h,$key)= @_; + my $v = $h->{$key}; + #warn ((exists $h->{$key}) ? "$key=$v\n" : "$key NONEXISTANT\n"); + return $v if defined $v; + if ($key =~ /^NAME_.c$/) { + my $cols = $h->FETCH('NAME'); + return undef unless $cols; + my @lcols = map { lc $_ } @$cols; + $h->{NAME_lc} = \@lcols; + my @ucols = map { uc $_ } @$cols; + $h->{NAME_uc} = \@ucols; + return $h->FETCH($key); + } + if ($key =~ /^NAME.*_hash$/) { + my $i=0; + for my $c(@{$h->FETCH('NAME')||[]}) { + $h->{'NAME_hash'}->{$c} = $i; + $h->{'NAME_lc_hash'}->{"\L$c"} = $i; + $h->{'NAME_uc_hash'}->{"\U$c"} = $i; + $i++; + } + return $h->{$key}; + } + if (!defined $v && !exists $h->{$key}) { + return ($h->FETCH('TaintIn') && $h->FETCH('TaintOut')) if $key eq'Taint'; + return (1==0) if $is_flag_attribute{$key}; # return perl-style sv_no, not undef + return $DBI::dbi_debug if $key eq 'TraceLevel'; + return [] if $key eq 'ChildHandles' && $HAS_WEAKEN; + if ($key eq 'Type') { + return "dr" if $h->isa('DBI::dr'); + return "db" if $h->isa('DBI::db'); + return "st" if $h->isa('DBI::st'); + Carp::carp( sprintf "Can't determine Type for %s",$h ); + } + if (!$is_valid_attribute{$key} and $key =~ m/^[A-Z]/) { + no warnings; # hide undef warnings + Carp::carp( sprintf "Can't get %s->{%s}: unrecognised attribute (@{[ %$h ]})",$h,$key ) + } + } + return $v; +} +sub STORE { + my ($h,$key,$value) = @_; + if ($key eq 'AutoCommit') { + Carp::croak("DBD driver has not implemented the AutoCommit attribute") + unless $value == -900 || $value == -901; + $value = ($value == -901); + } + elsif ($key =~ /^Taint/ ) { + Carp::croak(sprintf "Can't set %s->{%s}: Taint mode not supported by DBI::PurePerl",$h,$key) + if $value; + } + elsif ($key eq 'TraceLevel') { + $h->trace($value); + return 1; + } + elsif ($key eq 'NUM_OF_FIELDS') { + $h->{$key} = $value; + if ($value) { + my $fbav = DBD::_::st::dbih_setup_fbav($h); + @$fbav = (undef) x $value if @$fbav != $value; + } + return 1; + } + elsif (!$is_valid_attribute{$key} && $key =~ /^[A-Z]/ && !exists $h->{$key}) { + Carp::carp(sprintf "Can't set %s->{%s}: unrecognised attribute or invalid value %s", + $h,$key,$value); + } + $h->{$key} = $is_flag_attribute{$key} ? !!$value : $value; + Scalar::Util::weaken($h->{$key}) if $key eq 'CachedKids'; + return 1; +} +sub DELETE { + my ($h, $key) = @_; + return $h->FETCH($key) unless $key =~ /^private_/; + return delete $h->{$key}; +} +sub err { return shift->{err} } +sub errstr { return shift->{errstr} } +sub state { return shift->{state} } +sub set_err { + my ($h, $errnum,$msg,$state, $method, $rv) = @_; + $h = tied(%$h) || $h; + + if (my $hss = $h->{HandleSetErr}) { + return if $hss->($h, $errnum, $msg, $state, $method); + } + + if (!defined $errnum) { + $h->{err} = $DBI::err = undef; + $h->{errstr} = $DBI::errstr = undef; + $h->{state} = $DBI::state = ''; + return; + } + + if ($h->{errstr}) { + $h->{errstr} .= sprintf " [err was %s now %s]", $h->{err}, $errnum + if $h->{err} && $errnum && $h->{err} ne $errnum; + $h->{errstr} .= sprintf " [state was %s now %s]", $h->{state}, $state + if $h->{state} and $h->{state} ne "S1000" && $state && $h->{state} ne $state; + $h->{errstr} .= "\n$msg" if $h->{errstr} ne $msg; + $DBI::errstr = $h->{errstr}; + } + else { + $h->{errstr} = $DBI::errstr = $msg; + } + + # assign if higher priority: err > "0" > "" > undef + my $err_changed; + if ($errnum # new error: so assign + or !defined $h->{err} # no existing warn/info: so assign + # new warn ("0" len 1) > info ("" len 0): so assign + or defined $errnum && length($errnum) > length($h->{err}) + ) { + $h->{err} = $DBI::err = $errnum; + ++$h->{ErrCount} if $errnum; + ++$err_changed; + } + + if ($err_changed) { + $state ||= "S1000" if $DBI::err; + $h->{state} = $DBI::state = ($state eq "00000") ? "" : $state + if $state; + } + + if (my $p = $h->{Database}) { # just sth->dbh, not dbh->drh (see ::db::DESTROY) + $p->{err} = $DBI::err; + $p->{errstr} = $DBI::errstr; + $p->{state} = $DBI::state; + } + + $h->{'dbi_pp_last_method'} = $method; + return $rv; # usually undef +} +sub trace_msg { + my ($h, $msg, $minlevel)=@_; + $minlevel = 1 unless defined $minlevel; + return unless $minlevel <= ($DBI::dbi_debug & 0xF); + print $DBI::tfh $msg; + return 1; +} +sub private_data { + warn "private_data @_"; +} +sub take_imp_data { + my $dbh = shift; + # A reasonable default implementation based on the one in DBI.xs. + # Typically a pure-perl driver would have their own take_imp_data method + # that would delete all but the essential items in the hash before ending with: + # return $dbh->SUPER::take_imp_data(); + # Of course it's useless if the driver doesn't also implement support for + # the dbi_imp_data attribute to the connect() method. + require Storable; + croak("Can't take_imp_data from handle that's not Active") + unless $dbh->{Active}; + for my $sth (@{ $dbh->{ChildHandles} || [] }) { + next unless $sth; + $sth->finish if $sth->{Active}; + bless $sth, 'DBI::zombie'; + } + delete $dbh->{$_} for (keys %is_valid_attribute); + delete $dbh->{$_} for grep { m/^dbi_/ } keys %$dbh; + # warn "@{[ %$dbh ]}"; + local $Storable::forgive_me = 1; # in case there are some CODE refs + my $imp_data = Storable::freeze($dbh); + # XXX um, should probably untie here - need to check dispatch behaviour + return $imp_data; +} +sub rows { + return -1; # always returns -1 here, see DBD::_::st::rows below +} +sub DESTROY { +} + +package + DBD::_::dr; + +sub dbixs_revision { + return 0; +} + +package + DBD::_::db; + +sub connected { +} + + +package + DBD::_::st; + +sub fetchrow_arrayref { + my $h = shift; + # if we're here then driver hasn't implemented fetch/fetchrow_arrayref + # so we assume they've implemented fetchrow_array and call that instead + my @row = $h->fetchrow_array or return; + return $h->_set_fbav(\@row); +} +# twice to avoid typo warning +*fetch = \&fetchrow_arrayref; *fetch = \&fetchrow_arrayref; + +sub fetchrow_array { + my $h = shift; + # if we're here then driver hasn't implemented fetchrow_array + # so we assume they've implemented fetch/fetchrow_arrayref + my $row = $h->fetch or return; + return @$row; +} +*fetchrow = \&fetchrow_array; *fetchrow = \&fetchrow_array; + +sub fetchrow_hashref { + my $h = shift; + my $row = $h->fetch or return; + my $FetchCase = shift; + my $FetchHashKeyName = $FetchCase || $h->{'FetchHashKeyName'} || 'NAME'; + my $FetchHashKeys = $h->FETCH($FetchHashKeyName); + my %rowhash; + @rowhash{ @$FetchHashKeys } = @$row; + return \%rowhash; +} +sub dbih_setup_fbav { + my $h = shift; + return $h->{'_fbav'} || do { + $DBI::rows = $h->{'_rows'} = 0; + my $fields = $h->{'NUM_OF_FIELDS'} + or DBI::croak("NUM_OF_FIELDS not set"); + my @row = (undef) x $fields; + \@row; + }; +} +sub _get_fbav { + my $h = shift; + my $av = $h->{'_fbav'} ||= dbih_setup_fbav($h); + $DBI::rows = ++$h->{'_rows'}; + return $av; +} +sub _set_fbav { + my $h = shift; + my $fbav = $h->{'_fbav'}; + if ($fbav) { + $DBI::rows = ++$h->{'_rows'}; + } + else { + $fbav = $h->_get_fbav; + } + my $row = shift; + if (my $bc = $h->{'_bound_cols'}) { + for my $i (0..@$row-1) { + my $bound = $bc->[$i]; + $fbav->[$i] = ($bound) ? ($$bound = $row->[$i]) : $row->[$i]; + } + } + else { + @$fbav = @$row; + } + return $fbav; +} +sub bind_col { + my ($h, $col, $value_ref,$from_bind_columns) = @_; + my $fbav = $h->{'_fbav'} ||= dbih_setup_fbav($h); # from _get_fbav() + my $num_of_fields = @$fbav; + DBI::croak("bind_col: column $col is not a valid column (1..$num_of_fields)") + if $col < 1 or $col > $num_of_fields; + return 1 if not defined $value_ref; # ie caller is just trying to set TYPE + DBI::croak("bind_col($col,$value_ref) needs a reference to a scalar") + unless ref $value_ref eq 'SCALAR'; + $h->{'_bound_cols'}->[$col-1] = $value_ref; + return 1; +} +sub finish { + my $h = shift; + $h->{'_fbav'} = undef; + $h->{'Active'} = 0; + return 1; +} +sub rows { + my $h = shift; + my $rows = $h->{'_rows'}; + return -1 unless defined $rows; + return $rows; +} + +1; +__END__ + +=pod + +=head1 NAME + +DBI::PurePerl -- a DBI emulation using pure perl (no C/XS compilation required) + +=head1 SYNOPSIS + + BEGIN { $ENV{DBI_PUREPERL} = 2 } + use DBI; + +=head1 DESCRIPTION + +This is a pure perl emulation of the DBI internals. In almost all +cases you will be better off using standard DBI since the portions +of the standard version written in C make it *much* faster. + +However, if you are in a situation where it isn't possible to install +a compiled version of standard DBI, and you're using pure-perl DBD +drivers, then this module allows you to use most common features +of DBI without needing any changes in your scripts. + +=head1 EXPERIMENTAL STATUS + +DBI::PurePerl is new so please treat it as experimental pending +more extensive testing. So far it has passed all tests with DBD::CSV, +DBD::AnyData, DBD::XBase, DBD::Sprite, DBD::mysqlPP. Please send +bug reports to Jeff Zucker at with a cc to +. + +=head1 USAGE + +The usage is the same as for standard DBI with the exception +that you need to set the environment variable DBI_PUREPERL if +you want to use the PurePerl version. + + DBI_PUREPERL == 0 (the default) Always use compiled DBI, die + if it isn't properly compiled & installed + + DBI_PUREPERL == 1 Use compiled DBI if it is properly compiled + & installed, otherwise use PurePerl + + DBI_PUREPERL == 2 Always use PurePerl + +You may set the environment variable in your shell (e.g. with +set or setenv or export, etc) or else set it in your script like +this: + + BEGIN { $ENV{DBI_PUREPERL}=2 } + +before you C. + +=head1 INSTALLATION + +In most situations simply install DBI (see the DBI pod for details). + +In the situation in which you can not install DBI itself, you +may manually copy DBI.pm and PurePerl.pm into the appropriate +directories. + +For example: + + cp DBI.pm /usr/jdoe/mylibs/. + cp PurePerl.pm /usr/jdoe/mylibs/DBI/. + +Then add this to the top of scripts: + + BEGIN { + $ENV{DBI_PUREPERL} = 1; # or =2 + unshift @INC, '/usr/jdoe/mylibs'; + } + +(Or should we perhaps patch Makefile.PL so that if DBI_PUREPERL +is set to 2 prior to make, the normal compile process is skipped +and the files are installed automatically?) + +=head1 DIFFERENCES BETWEEN DBI AND DBI::PurePerl + +=head2 Attributes + +Boolean attributes still return boolean values but the actual values +used may be different, i.e., 0 or undef instead of an empty string. + +Some handle attributes are either not supported or have very limited +functionality: + + ActiveKids + InactiveDestroy + AutoInactiveDestroy + Kids + Taint + TaintIn + TaintOut + +(and probably others) + +=head2 Tracing + +Trace functionality is more limited and the code to handle tracing is +only embedded into DBI:PurePerl if the DBI_TRACE environment variable +is defined. To enable total tracing you can set the DBI_TRACE +environment variable as usual. But to enable individual handle +tracing using the trace() method you also need to set the DBI_TRACE +environment variable, but set it to 0. + +=head2 Parameter Usage Checking + +The DBI does some basic parameter count checking on method calls. +DBI::PurePerl doesn't. + +=head2 Speed + +DBI::PurePerl is slower. Although, with some drivers in some +contexts this may not be very significant for you. + +By way of example... the test.pl script in the DBI source +distribution has a simple benchmark that just does: + + my $null_dbh = DBI->connect('dbi:NullP:','',''); + my $i = 10_000; + $null_dbh->prepare('') while $i--; + +In other words just prepares a statement, creating and destroying +a statement handle, over and over again. Using the real DBI this +runs at ~4550 handles per second whereas DBI::PurePerl manages +~2800 per second on the same machine (not too bad really). + +=head2 May not fully support hash() + +If you want to use type 1 hash, i.e., C with +DBI::PurePerl, you'll need version 1.56 or higher of Math::BigInt +(available on CPAN). + +=head2 Doesn't support preparse() + +The DBI->preparse() method isn't supported in DBI::PurePerl. + +=head2 Doesn't support DBD::Proxy + +There's a subtle problem somewhere I've not been able to identify. +DBI::ProxyServer seem to work fine with DBI::PurePerl but DBD::Proxy +does not work 100% (which is sad because that would be far more useful :) +Try re-enabling t/80proxy.t for DBI::PurePerl to see if the problem +that remains will affect you're usage. + +=head2 Others + + can() - doesn't have any special behaviour + +Please let us know if you find any other differences between DBI +and DBI::PurePerl. + +=head1 AUTHORS + +Tim Bunce and Jeff Zucker. + +Tim provided the direction and basis for the code. The original +idea for the module and most of the brute force porting from C to +Perl was by Jeff. Tim then reworked some core parts to boost the +performance and accuracy of the emulation. Thanks also to Randal +Schwartz and John Tobey for patches. + +=head1 COPYRIGHT + +Copyright (c) 2002 Tim Bunce Ireland. + +See COPYRIGHT section in DBI.pm for usage and distribution rights. + +=cut diff --git a/src/main/perl/lib/DBI/_Handles.pm b/src/main/perl/lib/DBI/_Handles.pm deleted file mode 100644 index 66ed9dd93..000000000 --- a/src/main/perl/lib/DBI/_Handles.pm +++ /dev/null @@ -1,1433 +0,0 @@ -# Internal helper module for DBI. Provides the driver-architecture -# pieces that pure-Perl DBDs (DBD::NullP, DBD::ExampleP, DBD::Sponge, -# DBD::File, DBD::Mem, DBD::DBM, DBD::Proxy, ...) expect to see: -# -# * DBI->install_driver / installed_drivers / setup_driver -# * DBI::_new_drh, DBI::_new_dbh, DBI::_new_sth (handle factories) -# * DBD::_::common / DBD::_::dr / DBD::_::db / DBD::_::st base -# classes with FETCH / STORE / set_err / err / errstr / state / -# trace / trace_msg / func / DESTROY / finish / default connect. -# -# Lives in its own file so PerlOnJava compiles it to a separate JVM -# class (see note in DBI.pm). -# -# NOTE: this is a *minimal* reimplementation aimed at making the -# bundled DBI test suite load and exercise pure-Perl drivers. It is -# intentionally simpler than real DBI.pm. Notable differences: -# -# - Handles are plain blessed hashrefs, not tied hashes. `FETCH` -# / `STORE` / `can` / `isa` all work, and DBD drivers that use -# `$h->STORE(key => val)` / `$h->{key}` interchangeably work, -# but `each %$h` and tie-aware introspection do not. -# - `_new_drh` / `_new_dbh` / `_new_sth` return the same object -# for the outer and inner handle. Real DBI distinguishes them -# via a tie; we don't. -# - Trace flag parsing is a stub (enough to satisfy tests that -# probe it, not a full implementation). - -package DBI; - -use strict; -use warnings; -use Carp (); -use Scalar::Util (); - -our %installed_drh; # driver_name => $drh (outer) - -# ---- handle factories ----------------------------------------------- -# -# Real DBI handles are "two-headed": -# - an "inner" handle: the actual storage, blessed into the driver's -# implementor class (e.g. DBD::NullP::db). -# - an "outer" handle: a blessed reference to an anonymous hash, -# tied (at the hash level) to a small DBI::_::Tie class. The outer -# is what gets returned to user code. -# -# The outer is blessed into DBI::dr / DBI::db / DBI::st so -# `ref($dbh) eq 'DBI::db'` and `isa('DBI::db')` hold — matching what -# the DBI tests and DBIx::Class expect. -# -# Hash access on the outer (`$dbh->{Active}`) is intercepted by the -# tie class, which forwards FETCH / STORE to methods on the inner. -# The inner's @ISA reaches into DBD::_::common's FETCH / STORE, which -# can compute derived keys (NAME_lc, NAME_uc, NAME_hash, …) on the -# fly — matching real DBI's tied-hash behaviour. -# -# Method dispatch on the outer (`$dbh->prepare(...)`) falls through -# DBI::db's own methods first; if not found, DBI::db's AUTOLOAD looks -# up the method on the inner's class and invokes it with the inner -# as invocant. That way driver-specific methods (prepare, execute, -# f_versions, dbm_versions, …) all work transparently. -# -# Backward link: every inner has a weak reference to its outer in -# $inner->{_outer}, so helpers like `_new_dbh` (which take inner as -# $drh) can still populate new handles' `Driver` attribute with the -# user-visible outer. - -sub _new_drh { - my ($class, $initial_attr, $imp_data) = @_; - my $inner = { - State => \my $h_state, - Err => \my $h_err, - Errstr => \(my $h_errstr = ''), - TraceLevel => 0, - FetchHashKeyName => 'NAME', - %{ $initial_attr || {} }, - ImplementorClass => $class, - Kids => 0, - ActiveKids => 0, - Active => 1, - }; - $inner->{_private_data} = $imp_data if defined $imp_data; - bless $inner, $class; - - my %outer_storage; - my $outer = bless \%outer_storage, 'DBI::dr'; - tie %$outer, 'DBI::_::Tie', $inner; - $inner->{_outer} = $outer; - - return wantarray ? ($outer, $inner) : $outer; -} - -sub _new_dbh { - my ($drh, $attr, $imp_data) = @_; - # $drh may be the inner (if called from a driver's connect(), - # routed via AUTOLOAD with inner as invocant) or the outer (if - # called directly by user code). Normalise to inner. - my $drh_inner = _inner_of($drh); - my $drh_outer = $drh_inner->{_outer} || $drh; - - my $imp_class = $drh_inner->{ImplementorClass} - or Carp::croak("DBI _new_dbh: $drh has no ImplementorClass"); - (my $db_class = $imp_class) =~ s/::dr$/::db/; - - my $inner = { - Err => \my $h_err, - Errstr => \(my $h_errstr = ''), - State => \my $h_state, - TraceLevel => 0, - # Real DBI defaults applied before driver / caller attrs. - Warn => 1, - PrintWarn => ($^W ? 1 : 0), - PrintError => 1, - RaiseError => 0, - RaiseWarn => 0, - AutoCommit => 1, - CompatMode => 0, - ShowErrorStatement => 0, - ChopBlanks => 0, - LongTruncOk => 0, - Executed => 0, - ErrCount => 0, - FetchHashKeyName => 'NAME', - LongReadLen => 80, - %{ $attr || {} }, - ImplementorClass => $db_class, - Driver => $drh_outer, - Kids => 0, - ActiveKids => 0, - Active => 0, - Statement => '', - }; - # If the caller passed a string Profile spec (e.g. "2/DBI::ProfileDumper/File:x"), - # upgrade it to an object now so `$dbh->{Profile}->flush_to_disk` etc. work. - if (defined $inner->{Profile} && !ref $inner->{Profile}) { - $inner->{Profile} = DBD::_::common::_parse_profile_spec($inner->{Profile}); - } - $inner->{_private_data} = $imp_data if defined $imp_data; - bless $inner, $db_class; - - my %outer_storage; - my $outer = bless \%outer_storage, 'DBI::db'; - tie %$outer, 'DBI::_::Tie', $inner; - $inner->{_outer} = $outer; - - $drh_inner->{Kids}++; - # Track child handles on the parent for visit_child_handles. - # Weak refs so children are garbage-collected normally (but see - # note below: weak refs in combination with tied outer handles - # don't currently survive across scope boundaries on PerlOnJava; - # for now we keep strong refs and let `grep { defined }` in tests - # be a no-op. Real DBI cleans stale entries in its XS destroy path.) - push @{ $drh_inner->{ChildHandles} ||= [] }, $outer; - # Scalar::Util::weaken($drh_inner->{ChildHandles}[-1]); - - return wantarray ? ($outer, $inner) : $outer; -} - -sub _new_sth { - my ($dbh, $attr, $imp_data) = @_; - my $dbh_inner = _inner_of($dbh); - my $dbh_outer = $dbh_inner->{_outer} || $dbh; - - my $imp_class = $dbh_inner->{ImplementorClass} - or Carp::croak("DBI _new_sth: $dbh has no ImplementorClass"); - (my $st_class = $imp_class) =~ s/::db$/::st/; - - my $inner = { - Err => \my $h_err, - Errstr => \(my $h_errstr = ''), - State => \my $h_state, - TraceLevel => 0, - NUM_OF_FIELDS => 0, - NUM_OF_PARAMS => 0, - %{ $attr || {} }, - ImplementorClass => $st_class, - Database => $dbh_outer, - Active => 0, - }; - # Inherit Profile from the parent dbh if not explicitly set. - $inner->{Profile} = $dbh_inner->{Profile} - if !exists $inner->{Profile} && defined $dbh_inner->{Profile}; - # Inherit TraceLevel from the parent dbh (real DBI behaviour: - # TraceLevel is a per-handle attribute that children inherit at - # creation time). - $inner->{TraceLevel} = $dbh_inner->{TraceLevel} - if !exists($attr->{TraceLevel}) && $dbh_inner->{TraceLevel}; - $inner->{_private_data} = $imp_data if defined $imp_data; - bless $inner, $st_class; - - my %outer_storage; - my $outer = bless \%outer_storage, 'DBI::st'; - tie %$outer, 'DBI::_::Tie', $inner; - $inner->{_outer} = $outer; - - $dbh_inner->{Kids}++; - push @{ $dbh_inner->{ChildHandles} ||= [] }, $outer; - # Scalar::Util::weaken($dbh_inner->{ChildHandles}[-1]); # see _new_dbh - - return wantarray ? ($outer, $inner) : $outer; -} - -# Given either an outer (tied) handle or an inner (blessed driver -# hashref), return the inner. -sub _inner_of { - my $h = shift; - return $h unless ref $h; - my $tied = tied %$h; - if (ref($tied) eq 'DBI::_::Tie') { - return $$tied; - } - return $h; -} - -# Given either inner or outer, return the user-facing outer. Falls back -# to the input if no outer exists (e.g. handles constructed by older -# code paths). -sub _outer_of { - my $h = shift; - return $h unless ref $h; - my $tied = tied %$h; - return $h if ref($tied) eq 'DBI::_::Tie'; # already the outer - return $h->{_outer} || $h; # inner -> outer back-ref -} - -# ---- DBI::_::Tie ----------------------------------------------------- -# -# Minimal tie class: stores a reference to the inner handle, forwards -# hash access to FETCH / STORE methods on the inner's class. - -{ - package DBI::_::Tie; - sub TIEHASH { my ($class, $inner) = @_; bless \$inner, $class; } - sub FETCH { ${$_[0]}->FETCH($_[1]); } - sub STORE { ${$_[0]}->STORE($_[1], $_[2]); } - sub DELETE { delete ${${$_[0]}}{$_[1]}; } - sub EXISTS { exists ${${$_[0]}}{$_[1]}; } - sub FIRSTKEY { - my $h = ${$_[0]}; - my $a = keys %$h; # reset iterator - each %$h; - } - sub NEXTKEY { each %{${$_[0]}}; } - sub CLEAR { %{${$_[0]}} = (); } - sub SCALAR { scalar %{${$_[0]}}; } -} - -# ---- outer-handle classes ------------------------------------------- -# -# DBI::dr / DBI::db / DBI::st: the classes outer handles are blessed -# into. Methods are dispatched via AUTOLOAD to the inner handle's -# class, so driver-specific methods (prepare, execute, f_versions, ...) -# work transparently. - -{ - # Shared base that implements the outer-side dispatch. - package DBI::_::OuterHandle; - our @ISA = (); - - # Ordered list of packages to try when dispatching a method on an - # outer handle. Tied (pure-Perl DBD) handles hit the inner's class - # first; untied handles (JDBC path) fall straight through to the - # common base, with the DBI package checked for Java-registered - # methods like prepare / execute / fetchrow_*. - sub _dispatch_packages { - my ($self) = @_; - my $ref = ref $self; - my ($suffix) = $ref =~ /^DBI::(dr|db|st)$/; - $suffix ||= ''; - my $inner = DBI::_inner_of($self); - my $inner_class = (ref($inner) && $inner != $self) ? ref($inner) : undef; - my @packages; - push @packages, $inner_class if defined $inner_class; - push @packages, 'DBI' if !defined $inner_class; # JDBC fallback - push @packages, "DBD::_::$suffix" if $suffix; - return @packages; - } - - sub _dispatch_target { - my ($self) = @_; - my $inner = DBI::_inner_of($self); - return $inner if ref($inner) && $inner != $self; - return $self; - } - - our $AUTOLOAD; - sub AUTOLOAD { - my $method = $AUTOLOAD; - $method =~ s/.*:://; - return if $method eq 'DESTROY'; - my $self = shift; - Carp::croak("Can't call method \"$method\" on undefined handle") - unless defined $self && ref $self; - - # Callbacks: real DBI fires $h->{Callbacks}{$method} (or the - # "*" wildcard if the specific method isn't present) before - # dispatching. The callback gets $self and the args; if it - # returns a defined value (scalar context) / list, that's - # used as the method result and dispatch is skipped. $_ is - # localised to the method name inside the callback. - if (my $cbs = $self->{Callbacks}) { - my $cb = $cbs->{$method} // $cbs->{'*'}; - if (ref($cb) eq 'CODE') { - local $_ = $method; - # Use same call context as the outer method call. - my @cb_result; - my $want = wantarray; - if ($want) { - @cb_result = $cb->($self, @_); - } elsif (defined $want) { - $cb_result[0] = $cb->($self, @_); - } else { - $cb->($self, @_); - } - return $want ? @cb_result : $cb_result[0] - if @cb_result && defined $cb_result[0]; - # If callback returned empty / undef, fall through - # to the real method. - } - } - - my @packages = _dispatch_packages($self); - my $target = _dispatch_target($self); - for my $class (@packages) { - if (my $code = $class->can($method)) { - return $code->($target, @_); - } - } - my $ref = ref $self; - Carp::croak( - "Can't locate DBI object method \"$method\" via package \"$ref\""); - } - - sub can { - my ($self, $method) = @_; - return unless defined $self; - my $pkg = ref($self) || $self; - my $direct = UNIVERSAL::can($pkg, $method); - return $direct if $direct; - return unless ref $self; - for my $class (_dispatch_packages($self)) { - if (my $code = $class->can($method)) { - return $code; - } - } - return; - } - - sub isa { - my ($self, $class) = @_; - my $pkg = ref($self) || $self; - return 1 if UNIVERSAL::isa($pkg, $class); - return 0 unless ref $self; - for my $c (_dispatch_packages($self)) { - return 1 if $c->isa($class); - } - return 0; - } - - sub DESTROY { } -} - -# All three outer-handle classes are plain DBI::_::OuterHandle subclasses. -# (They do NOT inherit from DBI: DBI has `connect` etc. registered as class -# methods, and we don't want `$drh->connect` to recurse back into DBI::connect. -# Java-registered methods like prepare / execute are reachable through the -# AUTOLOAD fallback chain in _dispatch_packages.) -{ package DBI::dr; our @ISA = ('DBI::_::OuterHandle'); } -{ package DBI::db; our @ISA = ('DBI::_::OuterHandle'); } -{ package DBI::st; our @ISA = ('DBI::_::OuterHandle'); } - -# ---- driver installation -------------------------------------------- - -sub install_driver { - my ($class, $driver, $attr) = @_; - Carp::croak("usage: $class->install_driver(\$driver [, \\%attr])") - unless defined $driver && length $driver; - return $installed_drh{$driver} if $installed_drh{$driver}; - - my $dbd_class = "DBD::$driver"; - my $ok = eval "require $dbd_class; 1"; - unless ($ok) { - my $err = $@ || 'unknown error'; - Carp::croak("install_driver($driver) failed: $err"); - } - - # wire up @ISA for DBD::$driver::{dr,db,st} so SUPER:: works - $class->setup_driver($dbd_class); - - my $drh = $dbd_class->driver($attr || {}); - Carp::croak("$dbd_class->driver() did not return a driver handle") - unless ref $drh; - $installed_drh{$driver} = $drh; - return $drh; -} - -sub setup_driver { - my ($class, $driver_class) = @_; - no strict 'refs'; - for my $suffix (qw(dr db st)) { - my $h_class = "${driver_class}::${suffix}"; - my $base = "DBD::_::${suffix}"; - push @{"${h_class}::ISA"}, $base - unless UNIVERSAL::isa($h_class, $base); - } -} - -sub installed_drivers { %installed_drh } - -# DBI->visit_handles(\&code [, \%info]) — walk all child handles of -# installed drivers, calling $code->($handle, $info) on each. -sub visit_handles { - my ($class, $code, $info) = @_; - $info = {} unless defined $info; - for my $name (keys %installed_drh) { - my $drh = $installed_drh{$name} or next; - my $ci = $code->($drh, $info) or next; - $drh->visit_child_handles($code, $ci); - } - return $info; -} - -sub data_sources { - my ($class, $driver, $attr) = @_; - if (!ref($class)) { - # allow `DBI->data_sources("dbi:DRIVER:", $attr)` form - if (defined $driver && $driver =~ /^dbi:([^:]+):?/i) { - $driver = $1; - } - } - my $drh = ref($class) ? $class : $class->install_driver($driver); - return $drh->data_sources($attr); -} - -# DBI->internal returns the internal DBD::Switch pseudo-driver handle, -# used by the DBI self-tests to exercise DBI::dr-level attributes. We -# fake it as a simple DBD::Switch::dr handle that inherits from -# DBD::_::dr (and therefore isa('DBI::dr')). -our $_internal_drh; -sub internal { - return $_internal_drh if $_internal_drh; - { - package DBD::Switch::dr; - # Inherit from DBI::dr so isa('DBI::dr') is true on the inner - # too. Real DBI wires DBD::Switch::dr the same way. This is - # safe because DBI::_::OuterHandle::AUTOLOAD only fires on - # outer handles and _dispatch_packages falls through cleanly - # for inner classes that don't match /^DBI::(dr|db|st)$/. - our @ISA = ('DBD::_::dr', 'DBI::dr'); - sub DESTROY { } - } - # Build $_internal_drh as a proper tied outer handle so that - # FETCH / STORE route through DBD::_::common (with Attribution / - # Active defaults), and isa('DBI::dr') works. - $_internal_drh = DBI::_new_drh('DBD::Switch::dr', { - Name => 'Switch', - Version => $DBI::VERSION, - Attribution => "DBI $DBI::VERSION by Tim Bunce", - Active => 1, - }); - return $_internal_drh; -} - -# DBI->driver_prefix / dbixs_revision stubs. Real DBI uses these -# for the method-installation registry; we don't need the machinery, -# we just need the calls to succeed. -sub driver_prefix { - my ($class, $driver) = @_; - # Accept either 'DBM' or 'DBD::DBM'. - $driver =~ s/^DBD:://; - my %map = ( - DBM => 'dbm_', ExampleP => 'examplep_', File => 'f_', - Mem => 'mem_', NullP => 'nullp_', Proxy => 'proxy_', - Sponge => 'sponge_', SQLite => 'sqlite_', Gofer => 'go_', - ); - return $map{$driver}; -} - -sub dbixs_revision { return 0 } - -# DBI->parse_dsn(dsn): parse a DBI DSN into -# (scheme, driver, attr_string, attr_hash, dsn_rest). -sub parse_dsn { - my ($class, $dsn) = @_; - return unless defined $dsn; - return unless $dsn =~ /^(dbi):([^:;(]+)(?:\(([^)]*)\))?(?:[:;](.*))?$/si; - my ($scheme, $driver, $attr_str, $rest) = ($1, $2, $3, $4); - my %attr; - if (defined $attr_str && length $attr_str) { - for my $pair (split /,/, $attr_str) { - $pair =~ s/^\s+//; $pair =~ s/\s+$//; - my ($k, $v) = split /\s*=\s*/, $pair, 2; - $attr{$k} = $v if defined $k; - } - } - return ($scheme, $driver, $attr_str, \%attr, $rest); -} - -# DBI::_concat_hash_sorted(hashref, kv_sep, pair_sep, neat, sort_type). -# Serialize a hash deterministically. Used by prepare_cached cache keys -# and a handful of tests. Matches real DBI's XS behaviour: -# - undef hashref -> undef -# - non-HASH ref -> croak "... is not a hash reference" -# - keys unquoted; values quoted (or `neat`-formatted) -# - sort_type: 0/undef = lexical, 1 = numeric (uses looks_like_number) -sub _concat_hash_sorted { - my ($hash, $kv_sep, $pair_sep, $neat, $sort_type) = @_; - return undef unless defined $hash; - Carp::croak("$hash is not a hash reference") - unless ref($hash) eq 'HASH'; - $kv_sep = '=' unless defined $kv_sep; - $pair_sep = ',' unless defined $pair_sep; - my @keys = keys %$hash; - # Guess sort_type if not given: 1 (numeric) iff every key - # looks like a number, else 0 (lexical). - if (!defined $sort_type) { - $sort_type = 1; - for my $k (@keys) { - if (!Scalar::Util::looks_like_number($k)) { - $sort_type = 0; last; - } - } - } - no warnings 'numeric'; - @keys = $sort_type - ? sort { $a <=> $b or $a cmp $b } @keys - : sort @keys; - my @parts; - for my $k (@keys) { - my $v = $hash->{$k}; - if ($neat) { - $v = DBI::neat($v); - } else { - $v = defined $v ? "'$v'" : 'undef'; - } - push @parts, $k . $kv_sep . $v; - } - return join $pair_sep, @parts; -} - -# DBI::dbi_profile stubs. Real DBI implements a per-handle profiler -# (see DBI/Profile.pm). We accept the call so profile tests don't blow -# up; the real DBI::Profile module, when loaded, handles things itself. -sub dbi_profile { return; } - -sub dbi_profile_merge_nodes { - my ($dest, @sources) = @_; - return 0 unless ref($dest) eq 'ARRAY'; - my $total = 0; - for my $src (@sources) { - next unless ref($src) eq 'ARRAY' && @$src >= 2; - $dest->[0] = ($dest->[0] || 0) + ($src->[0] || 0); - $dest->[1] = ($dest->[1] || 0) + ($src->[1] || 0); - $total += ($src->[0] || 0); - } - return $total; -} - -sub dbi_profile_merge { goto &dbi_profile_merge_nodes } - -# DBI::dbi_time — real DBI returns Time::HiRes::time() here; we -# delegate to time() for simplicity. (Already defined in DBI/_Utils.pm -# — this copy would 'redefined' warn — so we omit it here.) - -# DBI::hash(string[, type=0]): 31-bit multiplicative hash used by -# various DBI tests and some XS-based drivers. Ported from -# DBI::PurePerl. -sub hash { - my ($key, $type) = @_; - $type ||= 0; - if ($type == 0) { - my $hash = 0; - for my $char (unpack("c*", $key)) { - $hash = $hash * 33 + $char; - } - $hash &= 0x7FFFFFFF; - $hash |= 0x40000000; - return -$hash; - } - Carp::croak("DBI::hash type $type not supported in PerlOnJava"); -} - -# DBI->_install_method is used by drivers to register new methods -# on handle classes. Real DBI builds dispatch tables; our simplified -# version just installs the method directly so `$h->$method` works. -sub _install_method { - my ($class, $full_name, $attr, $sub) = @_; - # $full_name is like "DBI::db::sqlite_foo" - no strict 'refs'; - if (ref $sub eq 'CODE') { - *{$full_name} = $sub; - } - return 1; -} - -# DBI->trace / DBI->trace_msg are already defined as instance -# methods by DBI.pm (on dbh/sth handles). Tests that call them as -# class methods (DBI->trace(1)) are uncommon and the existing -# impls accept that shape; don't redefine here. - -sub available_drivers { - my ($class, $quiet) = @_; - # Best-effort: scan @INC for DBD::* modules. Tests usually only - # care that this returns a list, not an exact one. - my %seen; - for my $dir (@INC) { - next unless ref($dir) eq '' && -d "$dir/DBD"; - if (opendir my $dh, "$dir/DBD") { - while (my $e = readdir $dh) { - next unless $e =~ /^(\w+)\.pm$/; - $seen{$1} ||= 1; - } - closedir $dh; - } - } - return sort keys %seen; -} - -# ---- base classes ---------------------------------------------------- -# -# Real DBI exposes these as `DBD::_::common` + DBD::_::{dr,db,st}, -# where each DBD:::: inherits from DBD::_:: -# (wired by setup_driver above). The `DBI::dr` / `DBI::db` / `DBI::st` -# outer-handle classes are set up earlier in this file (they inherit -# from DBI::_::OuterHandle and dispatch to the inner via AUTOLOAD). - -sub _get_imp_data { - my $h = shift; - return ref($h) ? $h->{_private_data} : undef; -} - -{ - package DBD::_::common; - our @ISA = (); - use strict; - - # Attributes DBI recognises. Used by FETCH / STORE to warn on - # unknown uppercase-prefixed attributes (real DBI behaviour — see - # DBI::PurePerl's %is_valid_attribute). Keys that start with a - # lowercase letter are always allowed (driver-private), as are - # those with the conventional private_* / dbd_* / dbi_* prefixes. - our %is_valid_attribute = map { $_ => 1 } qw( - Active ActiveKids AutoCommit AutoInactiveDestroy Attribution - BegunWork CachedKids Callbacks ChildHandles ChopBlanks - CompatMode CursorName Database Debug DebugDispatch Driver - Err ErrCount Errstr Executed ExecutedDestroyMode - FetchHashKeyName FetchHashKeyName_Drv - HandleError HandleSetErr HandleWarn - ImplementorClass InactiveDestroy Kids LongReadLen LongTruncOk - Name NAME NAME_lc NAME_uc NAME_hash NAME_lc_hash NAME_uc_hash - NULLABLE NUM_OF_FIELDS NUM_OF_PARAMS - ParamArrays ParamTypes ParamValues - PRECISION PrintError PrintWarn Profile - RaiseError RaiseWarn ReadOnly RootClass - RowCache RowCacheSize RowsInCache SCALE ShowErrorStatement - State Statement Taint TaintIn TaintOut TraceLevel Type TYPE - Username Version Warn - _private_data _outer _inner - ); - - sub _is_known_key { - my $key = shift; - return 1 if $is_valid_attribute{$key}; - return 1 if $key =~ /^[a-z]/; # lowercase = driver-private - return 1 if $key =~ /^(?:private_|dbd_|dbi_)/; - return 0; - } - - sub FETCH { - my ($h, $key) = @_; - return undef unless ref $h; - my $v = $h->{$key}; - # Err / Errstr / State are stored as scalarref holders so they - # can be shared with child handles. Dereference on FETCH. - return $$v if ref($v) eq 'SCALAR' && $key =~ /^(?:Err|Errstr|State)$/; - # Drivers may STORE magic sentinel values on AutoCommit - # (-900 / -901) to signal that they've handled the attribute - # themselves. Translate them back to 0 / 1 for user code. - if ($key eq 'AutoCommit' && defined $v && !ref $v) { - return 0 if $v eq '-900'; - return 1 if $v eq '-901'; - } - # Warn on fetch of an unknown uppercase-prefixed attribute - # (real DBI behaviour). - if (!defined $v && !exists $h->{$key} && !_is_known_key($key)) { - my $class = ref $h; - Carp::carp("Can't get " . $class . "->{$key}: unrecognised attribute"); - } - return $v; - } - - sub STORE { - my ($h, $key, $val) = @_; - if ($key eq 'Profile' && defined $val && !ref $val) { - # Real DBI parses "LEVEL/CLASS/ARGS" and creates a - # DBI::Profile(Dumper) object. Minimal port: try to - # require the requested class, call ->new, fall back to - # DBI::Profile. - $val = _parse_profile_spec($val); - } - if ($key eq 'TraceLevel') { - # Real DBI: assigning undef to TraceLevel is a no-op - # (used to make `local $h->{TraceLevel} = ...` safe in - # blocks that don't want to override). Assigning a - # non-numeric string routes through parse_trace_flags - # so names like "SQL" or "SQL|foo|3" work. - return 1 unless defined $val; - if ($val !~ /^-?\d+(?:\.\d+)?$/) { - $val = $h->parse_trace_flags($val); - } - } - # Warn on setting an unknown uppercase-prefixed attribute - # that's not already present (real DBI behaviour). - if (ref($h) && !exists($h->{$key}) && !_is_known_key($key)) { - my $class = ref $h; - Carp::carp("Can't set " . $class . "->{$key}: unrecognised attribute"); - } - if ($key =~ /^(?:Err|Errstr|State)$/ && ref($h->{$key}) eq 'SCALAR') { - ${ $h->{$key} } = $val; - } else { - $h->{$key} = $val; - } - return 1; - } - - # Very small subset of real DBI's Profile spec parser. Accepts - # "LEVEL[/CLASS[/ARGS]]" where ARGS is "Key1:val1:Key2:val2...". - sub _parse_profile_spec { - my ($spec) = @_; - return $spec unless defined $spec; - my ($flags, $rest); - if ($spec =~ m{^(\d+)(?:/(.*))?$}) { - ($flags, $rest) = ($1, $2); - } else { - ($flags, $rest) = (0, $spec); - } - my ($class, @arg_parts) = split m{/}, ($rest // ''), 2; - $class ||= 'DBI::Profile'; - my $args_str = $arg_parts[0]; - my %args; - if (defined $args_str && length $args_str) { - my @pairs = split /:/, $args_str; - while (@pairs) { - my $k = shift @pairs; - my $v = shift @pairs; - $args{$k} = $v if defined $k; - } - } - my $ok = eval "require $class; 1"; - return $spec unless $ok; - my $profile = eval { - $class->new(Path => ['!Statement'], %args); - }; - return $profile || $spec; - } - - sub EXISTS { defined($_[0]->FETCH($_[1])) } - sub FIRSTKEY { } - sub NEXTKEY { } - sub CLEAR { Carp::carp "Can't CLEAR $_[0] (DBI)" } - - sub err { - my $h = shift; - my $v = $h->{Err}; - return ref($v) eq 'SCALAR' ? $$v : $v; - } - sub errstr { - my $h = shift; - my $v = $h->{Errstr}; - return ref($v) eq 'SCALAR' ? $$v : $v; - } - sub state { - my $h = shift; - my $v = $h->{State}; - my $s = ref($v) eq 'SCALAR' ? $$v : $v; - return defined $s ? $s : ''; - } - - # set_err(err, errstr [, state, method, rv]) — standard DBI error - # setter. Tries to match real DBI's semantics: - # - # Severity levels (by $err value): - # err truthy — real error. HandleError always fires; - # if not suppressed, RaiseError dies and - # PrintError warns. - # err 0 / "0" — warning. HandleError fires only if - # RaiseWarn or PrintWarn is set; if fired - # and RaiseWarn, we die; if PrintWarn, we - # warn. No HandleError/die/warn when no - # *Warn flag is set. - # err "" — info. Just stored; no alerts, no handler. - # err undef — clear Err/Errstr/State; no alerts. - # - # Behaviour matching real DBI::PurePerl::set_err: - # * HandleSetErr callback (if set) fires FIRST on every call; - # if it returns true, the rest of set_err is short-circuited. - # * HandleSetErr may mutate $_[1], $_[2], $_[3] to override - # err/errstr/state before they're stored. - # * Errstr accumulates (does not overwrite): each call appends - # "\n$msg" with "[err was X now Y]" / "[state was X now Y]" - # annotations when appropriate. - # * Err is only promoted to a higher-priority value: - # err > "0" > "" > undef. - sub set_err { - my ($h, $err, $errstr, $state, $method, $rv) = @_; - - # HandleSetErr runs first and can short-circuit or mutate. - if (ref $h && ref($h->{HandleSetErr}) eq 'CODE') { - my $ret = $h->{HandleSetErr}->($h, $err, $errstr, $state, $method); - return if $ret; # suppressed - # $_[1..3] may have been modified; re-read: - ($err, $errstr, $state) = ($_[1], $_[2], $_[3]); - } - - # Clearing case: set_err(undef, ...). - if (!defined $err) { - $h->STORE(Err => undef); - $h->STORE(Errstr => undef); - $h->STORE(State => ''); - $DBI::err = undef; - $DBI::errstr = undef; - $DBI::state = ''; - return $rv; - } - - $errstr = $err unless defined $errstr; - - # Accumulate errstr on the handle ("\n$msg", plus inline - # "[err was X now Y]" / "[state was X now Y]" annotations). - my $existing_errstr = $h->{Errstr}; - $existing_errstr = $$existing_errstr if ref($existing_errstr) eq 'SCALAR'; - my $existing_err = $h->{Err}; - $existing_err = $$existing_err if ref($existing_err) eq 'SCALAR'; - my $existing_state = $h->{State}; - $existing_state = $$existing_state if ref($existing_state) eq 'SCALAR'; - - my $new_errstr; - if (defined $existing_errstr && length $existing_errstr) { - $new_errstr = $existing_errstr; - $new_errstr .= sprintf " [err was %s now %s]", $existing_err, $err - if $existing_err && $err && $existing_err ne $err; - $new_errstr .= sprintf " [state was %s now %s]", - $existing_state, $state - if defined $existing_state && length $existing_state - && $existing_state ne 'S1000' - && defined $state && length $state - && $existing_state ne $state; - $new_errstr .= "\n$errstr" if $new_errstr ne $errstr; - } else { - $new_errstr = $errstr; - } - - # Promote err only if the new value is higher-priority - # (truthy > "0" > "" > undef, judged by length()). - my $promote = 0; - if ($err) { - $promote = 1; - } elsif (!defined $existing_err) { - $promote = 1; - } elsif (length($err) > length($existing_err)) { - $promote = 1; - } - - if ($promote) { - $h->STORE(Err => $err); - $DBI::err = $err; - # state fill-in - if ($err && (!defined $state || !length $state)) { - $state = 'S1000'; - } - if (defined $state && length $state) { - my $s = ($state eq '00000') ? '' : $state; - $h->STORE(State => $s); - $DBI::state = $s; - } - } - - $h->STORE(Errstr => $new_errstr); - $DBI::errstr = $new_errstr; - - # Severity classification based on the value WE just set (the - # promoted one) — alerts fire on the stored severity, not the - # caller-supplied one. - my $stored_err = $promote ? $err : $existing_err; - my $is_error = $stored_err ? 1 : 0; - my $is_warning = !$is_error && defined $stored_err - && length($stored_err) > 0; - return $rv if !$is_error && !$is_warning; # info-level: done. - - # Build the formatted message real DBI's tests regex against. - my $impl_class = ref($h) || 'DBI'; - my $meth_name = defined $method ? $method : 'set_err'; - my $kind = $is_error ? 'failed' : 'warning'; - my $formatted = "${impl_class} ${meth_name} ${kind}: " - . (defined $errstr ? $errstr : ''); - - # HandleError: errors always fire it; warnings only when - # RaiseWarn or PrintWarn is set. - my $may_handle = $is_error - || ($is_warning && ($h->{RaiseWarn} || $h->{PrintWarn})); - - my $suppressed = 0; - if ($may_handle && ref($h->{HandleError}) eq 'CODE') { - local $@; - my $ret = eval { $h->{HandleError}->($formatted, $h, $rv) }; - die $@ if $@; - $suppressed = 1 if $ret; - } - - unless ($suppressed) { - if ($is_error) { - die "$formatted\n" if $h->{RaiseError}; - warn "$formatted\n" if $h->{PrintError}; - } elsif ($is_warning) { - die "$formatted\n" if $h->{RaiseWarn}; - warn "$formatted\n" if $h->{PrintWarn}; - } - } - - return $rv; # usually undef - } - - sub trace { - my ($h, $level, $file) = @_; - my $old = ref($h) ? ($h->{TraceLevel} || 0) : 0; - if (defined $level) { - if (ref $h) { - # Parse string forms ("SQL|foo", "2|SQL", ...) like real DBI. - if ($level =~ /\D/) { - $level = $h->parse_trace_flags($level); - } - $h->{TraceLevel} = $level; - } else { - $DBI::dbi_debug = $level; - } - } - # A third argument (even undef) controls the trace-output - # filehandle. Route to DBI::trace, which owns $DBI::tfh. - if (@_ >= 3) { - DBI::trace(undef, $DBI::dbi_debug, $file); - } - return $old; - } - - sub trace_msg { - my ($h, $msg, $min_level) = @_; - $min_level ||= 1; - my $level = ref($h) ? ($h->{TraceLevel} || 0) : ($DBI::dbi_debug || 0); - if ($level >= $min_level) { - my $fh = DBI::_trace_fh(); - print $fh $msg; - } - return 1; - } - - sub parse_trace_flag { - my ($h, $name) = @_; - return 0x00000100 if $name eq 'SQL'; - return 0x00000200 if $name eq 'CON'; - return 0x00000400 if $name eq 'ENC'; - return 0x00000800 if $name eq 'DBD'; - return 0x00001000 if $name eq 'TXN'; - return; - } - - sub parse_trace_flags { - my ($h, $spec) = @_; - my ($level, $flags) = (0, 0); - my @unknown; - for my $word (split /\s*[|&,]\s*/, $spec // '') { - if ($word =~ /^\d+$/ && $word >= 0 && $word <= 0xF) { - $level = $word; - } elsif ($word eq 'ALL') { - $flags = 0x7FFFFFFF; - last; - } elsif (my $flag = $h->parse_trace_flag($word)) { - $flags |= $flag; - } else { - push @unknown, $word; - } - } - if (@unknown && (ref $h ? ($h->FETCH('Warn') // 1) : 1)) { - Carp::carp( - "$h->parse_trace_flags($spec) ignored unknown trace flags: " - . join(" ", @unknown)); - } - return $flags | $level; - } - - sub func { - my ($h, @args) = @_; - my $method = pop @args; - my $target = ref($h) ? $h : $h; - my $impl = ref($h) ? $h->{ImplementorClass} : undef; - if ($impl && (my $sub = $impl->can($method))) { - return $sub->($h, @args); - } - Carp::croak("Can't locate DBI object method \"$method\""); - } - - sub private_attribute_info { undef } - - sub dbixs_revision { return 0 } - - sub debug { - my ($h, $level) = @_; - my $old = ref($h) ? ($h->{TraceLevel} || 0) : ($DBI::dbi_debug || 0); - $h->trace($level) if defined $level; - return $old; - } - - # FETCH_many: fetch multiple attributes in one call, used by - # DBI profile code and DBIx::Class. - sub FETCH_many { - my $h = shift; - return map { scalar $h->FETCH($_) } @_; - } - - # can() override so installed methods on the implementor class - # are findable. Handles inherit through @ISA already; this stub - # mostly exists for symmetry with real DBI. - sub install_method { - my ($class, $method, $attr) = @_; - Carp::croak("Class '$class' must begin with DBD:: and end with ::db or ::st") - unless $class =~ /^DBD::(\w+)::(dr|db|st)$/; - # No-op: drivers define methods directly on their :: - # packages and MRO picks them up. - return 1; - } - - sub dump_handle { - my ($h, $msg, $level) = @_; - $msg = '' unless defined $msg; - my $class = ref($h) || $h; - my $fh = DBI::_trace_fh(); - print $fh "$msg $class=HASH\n"; - if (ref $h) { - for my $k (sort keys %$h) { - my $v = $h->{$k}; - next if ref $v; - print $fh " $k = ", (defined $v ? $v : 'undef'), "\n"; - } - } - return 1; - } - - sub swap_inner_handle { return 1 } - sub visit_child_handles { - my ($h, $code, $info) = @_; - $info = {} unless defined $info; - for my $ch (@{ $h->{ChildHandles} || [] }) { - next unless $ch; - my $child_info = $code->($ch, $info) or next; - $ch->visit_child_handles($code, $child_info); - } - return $info; - } - - sub DESTROY { - my $h = shift; - # decrement parent's Kids on destruction. - if (ref $h eq 'HASH' || ref $h) { - my $parent = $h->{Database} || $h->{Driver}; - if ($parent && ref $parent && exists $parent->{Kids}) { - $parent->{Kids}-- if $parent->{Kids} > 0; - } - } - } -} - -{ - package DBD::_::dr; - # Intentionally does not inherit from DBI::dr: DBI::dr is the - # OUTER-handle class with an AUTOLOAD that forwards to the inner. - # If the inner's ISA reached DBI::dr, AUTOLOAD would loop. - our @ISA = ('DBD::_::common'); - use strict; - - sub default_user { - my ($drh, $user, $pass) = @_; - $user = $ENV{DBI_USER} unless defined $user; - $pass = $ENV{DBI_PASS} unless defined $pass; - return ($user, $pass); - } - - sub connect { - # default connect: create a db handle. DBDs typically override. - my ($drh, $dsn, $user, $auth, $attr) = @_; - my $dbh = DBI::_new_dbh($drh, { Name => $dsn }); - return $dbh; - } - - sub connect_cached { - my ($drh, $dsn, $user, $auth, $attr) = @_; - my $cache = $drh->{CachedKids} ||= {}; - my $key = join "!\001", - defined $dsn ? $dsn : '', - defined $user ? $user : '', - defined $auth ? $auth : ''; - my $dbh = $cache->{$key}; - if ($dbh && $dbh->FETCH('Active')) { - return $dbh; - } - $dbh = $drh->connect($dsn, $user, $auth, $attr); - $cache->{$key} = $dbh; - return $dbh; - } - - sub data_sources { return () } - sub disconnect_all { return; } -} - -{ - package DBD::_::db; - our @ISA = ('DBD::_::common'); - use strict; - - sub ping { return 0 } # DBDs should override - sub data_sources { - my ($dbh, $attr) = @_; - my $drh = $dbh->{Driver} or return (); - return $drh->data_sources($attr); - } - - sub do { - my ($dbh, $statement, $attr, @bind) = @_; - my $sth = $dbh->prepare($statement, $attr) or return undef; - $sth->execute(@bind) or return undef; - my $rows = $sth->rows; - return ($rows == 0) ? "0E0" : $rows; - } - - sub prepare_cached { - my ($dbh, $statement, $attr, $if_active) = @_; - $if_active ||= 0; - my $cache = $dbh->{CachedKids} ||= {}; - my $key = join "\001", $statement, - (defined $attr && ref($attr) eq 'HASH') - ? map { defined $_ ? $_ : '' } %$attr - : ''; - my $sth = $cache->{$key}; - if ($sth && $sth->FETCH('Active')) { - if ($if_active == 0) { - Carp::carp("prepare_cached($statement) statement handle $sth still Active"); - } elsif ($if_active == 1) { - $sth->finish; - } elsif ($if_active == 2) { - # fall through, reuse - } elsif ($if_active == 3) { - delete $cache->{$key}; - $sth = $dbh->prepare($statement, $attr); - $cache->{$key} = $sth; - } - } elsif (!$sth) { - $sth = $dbh->prepare($statement, $attr) or return undef; - $cache->{$key} = $sth; - } - return $sth; - } - - sub selectrow_array { - my ($dbh, $statement, $attr, @bind) = @_; - my $sth = (ref $statement) ? $statement : $dbh->prepare($statement, $attr) or return; - $sth->execute(@bind) or return; - my $row = $sth->fetchrow_arrayref; - $sth->finish; - return $row ? (wantarray ? @$row : $row->[0]) : (); - } - - sub selectrow_arrayref { - my ($dbh, $statement, $attr, @bind) = @_; - my $sth = (ref $statement) ? $statement : $dbh->prepare($statement, $attr) or return undef; - $sth->execute(@bind) or return undef; - my $row = $sth->fetchrow_arrayref; - $sth->finish; - return $row ? [@$row] : undef; - } - - sub selectall_arrayref { - my ($dbh, $statement, $attr, @bind) = @_; - my $sth = (ref $statement) ? $statement : $dbh->prepare($statement, $attr) or return undef; - $sth->execute(@bind) or return undef; - my @rows; - while (my $row = $sth->fetchrow_arrayref) { - push @rows, [@$row]; - } - return \@rows; - } - - sub selectcol_arrayref { - my ($dbh, $statement, $attr, @bind) = @_; - my $sth = (ref $statement) ? $statement : $dbh->prepare($statement, $attr) or return undef; - $sth->execute(@bind) or return undef; - my @col; - while (my $row = $sth->fetchrow_arrayref) { - push @col, $row->[0]; - } - return \@col; - } - - sub selectrow_hashref { - my ($dbh, $statement, $attr, @bind) = @_; - my $sth = (ref $statement) ? $statement : $dbh->prepare($statement, $attr) or return undef; - $sth->execute(@bind) or return undef; - my $row = $sth->fetchrow_hashref; - $sth->finish; - return $row; - } - - sub selectall_hashref { - my ($dbh, $statement, $key_field, $attr, @bind) = @_; - my $sth = (ref $statement) ? $statement : $dbh->prepare($statement, $attr) or return undef; - $sth->execute(@bind) or return undef; - return $sth->fetchall_hashref($key_field); - } - - sub disconnect { - my $dbh = shift; - $dbh->STORE(Active => 0); - return 1; - } - sub commit { - my $dbh = shift; - if ($dbh->{BegunWork}) { - $dbh->STORE(AutoCommit => 1); - $dbh->{BegunWork} = 0; - } - return 1; - } - sub rollback { - my $dbh = shift; - if ($dbh->{BegunWork}) { - $dbh->STORE(AutoCommit => 1); - $dbh->{BegunWork} = 0; - } - return 1; - } - - sub begin_work { - my $dbh = shift; - if (!$dbh->FETCH('AutoCommit')) { - Carp::carp("Already in a transaction"); - return 0; - } - $dbh->STORE(AutoCommit => 0); - $dbh->{BegunWork} = 1; - return 1; - } - - sub clone { - my ($dbh, $attr) = @_; - my $drh = $dbh->{Driver} or return; - my $new = $drh->connect( - $dbh->{Name} // '', - $dbh->{Username} // '', - '', - $attr || {}, - ); - return $new; - } - sub quote { - my ($dbh, $str, $type) = @_; - return 'NULL' unless defined $str; - $str =~ s/'/''/g; - return "'$str'"; - } - sub quote_identifier { - my ($dbh, @ids) = @_; - my $q = '"'; - return join('.', map { defined $_ ? qq{$q$_$q} : '' } @ids); - } - sub table_info { return undef } - sub column_info { return undef } - sub primary_key_info { return undef } - sub foreign_key_info { return undef } - sub type_info_all { return [] } - sub type_info { return () } - sub get_info { return undef } - sub last_insert_id { return undef } - sub take_imp_data { return undef } -} - -{ - package DBD::_::st; - our @ISA = ('DBD::_::common'); - use strict; - - sub rows { return -1 } - sub finish { - my $sth = shift; - $sth->STORE(Active => 0); - return 1; - } - - # Computed NAME_lc / NAME_uc / NAME_hash / NAME_lc_hash / - # NAME_uc_hash attributes derived from NAME. - sub FETCH { - my ($sth, $key) = @_; - return undef unless ref $sth; - if ($key eq 'NAME_lc') { - return undef unless $sth->{NAME}; - return [ map { lc } @{ $sth->{NAME} } ]; - } - if ($key eq 'NAME_uc') { - return undef unless $sth->{NAME}; - return [ map { uc } @{ $sth->{NAME} } ]; - } - if ($key eq 'NAME_hash') { - return undef unless $sth->{NAME}; - my %h; @h{ @{ $sth->{NAME} } } = (0 .. $#{ $sth->{NAME} }); - return \%h; - } - if ($key eq 'NAME_lc_hash') { - return undef unless $sth->{NAME}; - my %h; @h{ map { lc } @{ $sth->{NAME} } } = (0 .. $#{ $sth->{NAME} }); - return \%h; - } - if ($key eq 'NAME_uc_hash') { - return undef unless $sth->{NAME}; - my %h; @h{ map { uc } @{ $sth->{NAME} } } = (0 .. $#{ $sth->{NAME} }); - return \%h; - } - return $sth->SUPER::FETCH($key); # DBD::_::common::FETCH - } - - sub bind_col { return 1 } - sub bind_columns { return 1 } - sub bind_param { return 1 } - sub bind_param_array { return 1 } - sub execute_array { return 0 } - - sub fetchall_arrayref { - my ($sth, $slice, $maxrows) = @_; - my @rows; - my $count = 0; - if (!defined $slice || (ref $slice eq 'ARRAY' && !@$slice)) { - # plain: each row as arrayref - while (my $row = $sth->fetchrow_arrayref) { - push @rows, [@$row]; - last if defined $maxrows && ++$count >= $maxrows; - } - } elsif (ref $slice eq 'ARRAY') { - while (my $row = $sth->fetchrow_arrayref) { - push @rows, [ @{$row}[ @$slice ] ]; - last if defined $maxrows && ++$count >= $maxrows; - } - } elsif (ref $slice eq 'HASH') { - my $names = $sth->{ $sth->{FetchHashKeyName} || 'NAME' }; - my @keys = keys %$slice; - @keys = @$names if !@keys && $names; - while (my $row = $sth->fetchrow_arrayref) { - my %h; - for my $i (0 .. $#$names) { - $h{ $names->[$i] } = $row->[$i]; - } - push @rows, \%h; - last if defined $maxrows && ++$count >= $maxrows; - } - } - return \@rows; - } - - sub fetchall_hashref { - my ($sth, $key_field) = @_; - my %result; - my $names = $sth->{ $sth->{FetchHashKeyName} || 'NAME' }; - return {} unless $names; - # map field name -> column index - my %idx; - for my $i (0 .. $#$names) { $idx{ $names->[$i] } = $i; } - my @key_fields = ref($key_field) eq 'ARRAY' ? @$key_field : ($key_field); - while (my $row = $sth->fetchrow_arrayref) { - my %h; - for my $i (0 .. $#$names) { $h{ $names->[$i] } = $row->[$i]; } - my $target = \%result; - for my $i (0 .. $#key_fields - 1) { - my $k = $h{ $key_fields[$i] }; - $target = $target->{$k} ||= {}; - } - $target->{ $h{ $key_fields[-1] } } = \%h; - } - return \%result; - } - - sub fetchrow_array { - my $sth = shift; - my $ref = $sth->fetchrow_arrayref; - return $ref ? @$ref : (); - } - sub fetchrow_hashref { - my ($sth, $name_attr) = @_; - my $row = $sth->fetchrow_arrayref or return undef; - my $names = $sth->{ $name_attr || $sth->{FetchHashKeyName} || 'NAME' }; - my %h; - @h{ @$names } = @$row; - return \%h; - } - - # `fetch` is the canonical method real DBI documents for pulling - # a row from a statement handle; many drivers alias it to - # fetchrow_arrayref. Provide a default delegate so outer - # `$sth->fetch` works even when the driver didn't install one. - sub fetch { - my $sth = shift; - my $code = ref($sth)->can('fetchrow_arrayref') - or return; - return $code->($sth); - } - - # Helper used by pure-Perl DBDs (see DBD::NullP::st::fetchrow_arrayref). - # Real DBI binds fetched column values into the variables that were - # passed to bind_col / bind_columns. Our simplified impl just returns - # the array reference unchanged. - sub _set_fbav { - my ($sth, $data) = @_; - if (my $bound = $sth->{_bound_cols}) { - for my $i (0 .. $#$bound) { - ${ $bound->[$i] } = $data->[$i] if ref $bound->[$i]; - } - } - return $data; - } - - # _get_fbav: returns the pre-allocated row buffer for bind_col-style - # fetch. Used by DBD::Sponge and a few others. We simply allocate a - # fresh array of the expected width. - sub _get_fbav { - my ($sth) = @_; - my $num = $sth->FETCH('NUM_OF_FIELDS') || 0; - return [ (undef) x $num ]; - } -} - -1; diff --git a/src/main/perl/lib/DBI/_Utils.pm b/src/main/perl/lib/DBI/_Utils.pm deleted file mode 100644 index 5a40478ec..000000000 --- a/src/main/perl/lib/DBI/_Utils.pm +++ /dev/null @@ -1,185 +0,0 @@ -# Internal helper module for DBI: Exporter wiring, :sql_types / -# :sql_cursor_types / :utils / :profile tags, and the small utility -# functions (neat, neat_list, looks_like_number, data_string_diff, -# data_string_desc, data_diff, dump_results, sql_type_cast, dbi_time). -# -# Lives in its own file so PerlOnJava compiles it to a separate JVM -# class — the combined DBI.pm would otherwise overflow a per-method -# bytecode limit during module load. - -package DBI; -use strict; -use warnings; -use Exporter (); - -our (@EXPORT, @EXPORT_OK, %EXPORT_TAGS); -@EXPORT = (); -@EXPORT_OK = qw(%DBI %DBI_methods hash); -%EXPORT_TAGS = ( - sql_types => [ qw( - SQL_GUID SQL_WLONGVARCHAR SQL_WVARCHAR SQL_WCHAR SQL_BIGINT SQL_BIT - SQL_TINYINT SQL_LONGVARBINARY SQL_VARBINARY SQL_BINARY SQL_LONGVARCHAR - SQL_UNKNOWN_TYPE SQL_ALL_TYPES SQL_CHAR SQL_NUMERIC SQL_DECIMAL - SQL_INTEGER SQL_SMALLINT SQL_FLOAT SQL_REAL SQL_DOUBLE SQL_DATETIME - SQL_DATE SQL_INTERVAL SQL_TIME SQL_TIMESTAMP SQL_VARCHAR SQL_BOOLEAN - SQL_UDT SQL_UDT_LOCATOR SQL_ROW SQL_REF SQL_BLOB SQL_BLOB_LOCATOR - SQL_CLOB SQL_CLOB_LOCATOR SQL_ARRAY SQL_ARRAY_LOCATOR SQL_MULTISET - SQL_MULTISET_LOCATOR SQL_TYPE_DATE SQL_TYPE_TIME SQL_TYPE_TIMESTAMP - SQL_TYPE_TIME_WITH_TIMEZONE SQL_TYPE_TIMESTAMP_WITH_TIMEZONE - SQL_INTERVAL_YEAR SQL_INTERVAL_MONTH SQL_INTERVAL_DAY SQL_INTERVAL_HOUR - SQL_INTERVAL_MINUTE SQL_INTERVAL_SECOND SQL_INTERVAL_YEAR_TO_MONTH - SQL_INTERVAL_DAY_TO_HOUR SQL_INTERVAL_DAY_TO_MINUTE - SQL_INTERVAL_DAY_TO_SECOND SQL_INTERVAL_HOUR_TO_MINUTE - SQL_INTERVAL_HOUR_TO_SECOND SQL_INTERVAL_MINUTE_TO_SECOND - ) ], - sql_cursor_types => [ qw( - SQL_CURSOR_FORWARD_ONLY SQL_CURSOR_KEYSET_DRIVEN SQL_CURSOR_DYNAMIC - SQL_CURSOR_STATIC SQL_CURSOR_TYPE_DEFAULT - ) ], - utils => [ qw( - neat neat_list $neat_maxlen dump_results looks_like_number - data_string_diff data_string_desc data_diff sql_type_cast - DBIstcf_DISCARD_STRING DBIstcf_STRICT - ) ], - profile => [ qw( - dbi_profile dbi_profile_merge dbi_profile_merge_nodes dbi_time - ) ], - # :preparse_flags is real DBI's tag for the DBIpp_* SQL-preparser - # flags. We don't implement the preparser, but tests that only - # `use DBI qw(:preparse_flags)` to check the import succeeds are - # happy with an empty tag (nothing gets imported). - preparse_flags => [ ], -); -Exporter::export_ok_tags(keys %EXPORT_TAGS); - -# ---- utility functions (ported from DBI.pm / DBI::PurePerl) ---- - -sub looks_like_number { - my @new = (); - for my $thing (@_) { - if (!defined $thing or $thing eq '') { - push @new, undef; - } - else { - push @new, ($thing =~ /^([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/) ? 1 : 0; - } - } - return (@_ > 1) ? @new : $new[0]; -} - -sub neat { - my $v = shift; - return "undef" unless defined $v; - my $quote = q{"}; - if (not utf8::is_utf8($v)) { - return $v if (($v & ~ $v) eq "0"); # is SvNIOK (numeric) - $quote = q{'}; - } - my $maxlen = shift || $DBI::neat_maxlen; - if ($maxlen && $maxlen < length($v) + 2) { - $v = substr($v, 0, $maxlen - 5); - $v .= '...'; - } - $v =~ s/[^[:print:]]/./g; - return "$quote$v$quote"; -} - -sub neat_list { - my ($listref, $maxlen, $sep) = @_; - $maxlen = 0 unless defined $maxlen; - $sep = ", " unless defined $sep; - join($sep, map { neat($_, $maxlen) } @$listref); -} - -sub dump_results { - my ($sth, $maxlen, $lsep, $fsep, $fh) = @_; - return 0 unless $sth; - $maxlen ||= 35; - $lsep ||= "\n"; - $fh ||= \*STDOUT; - my $rows = 0; - my $ref; - while ($ref = $sth->fetch) { - print $fh $lsep if $rows++ and $lsep; - my $str = neat_list($ref, $maxlen, $fsep); - print $fh $str; - } - print $fh "\n$rows rows" . ($DBI::err ? " ($DBI::err: $DBI::errstr)" : "") . "\n"; - $rows; -} - -sub data_string_diff { - my ($a, $b) = @_; - unless (defined $a and defined $b) { - return "" if !defined $a and !defined $b; - return "String a is undef, string b has " . length($b) . " characters" if !defined $a; - return "String b is undef, string a has " . length($a) . " characters" if !defined $b; - } - my @a_chars = (utf8::is_utf8($a)) ? unpack("U*", $a) : unpack("C*", $a); - my @b_chars = (utf8::is_utf8($b)) ? unpack("U*", $b) : unpack("C*", $b); - my $i = 0; - while (@a_chars && @b_chars) { - ++$i, shift(@a_chars), shift(@b_chars), next - if $a_chars[0] == $b_chars[0]; - my @desc = map { - $_ > 255 ? sprintf("\\x{%04X}", $_) : - chr($_) =~ /[[:cntrl:]]/ ? sprintf("\\x%02X", $_) : - chr($_) - } ($a_chars[0], $b_chars[0]); - foreach my $c (@desc) { - next unless $c =~ m/\\x\{08(..)}/; - $c .= "='" . chr(hex($1)) . "'"; - } - return sprintf "Strings differ at index $i: a[$i]=$desc[0], b[$i]=$desc[1]"; - } - return "String a truncated after $i characters" if @b_chars; - return "String b truncated after $i characters" if @a_chars; - return ""; -} - -sub data_string_desc { - my ($a) = @_; - require bytes; - my $utf8 = sprintf "UTF8 %s%s", - utf8::is_utf8($a) ? "on" : "off", - utf8::valid($a || '') ? "" : " but INVALID encoding"; - return "$utf8, undef" unless defined $a; - my $is_ascii = $a =~ m/^[\000-\177]*$/; - return sprintf "%s, %s, %d characters %d bytes", - $utf8, $is_ascii ? "ASCII" : "non-ASCII", - length($a), bytes::length($a); -} - -sub data_diff { - my ($a, $b, $logical) = @_; - my $diff = data_string_diff($a, $b); - return "" if $logical and !$diff; - my $a_desc = data_string_desc($a); - my $b_desc = data_string_desc($b); - return "" if !$diff and $a_desc eq $b_desc; - $diff ||= "Strings contain the same sequence of characters" if length($a); - $diff .= "\n" if $diff; - return "a: $a_desc\nb: $b_desc\n$diff"; -} - -sub sql_type_cast { - my (undef, $sql_type, $flags) = @_; - return -1 unless defined $_[0]; - my $cast_ok = 1; - my $evalret = eval { - use warnings FATAL => qw(numeric); - if ($sql_type == DBI::SQL_INTEGER()) { my $d = $_[0] + 0; return 1; } - elsif ($sql_type == DBI::SQL_DOUBLE()) { my $d = $_[0] + 0.0; return 1; } - elsif ($sql_type == DBI::SQL_NUMERIC()) { my $d = $_[0] + 0.0; return 1; } - else { return -2; } - } or $^W && warn $@; - return $evalret if defined($evalret) && ($evalret == -2); - $cast_ok = 0 unless $evalret; - return 2 if $cast_ok; - return 0 if $flags & DBI::DBIstcf_STRICT(); - return 1; -} - -sub dbi_time { return time(); } - -1; diff --git a/src/test/resources/unit/my_short_circuit_scope_exit.t b/src/test/resources/unit/my_short_circuit_scope_exit.t new file mode 100644 index 000000000..0300a3660 --- /dev/null +++ b/src/test/resources/unit/my_short_circuit_scope_exit.t @@ -0,0 +1,73 @@ +use strict; +use warnings; +print "1..6\n"; + +# Regression test for the interpreter-backend bug where a `my` variable +# declared inside a short-circuiting expression left stale data in its +# register when the short-circuit skipped the initialisation. When the +# enclosing scope exited, SCOPE_EXIT_CLEANUP crashed with +# "RuntimeList cannot be cast to RuntimeScalar". +# +# Before the fix this pattern would crash reliably under the +# JVM->interpreter fallback path when the sub was large enough to trip +# JVM bytecode verification. + +# --- Test 1: simple short-circuit my-assignment ----------------------- +# Ensure `my $h_new` inside `and defined((my $h_new = ...)->{k})` works. +sub check_short_circuit { + my $arg = shift; + if ( ref($arg) + and UNIVERSAL::isa($arg, 'HASH') + and defined( (my $h_new = $arg)->{key} ) ) + { + return $h_new->{key}; + } + return 'no-match'; +} + +print "not " unless check_short_circuit(undef) eq 'no-match'; +print "ok 1 - skipped my-assignment via ref() short-circuit\n"; + +print "not " unless check_short_circuit('plain-string') eq 'no-match'; +print "ok 2 - skipped my-assignment via isa() short-circuit\n"; + +print "not " unless check_short_circuit({ key => 'OK' }) eq 'OK'; +print "ok 3 - reached my-assignment and read the value\n"; + +# --- Test 2: eval'd sub with large body + same pattern ---------------- +# This shape matches DBI::PurePerl's dispatch wrapper, which is the +# real-world case that first surfaced the bug. Building the sub via +# eval STRING forces the interpreter path in many PerlOnJava modes. +my $eval_code = q{ + sub { + my @ret = @_; + # Dummy temp-register-consuming statement before the my-decl: + my $prev = join " ", map { "x$_" } @ret; + if ( ref $ret[0] + and UNIVERSAL::isa($ret[0], 'HASH') + and defined( (my $h_new = $ret[0])->{key} ) ) + { + return "found:" . $h_new->{key}; + } + return "fallback:$prev"; + } +}; +my $sub = eval $eval_code; +die $@ if $@; + +print "not " unless $sub->({ key => 'yes' }, 'ignored') eq 'found:yes'; +print "ok 4 - eval'd sub found key in hashref\n"; + +print "not " unless $sub->('str', 'ignored') =~ /^fallback:/; +print "ok 5 - eval'd sub took fallback path without crashing\n"; + +# --- Test 3: scope-exit cleanup safe even with stale register --------- +# Call the sub repeatedly so any lingering register reuse across +# invocations is exercised. +my $ok = 1; +for my $i (1..100) { + my $r = $sub->($i % 2 ? { key => $i } : "plain-$i"); + $ok = 0 unless defined $r && length $r; +} +print "not " unless $ok; +print "ok 6 - 100 iterations without scope-exit crash\n";