diff --git a/dev/modules/README.md b/dev/modules/README.md index c30c3d4a1..0e23bd47b 100644 --- a/dev/modules/README.md +++ b/dev/modules/README.md @@ -13,6 +13,7 @@ This directory contains design documents and guides related to porting CPAN modu | [makemaker_perlonjava.md](makemaker_perlonjava.md) | ExtUtils::MakeMaker implementation | | [cpan_client.md](cpan_client.md) | jcpan - CPAN client for PerlOnJava | | [dbix_class.md](dbix_class.md) | DBIx::Class support (in progress) | +| [dbi_test_parity.md](dbi_test_parity.md) | DBI test-suite parity (~13.5× more passes than master; Phases 1–4 done, incl. a tied-hash method-dispatch fix in the PerlOnJava runtime) | | [math_bigint_bignum.md](math_bigint_bignum.md) | Math::BigInt / BigFloat / BigRat / bignum support (in progress) | ## Module Status Overview diff --git a/dev/modules/dbi_test_parity.md b/dev/modules/dbi_test_parity.md new file mode 100644 index 000000000..05c0a4feb --- /dev/null +++ b/dev/modules/dbi_test_parity.md @@ -0,0 +1,676 @@ +# Plan: DBI Test Suite Parity + +This document tracks the work needed to make `jcpan -t DBI` (the bundled +DBI test suite, 200 test files) pass on PerlOnJava. + +## Current Baseline + +After Phase 6 (`HandleSetErr`, errstr accumulation with priority +promotion, `Callbacks`, `:preparse_flags`): + +| | Files | Subtests | Passing | Failing | +|---|---|---|---|---| +| `jcpan -t DBI` | 200 | 6570 | 4940 | 1630 | + +Previous baseline (after Phase 5 — HandleError severity / trace-to-file): + +| | Files | Subtests | Passing | Failing | +|---|---|---|---|---| +| `jcpan -t DBI` | 200 | 6294 | 4504 | 1790 | + +Previous baseline (after Phase 4 — tied-hash method-dispatch fix): + +| | Files | Subtests | Passing | Failing | +|---|---|---|---|---| +| `jcpan -t DBI` | 200 | 5890 | 4160 | 1730 | + +Previous baseline (after Phase 3 third batch): + +| | Files | Subtests | Passing | Failing | +|---|---|---|---|---| +| `jcpan -t DBI` | 200 | 5878 | 4156 | 1722 | + +Previous baseline (after Phase 3 second batch — tied handles): + +| | Files | Subtests | Passing | Failing | +|---|---|---|---|---| +| `jcpan -t DBI` | 200 | 5862 | 4116 | 1746 | + +Previous baseline (after Phase 3 first batch): + +| | Files | Subtests | Passing | Failing | +|---|---|---|---|---| +| `jcpan -t DBI` | 200 | 5610 | 3978 | 1632 | + +Previous baseline (after Phase 2 — driver-architecture pieces): + +| | Files | Subtests | Passing | Failing | +|---|---|---|---|---| +| `jcpan -t DBI` | 200 | 1600 | 1240 | 360 | + +Previous baseline (after Phase 1 — runtime interpreter fallback): + +| | Files | Subtests | Passing | Failing | +|---|---|---|---|---| +| `jcpan -t DBI` | 200 | 946 | 676 | 270 | + +Previous baseline (after Exporter wiring only): + +| | Files | Subtests | Passing | Failing | +|---|---|---|---|---| +| `jcpan -t DBI` | 200 | 638 | 368 | 270 | + +Original baseline on master: 562 subtests, 308 passing, 254 failing. + +The remaining failures fall into five categories, listed below in +priority order. The highest priority is now Phase 4 — a PerlOnJava +interpreter bug discovered while working on Phase 3. It blocks an +entire family of DBI profile-related tests and, worse, is a latent +correctness problem that will keep surfacing in unrelated CPAN +modules as long as it's unfixed. + +Phase 1 was a similar hard blocker on the JVM backend — test files +aborted mid-run and masked the real DBI gaps. Now that Phases 1–3 +have opened up most of the suite, the interpreter bug has become +the single biggest lever. + +--- + +## Phase 4 (priority 1, NEW): PerlOnJava bug — method dispatch on tied hash FETCH + +**Status: done (2026-04-22).** Root-cause was narrower than the +repro suggested: `local` was a red herring. The real bug was that +`$tied_hash{key}->method(...)` dispatch on the value returned from +a tied hash FETCH saw only the `TIED_SCALAR` proxy shell, not the +underlying blessed reference, and fell through to the +"stringify-as-package-name" error path. + +### The bug (refined diagnosis) + +Minimal repro: + +```perl +package Tie; +sub TIEHASH { bless \$_[1], $_[0] } +sub FETCH { ${$_[0]}->{$_[1]} } + +package Foo; +sub meth { print "in meth\n"; } + +package main; +my $obj = bless {}, 'Foo'; +my %h; +tie %h, 'Tie', { obj => $obj }; +$h{obj}->meth; # <-- died +``` + +Output before the fix: + +``` +Can't locate object method "meth" via package + "Foo=HASH(0x7276c8cd)" (perhaps you forgot to load ...) +``` + +`ref($h{obj})` returned `"Foo"` (correct) but direct method +dispatch used the scalar's stringification as the package name +(`"Foo=HASH(0x...)"`). + +### Why + +`RuntimeHash.get()` for a tied hash returns a **`TIED_SCALAR` +proxy** — lazily backed by `tiedFetch()` — instead of the fetched +value itself. That's deliberate (so `$h{key} = "x"` can route +through `STORE` and so lvalue semantics work), but the method- +dispatch code in `RuntimeCode.callCached` and `RuntimeCode.call` +only unwrapped `READONLY_SCALAR`, not `TIED_SCALAR`. The latter +hit `isReference(invocant) -> false` and fell through to +`perlClassName = invocant.toString()`, which is what Perl's +default stringification of a blessed hashref looks like — +`Foo=HASH(0x...)`. + +The scalar's stringified class name was then used as the package +to look up the method in, and naturally no such package exists. + +### The fix + +`src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeCode.java`: +at the top of both `callCached` and `call`, unwrap `TIED_SCALAR` +to the fetched value (mirroring the existing handling for +`apply()` at lines 2378 / 2659 / 2846): + +```java +if (runtimeScalar.type == RuntimeScalarType.TIED_SCALAR) { + return callCached(callsiteId, runtimeScalar.tiedFetch(), ...); +} +``` + +`tiedFetch()` is an existing `RuntimeScalar` helper that either +returns the tied handle's `self` (for scalar tie handles) or calls +`TieHash.tiedFetch` for hash-element proxies. + +### Effect + +- The minimal repro passes with both `jperl` (JVM backend) and + `jperl --interpreter`. +- `t/41prof_dump.t` runs 9 subtests before hitting an unrelated + Profile-on-disk issue (was: died after 7). +- `t/42prof_data.t` runs 4 subtests (was: 3). +- Small `jcpan -t DBI` overall delta (+4 passing subtests, + 5886→5890 executed) because these tests have other + Profile-related failures further down. +- No other regressions in `make` or the DBI suite. + +### Still open + +Not strictly related to the tie fix, but discovered during +investigation and worth nothing here: + +- `local` + tied hashes may still have edge cases around restore + ordering. The specific repro in the previous Phase 4 section + now works, but it's worth auditing. +- `RuntimeHash.get()` on tied hashes always builds a fresh proxy + `RuntimeScalar` each call, so repeated `$h{key}` does repeated + `FETCH`es on access. The fix triggers one extra FETCH per + method dispatch; still correct but not free. + +--- + +## Phase 1 (priority 2): fix or fall back from bytecode-gen verifier bug + +**Status: done (2026-04-22). Fell back to the interpreter on +runtime VerifyError rather than fixing the emitter.** + +### The bug + +Running `t/01basics.t` on the JVM backend produces: + +``` +ok 1 - use DBI; +Bad local variable type +Exception Details: + Location: + org/perlonjava/anon1762.apply( + Lorg/perlonjava/runtime/runtimetypes/RuntimeArray;I + )Lorg/perlonjava/runtime/runtimetypes/RuntimeList; @25039: aload + Reason: + Type top (current frame, locals[203]) is not assignable to reference type +``` + +This is a JVM bytecode verifier error on a per-subroutine `apply()` +method. The cause is a PerlOnJava-generated flat method with ~200+ +local variables and inconsistent stack-map frames — any flat Perl +script body with hundreds of top-level statements (here 130+ `cmp_ok` +calls plus 24 `ok`/`is` calls in a single `BEGIN`/top-level) triggers +it. It is not a DBI-specific bug; the same backend bug affects any +sufficiently large test script. + +### Why the existing fallback does not kick in + +`src/main/java/org/perlonjava/app/scriptengine/PerlLanguageProvider.java` +already has an interpreter-fallback path (`needsInterpreterFallback`) +that catches `VerifyError` and messages like `"Method too large"`, +`"dstFrame"`, `"ASM frame computation failed"`, etc. The 01basics.t +failure slips past that path because: + +- the bad class is generated **successfully** (no ASM error during emit); +- the problem is only detected by the JVM verifier at **class-load / + first-invocation time**, long after + `PerlLanguageProvider.compileToRuntimeCode` returns; +- subroutines are compiled and loaded lazily (see + `backend/jvm/EmitSubroutine.java`), and the lazy path does not have + a fallback wrapper around the verify-time error. + +### Plan + +Target: when a JVM-compiled Perl subroutine fails class verification, +automatically recompile that subroutine with the bytecode interpreter +and re-invoke, rather than aborting the process. + +1. **Reproduce in isolation.** Add a tiny repro under + `src/test/resources/backend/`: + ```perl + # 200+ top-level cmp_ok-style calls, enough to trip the same + # "locals[203] is not assignable" verifier error. + ``` + Run it with `./jperl` and confirm the failure, then with + `./jperl --interpreter` and confirm the interpreter executes it + correctly. (We already know the interpreter handles this shape — + `./jperl --interpreter t/01basics.t` runs past the verifier point + and only stops on a different, unrelated issue.) + +2. **Decide: fix the emitter, or fall back.** Two realistic options; + do whichever is smaller: + + a. **Fix the emitter.** The underlying generator bug is that a + local-variable slot ends up with `top` (= uninitialised / + disjoint) on one incoming path and a reference type on another. + Candidates to audit: + - `backend/jvm/EmitBlock.java`, `EmitSubroutine.java`, + `EmitCompilerFlag.java` — how locals are allocated across + nested blocks and re-used; + - `backend/jvm/EmitLiteral.java` — slot reuse for temporaries + in large constant lists; + - ASM `ClassWriter.COMPUTE_FRAMES` vs our manual frame logic + in `EmitControlFlow.java`. + Expect the fix to be: initialise all slots to a consistent + reference type at method entry, or clear/reset slot type on + every entry to a `full_frame` target so the verifier sees a + consistent type. + + b. **Fall back on verifier errors at first call.** If (a) is too + invasive, wire a `try { invoke } catch (VerifyError)` around the + first invocation of a lazily-loaded compiled subroutine. + On catch, rebuild the sub via `BytecodeCompiler` (as the main + script path already does in `PerlLanguageProvider` lines + 519–557) and swap the `MethodHandle` in the `RuntimeCode` + instance to point at the interpreted version. + + This probably belongs in `runtime/runtimetypes/RuntimeCode.java` + or around the `MethodHandle.invokeExact` call site in + `backend/jvm/EmitSubroutine.java`. Add a one-time guard so we + don't retry compiled-then-verify on every call; remember the + fallback and use it directly on subsequent invocations. + +3. **Extend `JPERL_SHOW_FALLBACK` coverage** so both the main-script + fallback and the new per-sub fallback print a "Note: using + interpreter fallback (verify error in sub )" line when the + env var is set. + +4. **Regression test.** Add the repro from step 1 to + `src/test/resources/` and assert it runs to completion. Also + re-run `jcpan -t DBI` and record the new baseline here. + +### Acceptance criteria + +- `./jperl t/01basics.t` (and sibling DBI tests) no longer aborts + with a `VerifyError`; it either runs correctly on the JVM backend + or falls back silently to the interpreter. +- `JPERL_SHOW_FALLBACK=1 ./jperl ` prints a single `Note:` + line identifying the fallback. +- `make` still passes. +- Expected DBI delta: ~25–30 additional test files move from + "Tests: 1 Failed: 0, Parse errors: Bad plan" to reporting real + test results. + +--- + +## Phase 2 (priority 2): missing DBI core internals + +**Status: done (2026-04-22). Pure-Perl DBDs now load and connect.** + +Several tests die with: + +``` +Undefined subroutine &DBI::_new_drh called at t/02dbidrv.t line 28. +Can't locate object method "install_driver" via package "DBI". +``` + +These methods are part of the documented DBI API that driver modules +(including DBI's own `DBD::File`, `DBD::Gofer`, `DBD::Sponge`) build +on. They are currently unimplemented in +`src/main/java/org/perlonjava/runtime/perlmodule/DBI.java`. + +### Plan + +1. **Survey required methods.** Grep the test files and the bundled + `DBD::*` modules for calls that fail: + ``` + grep -rhoE '\bDBI::[A-Za-z_][A-Za-z0-9_]*|DBI->[A-Za-z_][A-Za-z0-9_]*' \ + ~/.cpan/build/DBI-1.647-5/t/ ~/.cpan/build/DBI-1.647-5/lib/ \ + | sort -u + ``` + Expected minimum set (from spot-checking): + - `DBI::_new_drh` — bless a driver handle (`DBI::dr`) with + installed attributes. + - `DBI::_new_dbh` / `DBI::_new_sth` — same for db/statement handles. + - `DBI->install_driver($name)` — locate `DBD::$name`, call its + `driver()` factory, cache result, return the drh. + - `DBI->installed_drivers` (already a stub — verify it actually + reflects loaded drivers). + - `DBI->trace`, `DBI->trace_msg`, `DBI->parse_trace_flag(s)` — + aliased from `DBD::_::common::` in real DBI; needs the + `DBD::_::common` / `DBD::_::db` / `DBD::_::st` base classes + with trace-flag state. + - `$h->set_err`, `$h->err_handler`, `$h->func` — handle-level + helpers used by tests in `t/08keeperr.t` and `t/17handle_error.t`. + +2. **Pick implementation language per method.** Simple glue (e.g. + `_new_drh` just blesses a hash with known attributes) should live + in `src/main/perl/lib/DBI.pm`. Anything that has to interact with + the JDBC driver registry (e.g. `install_driver`) belongs in + `src/main/java/org/perlonjava/runtime/perlmodule/DBI.java`. + +3. **Make `install_driver` work with bundled DBDs.** The test suite + loads the bundled pure-Perl drivers: + - `DBD::ExampleP` — trivial Perl-only driver used by many tests; + - `DBD::NullP` — even simpler, used for negative tests; + - `DBD::Sponge` — used by `fetchall_arrayref` tests. + Verify each loads and `install_driver("ExampleP")` returns a + working drh. These drivers already ship in + `$HOME/.perlonjava/lib/DBD/` after `jcpan -i DBI`. + +4. **Wire `DBD::_::common` / `db` / `st` base classes.** Real DBI + exposes these as parent packages that drh/dbh/sth inherit from + (in addition to the driver-specific `DBD::X::dr` etc.). Tests + probe things like `ref($dbh)->isa('DBD::_::db')`. Add empty + packages in `DBI.pm` with the required base methods (`trace`, + `trace_msg`, `set_err`, `err`, `errstr`, `state`, `func`) wired + to the existing Java implementation or to simple Perl stubs. + +### Acceptance criteria + +- `./jperl ~/.cpan/build/DBI-1.647-5/t/02dbidrv.t` runs past line 155 + (where it currently dies on `install_driver`). +- `./jperl -e 'use DBI; my $drh = DBI->install_driver("ExampleP"); print ref $drh'` + prints `DBD::ExampleP::dr`. +- Expected DBI delta: `t/02dbidrv.t`, `t/07kids.t`, + `t/17handle_error.t`, `t/10examp.t` start reporting meaningful + results instead of blowing up early. + +--- + +## Phase 3 (priority 3): pure-Perl subdrivers + +Most of the 180 failing wrapper files belong to three pure-Perl +subdriver axes that real DBI ships and tests: + +| Axis | Prefix | Implemented? | +|---|---|---| +| Base tests (no wrapper) | `01basics.t` etc. | mostly hits Phase 1/2 issues | +| `DBD::Gofer` | `zvg_*` | no — Gofer transport missing | +| `DBI::SQL::Nano` | `zvn_*` | partially — test framework only needs the module to load | +| `DBI::PurePerl` | `zvp_*` | no — module aborts on load today | +| combinations | `zvxg*_*` | combinations of the above | + +The two big missing pieces: + +### 3a. `DBI::PurePerl` + +`lib/DBI/PurePerl.pm` is installed by `jcpan -i DBI` but fails to load +because it assumes `DBI::st::TIEHASH`, `DBI::db::TIEHASH`, +`%DBI::installed_drh`, and the whole tied-hash handle model — none of +which our Java-backed DBI uses. + +Options: +- **Skip cleanly.** Make `DBI::PurePerl` `warn` and `exit` when + loaded under PerlOnJava so the `zvp_*` wrappers are skipped + rather than counted as failures. Low effort, immediate win on the + overall file count. +- **Port properly.** Much bigger: we would need Perl-side handle + objects tied to the same Java DBI state. Probably not worth it + unless a user actually needs `DBI_PUREPERL=1`. + +**Recommendation**: do the skip-cleanly approach first. Revisit if +there's demand. + +### 3b. `DBD::File` / `DBD::DBM` + +Used by `t/49dbd_file.t`, `t/50dbm_simple.t`, `t/51dbm_file.t`, +`t/52dbm_complex.t`, `t/53sqlengine_adv.t`, `t/54_dbd_mem.t`, and +every `zv*_49..54` variant. These drivers implement a SQL engine +(`DBI::DBD::SqlEngine`) over the filesystem / DBM / in-memory +storage. + +The hard dependency is `SQL::Statement` and `Text::CSV_XS`. +`SQL::Statement` is pure Perl and should load. `Text::CSV_XS` is +XS — check whether `Text::CSV` (pure Perl) satisfies DBD::File's +requirements. + +Plan: +1. Verify `SQL::Statement` loads under PerlOnJava. +2. Run `./jperl t/49dbd_file.t` and triage the first failure. +3. Decide whether to port the missing bits or mark the family + as skipped with a clear reason. + +### 3c. `DBD::Gofer` + +Gofer is a remote-DBI transport using stream / pipe / HTTP. Tests +use the in-process `null` transport. The whole family (`zvg_*`) is +probably tractable if and only if `DBI::Gofer::Transport::null` +loads cleanly — which requires tie-hash compatibility similar to +Phase 3a. Defer until after Phase 1 & 2 are done so we can measure +the real baseline. + +### Acceptance criteria + +- `zvp_*` wrappers are either skipped with a clear "skipped under + PerlOnJava: DBI::PurePerl requires tied-hash handles" or pass. +- `t/49dbd_file.t` and friends either pass or are skipped with a + concrete reason. +- Expected DBI delta: of the remaining ~180 failing files, ~120 + should move to "skipped" or "passed". + +--- + +## Phase 4 (priority 4): everything else + +Anything left after Phase 3 is bug-by-bug DBI or subdriver work: +callbacks (`t/70callbacks.t`), handle-error ordering +(`t/17handle_error.t`), profiling (`t/40profile.t`, +`t/41prof_dump.t`, `t/42prof_data.t`, `t/43prof_env.t`), tainting +(skipped already because we don't run with `perl -T`), threads +(skipped already), proxy (`t/80proxy.t`, needs `RPC::PlServer`). + +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. + +### Completed + +- [x] **2026-04-22 — Exporter fix.** PR #540. + - Added `%EXPORT_TAGS` for `:sql_types`, `:sql_cursor_types`, + `:utils`, `:profile` to `src/main/perl/lib/DBI.pm`. + - Added missing constants (`SQL_INTERVAL_*`, `SQL_ARRAY_LOCATOR`, + `SQL_CURSOR_*`, `DBIstcf_*`). + - Ported `neat`, `neat_list`, `looks_like_number`, + `data_string_diff`, `data_string_desc`, `data_diff`, + `dump_results`, `sql_type_cast`, `dbi_time` into + `src/main/perl/lib/DBI/_Utils.pm`. + - Baseline went from 308/562 passing to 368/638 passing. + +- [x] **2026-04-22 — Phase 1: runtime interpreter fallback.** PR #542. + - Added a second try/catch at the `runtimeCode.apply(...)` call + site in `PerlLanguageProvider.executeCode`. The existing + compile-time fallback path only runs while + `compileToExecutable` is executing, but HotSpot defers + per-method bytecode verification to the first invocation, + so `VerifyError` / `ClassFormatError` propagated past that + point. Now we re-use `needsInterpreterFallback` at invocation + time, recompile the AST through `BytecodeCompiler`, and re-run + `apply()` on the interpreted form. BEGIN / CHECK / INIT have + already run by this point and the main body has not, so retry + is safe. + - `JPERL_SHOW_FALLBACK=1` now also prints a + "Note: Using interpreter fallback (verify error at first call)." + line when this new path fires. + - Baseline went from 368/638 passing to 676/946 passing + (+308 additional subtests now execute successfully). Same 270 + still fail — those are Phase 2/3 DBI-level issues that were + previously hidden behind the verifier crash. + +- [x] **2026-04-22 — Phase 2: driver-architecture pieces.** PR TBD. + - Added `DBI->install_driver`, `DBI->data_sources`, + `DBI->available_drivers`, `DBI->installed_drivers`, + `DBI->setup_driver`, `DBI::_new_drh`, `DBI::_new_dbh`, + `DBI::_new_sth`, `DBI::_get_imp_data` in the new + `src/main/perl/lib/DBI/_Handles.pm`. + - Added `DBD::_::common` / `dr` / `db` / `st` base classes with + FETCH, STORE, err, errstr, state, set_err, trace, trace_msg, + parse_trace_flag(s), func, dump_handle, default connect, + connect_cached, quote, data_sources, disconnect, finish, + fetchrow_array/hashref, rows, etc. — enough for the bundled + pure-Perl DBDs to work (`DBD::NullP`, `DBD::ExampleP`, + `DBD::Sponge`, `DBD::Mem`, `DBD::File`, `DBD::DBM`). + - Stubbed `DBI::dr` / `DBI::db` / `DBI::st` packages so + `isa('DBI::dr')` etc. pass; `DBD::_::` inherits from + them. + - Modified `DBI->connect` in `DBI.pm`: when the DSN's driver + (`DBD::$name`) has a `driver()` method but no `_dsn_to_jdbc` + (i.e. it's a pure-Perl DBD), route through + `install_driver($name)->connect(...)` instead of the JDBC path. + - Baseline went from 676/946 passing to 1240/1600 passing + (+564 additional subtests now pass; +654 more execute). 10 + fewer test files fail overall. + +- [x] **2026-04-22 — Phase 3 first batch: more DBI internals.** + - (As before.) Baseline 1240/1600 → 3978/5610 passing. + +- [x] **2026-04-22 — Phase 3 second batch: tied-handle semantics.** + - (As before.) Baseline 3978/5610 → 4116/5862 passing. + +- [x] **2026-04-22 — Phase 3 third batch: Profile / transactions / misc.** + - Added `DBD::_::common::STORE` magic for the `Profile` attribute: + a string like `"2/DBI::ProfileDumper/File:path"` is upgraded to + a real `DBI::ProfileDumper` object on assignment (and on + `_new_dbh` when passed via the connect attr hash). + - `_new_sth` inherits `Profile` from the parent dbh. + - Added `DBI->visit_handles` that walks `%installed_drh` and + recurses via `visit_child_handles`. + - Fixed `begin_work` / `commit` / `rollback` so transactions round- + trip `AutoCommit` / `BegunWork` correctly. + - Added `AutoCommit` sentinel translation in + `DBD::_::common::FETCH`: the `-900` / `-901` values that pure- + Perl drivers STORE (to signal "I've handled AutoCommit myself") + are translated back to `0` / `1` on FETCH, matching real DBI's + XS behaviour. + - Made DBI.pm's `connect` wrapper re-apply the user's attr hash + on the returned dbh (Profile / RaiseError / PrintError / + HandleError) so driver `connect()` implementations that ignore + most of the attr hash still get those attributes set. + - Baseline 4116/5862 → 4156/5878 passing (+40 subtests). 2 more + test files pass (164/200 failing, was 166/200). + +- [x] **2026-04-22 — Phase 4: tied-hash method-dispatch fix.** + - `RuntimeCode.callCached` and `RuntimeCode.call` now unwrap + `TIED_SCALAR` to the underlying fetched value before + checking `isReference` / `blessId`. Without this, method + dispatch on `$tied_hash{key}->method(...)` treated the + stringified form of the blessed ref as the package name. + - Fixes both JVM backend and `--interpreter` path. + - Baseline 4156/5878 → 4160/5890 passing. Small overall delta + because the profile tests that were blocked on this have + other downstream issues. + - PerlOnJava bug fix; useful for any CPAN module that does + direct method calls through tied hash elements (DBI itself, + DBIx::Class, Catalyst-style dispatch tables). + +- [x] **2026-04-22 — Phase 5: HandleError / set_err severity, trace-to-file.** + - Rewrote `DBD::_::common::set_err` to match real DBI's three + severity levels: undef (clear), "" (info, silent), + 0/"0" (warning — fires HandleError / RaiseWarn / PrintWarn), + and truthy (error — fires HandleError unconditionally, plus + RaiseError / PrintError). Error messages now follow real DBI's + `"IMPL_CLASS METHOD failed|warning: errstr"` format that the + self-tests regex against. + - Added real trace-file support in DBI.pm: `DBI->trace($level, + $file)` opens and installs a process-global `$DBI::tfh` + filehandle; `trace(0, undef)` closes it; `dump_handle` and + both `trace_msg`s (top-level and DBD::_::common) write to + `DBI::_trace_fh()` which returns `$DBI::tfh` if set else + STDERR. + - `t/17handle_error.t`: 2 passing → **all 84** passing. + - `t/09trace.t`: 82 passing → 83 passing (16 still fail; + remaining are parse-trace-flag details). + - `t/19fhtrace.t`: 11 passing → 19 passing. + - Baseline 4160/5890 → **4504/6294 passing** (+344 passes, + +404 more subtests executed). **8 fewer test files fail + overall (156/200, was 164/200).** + +- [x] **2026-04-22 — Phase 6: HandleSetErr, errstr accumulation, Callbacks.** + - `set_err` now runs `HandleSetErr` first (returns true to + short-circuit, can mutate err/errstr/state in-place). + - Errstr accumulates across calls with real DBI's + `"[err was X now Y]"` / `"[state was X now Y]"` / `"\n$msg"` + annotations, and err is promoted only when the new value is + higher-priority (`truthy > "0" > "" > undef`, judged by + `length()`). + - Added `Callbacks` support in `DBI::_::OuterHandle::AUTOLOAD`: + before method dispatch, fire `$h->{Callbacks}{$method}` (or + the `"*"` wildcard if the specific method isn't registered). + Callback runs in the caller's context; if it returns a + defined value the method dispatch is short-circuited. + - Added `:preparse_flags` export tag (empty) so + `use DBI qw(:preparse_flags)` works in tests that probe the + import even when they don't use the preparser itself. + - `t/08keeperr.t`: 17 passing → **84 passing** (7 still fail). + - `t/70callbacks.t`: 36 passing → **67 passing**. + - `t/17handle_error.t` still all 84 passing (no regression). + - Baseline 4504/6294 → **4940/6570 passing** (+436 passes). + +### Next Steps + +1. **Profile-on-disk internals.** `t/41prof_dump.t` / + `t/42prof_data.t` / `t/43prof_env.t` still fail after Phase 4 + — not blocked by the tie bug anymore, but the + ProfileDumper-writes-to-file path is not exercising correctly. + Likely `flush_to_disk` path needs more DBI::Profile internals. +2. **HandleError flow** (`t/17handle_error.t`, `t/08keeperr.t`) — + the ordering between RaiseError, PrintError, HandleError, and + set_err is subtle and our current implementation cuts some + corners. +3. **Trace file support** (`t/09trace.t`, `t/19fhtrace.t`) — + `trace($level, $output)` currently only tracks a level, no + output redirection. +4. **`t/16destroy.t` Active-in-DESTROY semantics.** +5. Periodically re-run `jcpan -t DBI` to track progress. + +### Open Questions + +- Is it worth porting `DBI::PurePerl` at all, or should we just + skip it under PerlOnJava? See Phase 3a. +- Does anyone actually use Gofer on PerlOnJava? Phase 3c can + probably be skipped entirely. +- Phase 4's bug: is it purely in the `local` restore path, or + does method dispatch on a once-`local`-ized tied slot read + the wrong SV? Minimal repro below will pin it down. +- **Reuse `DBI::PurePerl` to shrink `DBI/_Handles.pm`?** The + upstream `DBI::PurePerl` (~1280 lines) already implements most + of what our `DBI/_Handles.pm` (~1210 lines) does: handle + factories (`_new_drh` / `_new_dbh` / `_new_sth`), `set_err`, + `trace_msg`, the `DBD::_::common` / `dr` / `db` / `st` base + packages, and `DBI::db::TIEHASH` / `DBI::dr::TIEHASH` / + `DBI::st::TIEHASH` tied-handle dispatch. It's loaded by the + upstream XS DBI when `$ENV{DBI_PUREPERL}` is set. A future PR + could: + 1. Teach our `DBI.pm` to `require DBI::PurePerl` unconditionally + (we don't have the XS path anyway). + 2. Keep the JDBC-backed `connect` wrapper on top of whatever + PurePerl provides. + 3. Delete most of `_Handles.pm` (retaining only the shim + pieces PurePerl doesn't cover — e.g. `DBI->internal`, + the Profile-spec auto-upgrade hook, Kids/ChildHandles + bookkeeping). + Not done in this PR because it's a significant architectural + change and risks regressions in the existing 4500+ passing + subtests. + + The rest of upstream DBI's ecosystem is already reused as-is: + `DBI::Profile`, `DBI::ProfileData`, `DBI::ProfileDumper`, + `DBI::SQL::Nano`, `DBI::DBD::SqlEngine`, `DBI::Gofer::*`, + `DBD::File` / `DBD::DBM` / `DBD::Sponge` / `DBD::NullP` / + `DBD::ExampleP`, etc. + +--- + +## Related Documents + +- [`dev/modules/dbix_class.md`](dbix_class.md) — DBIx::Class sits on + top of DBI; progress here directly helps DBIx::Class too. +- [`AGENTS.md`](../../AGENTS.md) — includes the `JPERL_SHOW_FALLBACK` + debug-env var mentioned in Phase 1. +- [`src/main/java/org/perlonjava/app/scriptengine/PerlLanguageProvider.java`](../../src/main/java/org/perlonjava/app/scriptengine/PerlLanguageProvider.java) + — existing interpreter-fallback path we'd extend in Phase 1. +- PerlOnJava source dirs relevant to Phase 4: + - [`src/main/java/org/perlonjava/backend/bytecode/`](../../src/main/java/org/perlonjava/backend/bytecode/) + — the interpreter backend (`--interpreter`), where tie magic + and `local` restore hooks live. + - [`src/main/java/org/perlonjava/backend/jvm/`](../../src/main/java/org/perlonjava/backend/jvm/) + — the JVM backend emitter; both backends need the fix. + - [`src/main/java/org/perlonjava/runtime/`](../../src/main/java/org/perlonjava/runtime/) + — tied hash magic (TIEHASH / FETCH / STORE dispatch) lives + here; the scalar representation that method dispatch reads is + likely also here. diff --git a/src/main/java/org/perlonjava/app/scriptengine/PerlLanguageProvider.java b/src/main/java/org/perlonjava/app/scriptengine/PerlLanguageProvider.java index b288e6897..735fc6b5e 100644 --- a/src/main/java/org/perlonjava/app/scriptengine/PerlLanguageProvider.java +++ b/src/main/java/org/perlonjava/app/scriptengine/PerlLanguageProvider.java @@ -232,7 +232,7 @@ public static RuntimeList executePerlCode(CompilerOptions compilerOptions, RuntimeCode runtimeCode = compileToExecutable(ast, ctx); // Execute (unified path for both backends) - return executeCode(runtimeCode, ctx, isTopLevelScript, callerContext); + return executeCode(runtimeCode, ast, ctx, isTopLevelScript, callerContext); } finally { // Restore the caller's scope so require/do doesn't leak its scope to the caller. // But do NOT restore for top-level scripts - we want the main script's pragmas to persist. @@ -337,7 +337,7 @@ public static RuntimeList executePerlAST(Node ast, // Compile to executable (compiler or interpreter based on flag) RuntimeCode runtimeCode = compileToExecutable(ast, ctx); - return executeCode(runtimeCode, ctx, false, contextType); + return executeCode(runtimeCode, ast, ctx, false, contextType); } finally { // Propagate $^H changes back to the caller's scope so subsequent // code in the same lexical block sees the updated hints @@ -358,12 +358,16 @@ public static RuntimeList executePerlAST(Node ast, * Works with both interpreter (InterpretedCode) and compiler (CompiledCode). * * @param runtimeCode The compiled RuntimeCode instance (InterpretedCode or CompiledCode) + * @param ast The AST used to produce runtimeCode. Retained so we can + * recompile to the interpreter backend if the JVM-verified + * class is rejected by the verifier at first invocation + * (i.e. VerifyError thrown from {@code runtimeCode.apply(...)}). * @param ctx The emitter context. * @param isMainProgram Indicates if this is the main program. * @param callerContext The calling context (VOID, SCALAR, LIST) or -1 for default * @return The result of the Perl code execution. */ - private static RuntimeList executeCode(RuntimeCode runtimeCode, EmitterContext ctx, boolean isMainProgram, int callerContext) throws Exception { + private static RuntimeList executeCode(RuntimeCode runtimeCode, Node ast, EmitterContext ctx, boolean isMainProgram, int callerContext) throws Exception { runUnitcheckBlocks(ctx.unitcheckBlocks); if (isMainProgram) { // Push a CallerStack entry so caller() inside CHECK/INIT/END blocks @@ -396,8 +400,36 @@ private static RuntimeList executeCode(RuntimeCode runtimeCode, EmitterContext c int executionContext = callerContext >= 0 ? callerContext : (isMainProgram ? RuntimeContextType.VOID : RuntimeContextType.SCALAR); - // Call apply() directly - works for both InterpretedCode and CompiledCode - result = runtimeCode.apply(new RuntimeArray(), executionContext); + // Call apply() directly - works for both InterpretedCode and CompiledCode. + // + // If the JVM backend produced a class whose apply() fails bytecode + // verification (VerifyError / ClassFormatError on first invocation), + // transparently recompile the AST with the interpreter backend and + // retry. The compile-time fallback in compileToExecutable only fires + // while createClassWithMethod is running, but HotSpot defers verifier + // checks to the first call, so we have to catch again here. BEGIN / + // CHECK / INIT have already run, and the main body has not, so + // re-executing apply() on the interpreted form is safe. + try { + result = runtimeCode.apply(new RuntimeArray(), executionContext); + } catch (Throwable t) { + if (runtimeCode instanceof CompiledCode && needsInterpreterFallback(t)) { + if (System.getenv("JPERL_SHOW_FALLBACK") != null) { + System.err.println("Note: Using interpreter fallback (verify error at first call)."); + } + if (CompilerOptions.DEBUG_ENABLED) { + ctx.logDebug("Falling back to bytecode interpreter after runtime verify error: " + t); + } + BytecodeCompiler compiler = new BytecodeCompiler( + ctx.compilerOptions.fileName, + 1, + ctx.errorUtil); + InterpretedCode interpretedCode = compiler.compile(ast, ctx); + result = interpretedCode.apply(new RuntimeArray(), executionContext); + } else { + throw t; + } + } try { if (isMainProgram) { diff --git a/src/main/java/org/perlonjava/core/Configuration.java b/src/main/java/org/perlonjava/core/Configuration.java index e0766f0ae..e61177f82 100644 --- a/src/main/java/org/perlonjava/core/Configuration.java +++ b/src/main/java/org/perlonjava/core/Configuration.java @@ -33,14 +33,14 @@ public final class Configuration { * Automatically populated by Gradle/Maven during build. * DO NOT EDIT MANUALLY - this value is replaced at build time. */ - public static final String gitCommitId = "5ccd1c339"; + public static final String gitCommitId = "00cdd0b3a"; /** * Git commit date of the build (ISO format: YYYY-MM-DD). * Automatically populated by Gradle/Maven during build. * DO NOT EDIT MANUALLY - this value is replaced at build time. */ - public static final String gitCommitDate = "2026-04-22"; + public static final String gitCommitDate = "2026-04-23"; /** * Build timestamp in Perl 5 "Compiled at" format (e.g., "Apr 7 2026 11:20:00"). @@ -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 22 2026 18:57:07"; + public static final String buildTimestamp = "Apr 23 2026 07:38:18"; // Prevent instantiation private Configuration() { diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeCode.java b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeCode.java index 3478b9a31..6c04c59f3 100644 --- a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeCode.java +++ b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeCode.java @@ -1756,6 +1756,14 @@ public static RuntimeList callCached(int callsiteId, RuntimeScalar currentSub, RuntimeBase[] args, int callContext) { + // Handle tied scalars: the invocant may be a TIED_SCALAR returned + // from a tied hash / array FETCH (e.g. $tied_hash{obj}->method). + // Dispatch sees only the TIED_SCALAR shell, so unwrap to the + // underlying blessed reference before cache / invocant checks. + if (runtimeScalar.type == RuntimeScalarType.TIED_SCALAR) { + return callCached(callsiteId, runtimeScalar.tiedFetch(), method, + currentSub, args, callContext); + } // Fast path: check inline cache for monomorphic call sites if (method.type == RuntimeScalarType.STRING || method.type == RuntimeScalarType.BYTE_STRING) { // Unwrap READONLY_SCALAR for blessId check (same as in call()) @@ -1875,6 +1883,13 @@ public static RuntimeList call(RuntimeScalar runtimeScalar, RuntimeScalar currentSub, RuntimeArray args, int callContext) { + // Handle tied scalars: the invocant may be a TIED_SCALAR returned + // from a tied hash / array FETCH. Unwrap before dispatch so + // isReference / blessId checks see the real underlying value. + if (runtimeScalar.type == RuntimeScalarType.TIED_SCALAR) { + return call(runtimeScalar.tiedFetch(), method, currentSub, args, callContext); + } + // insert `this` into the parameter list args.elements.addFirst(runtimeScalar); diff --git a/src/main/perl/lib/DBI.pm b/src/main/perl/lib/DBI.pm index dd0d115ac..2bcf11a46 100644 --- a/src/main/perl/lib/DBI.pm +++ b/src/main/perl/lib/DBI.pm @@ -3,16 +3,21 @@ use strict; use warnings; use Scalar::Util (); use XSLoader; +use Exporter (); our $VERSION = '1.643'; XSLoader::load( 'DBI' ); # DBI::db and DBI::st inherit from DBI so method dispatch works -# when handles are blessed into subclass packages +# 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'); +our $neat_maxlen = 1000; + # 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 @@ -107,7 +112,9 @@ sub _handle_error_with_handler { # 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 +# 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, @@ -130,6 +137,9 @@ use constant { SQL_FLOAT => 6, SQL_REAL => 7, SQL_DOUBLE => 8, +}; + +use constant { SQL_DATETIME => 9, SQL_DATE => 9, SQL_INTERVAL => 10, @@ -146,7 +156,9 @@ use constant { 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, @@ -154,6 +166,46 @@ use constant { SQL_TYPE_TIMESTAMP_WITH_TIMEZONE => 95, }; +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, +}; + +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, +}; + +# 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 @@ -187,6 +239,34 @@ use constant { 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 that the + # driver may not have copied over (Profile, + # RaiseError, PrintError, HandleError, etc.). + if (ref $attr eq 'HASH') { + for my $k (keys %$attr) { + $dbh->STORE($k, $attr->{$k}) + if !exists $dbh->{$k} + || (!defined $dbh->{$k} && defined $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) { @@ -538,26 +618,65 @@ sub bind_columns { sub trace { my ($dbh, $level, $output) = @_; - $level ||= 0; + my $old_level; - $dbh->{TraceLevel} = $level; - $dbh->{TraceOutput} = $output if defined $output; + 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; + } - return $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; + } + } + + return $old_level; +} + +# _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 trace_msg { my ($dbh, $msg, $level) = @_; - $level ||= 0; + $level ||= 1; - my $current_level = $dbh->{TraceLevel} || 0; + my $current_level = ref($dbh) + ? ($dbh->{TraceLevel} || 0) + : ($DBI::dbi_debug || 0); if ($level <= $current_level) { - if ($dbh->{TraceOutput}) { - # TODO: Write to custom output - print STDERR $msg; - } else { - print STDERR $msg; - } + my $fh = DBI::_trace_fh(); + print $fh $msg; } return 1; } diff --git a/src/main/perl/lib/DBI/_Handles.pm b/src/main/perl/lib/DBI/_Handles.pm new file mode 100644 index 000000000..d1a023c20 --- /dev/null +++ b/src/main/perl/lib/DBI/_Handles.pm @@ -0,0 +1,1313 @@ +# 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, + %{ $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}; + $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; + our @ISA = ('DBD::_::dr'); + sub DESTROY { } + } + $_internal_drh = bless { + Name => 'Switch', + Version => $DBI::VERSION, + ImplementorClass => 'DBD::Switch::dr', + Kids => 0, + ActiveKids => 0, + }, 'DBD::Switch::dr'; + 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. +sub _concat_hash_sorted { + my ($hash, $kv_sep, $pair_sep, $neat, $sort_type) = @_; + return '' unless ref($hash) eq 'HASH'; + $kv_sep = '=' unless defined $kv_sep; + $pair_sep = ',' unless defined $pair_sep; + my @parts; + for my $k (sort keys %$hash) { + 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; + + 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'; + } + 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 =~ /^(?: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) { + $h->{TraceLevel} = $level; + } else { + $DBI::dbi_debug = $level; + } + } + 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); + 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; + } + } + 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 new file mode 100644 index 000000000..5a40478ec --- /dev/null +++ b/src/main/perl/lib/DBI/_Utils.pm @@ -0,0 +1,185 @@ +# 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;