From b408fc1090b84518073be8b87d3c8a46fd53128c Mon Sep 17 00:00:00 2001 From: "Flavio S. Glock" Date: Wed, 22 Apr 2026 15:49:02 +0200 Subject: [PATCH 01/11] fix(DBI): wire Exporter + :sql_types/:sql_cursor_types/:utils tags The bundled DBI.pm declared SQL_* constants but never set up @EXPORT_OK / %EXPORT_TAGS, so `use DBI qw(:sql_types ...)` (which essentially every DBI test uses) pulled nothing into the caller's namespace and failed at compile time with "Bareword SQL_GUID not allowed while strict subs in use". This change: - makes DBI inherit from Exporter and registers the four standard export tags (sql_types, sql_cursor_types, utils, profile); - adds the constants that were missing (SQL_INTERVAL_*, SQL_ARRAY_LOCATOR, SQL_MULTISET_LOCATOR, SQL_CURSOR_*, DBIstcf_STRICT/DISCARD_STRING); - ports the small utility functions from DBI / DBI::PurePerl (neat, neat_list, looks_like_number, data_string_diff, data_string_desc, data_diff, dump_results, sql_type_cast, dbi_time) into a sibling DBI::_Utils module, required by DBI.pm. The utils live in a separate .pm so PerlOnJava compiles them to their own JVM class; combining everything into a single DBI.pm tripped a per-method bytecode limit in our backend. Effect on `jcpan -t DBI`: before: 200 files, 562 subtests, 308 passing, 254 failing after: 200 files, 638 subtests, 368 passing, 270 failing The remaining failures are unrelated issues (missing DBI::install_driver / DBI::_new_drh, DBD::File / DBD::DBM / gofer / DBI::PurePerl not implemented, plus a separate bytecode verifier bug on very large flat test scripts). Generated with [Devin](https://cli.devin.ai/docs) Co-Authored-By: Devin <158243242+devin-ai-integration[bot]@users.noreply.github.com> --- .../org/perlonjava/core/Configuration.java | 4 +- src/main/perl/lib/DBI.pm | 48 ++++- src/main/perl/lib/DBI/_Utils.pm | 180 ++++++++++++++++++ 3 files changed, 228 insertions(+), 4 deletions(-) create mode 100644 src/main/perl/lib/DBI/_Utils.pm diff --git a/src/main/java/org/perlonjava/core/Configuration.java b/src/main/java/org/perlonjava/core/Configuration.java index e0766f0ae..ed2791fa2 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 = "5ccd1c339"; + public static final String gitCommitId = "ba42e2070"; /** * 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 22 2026 18:57:07"; + public static final String buildTimestamp = "Apr 22 2026 15:43:32"; // Prevent instantiation private Configuration() { diff --git a/src/main/perl/lib/DBI.pm b/src/main/perl/lib/DBI.pm index dd0d115ac..ff2271877 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,38 @@ 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; + # 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 diff --git a/src/main/perl/lib/DBI/_Utils.pm b/src/main/perl/lib/DBI/_Utils.pm new file mode 100644 index 000000000..6b789540c --- /dev/null +++ b/src/main/perl/lib/DBI/_Utils.pm @@ -0,0 +1,180 @@ +# 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 + ) ], +); +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; From bf331f4eb6dfa080c5415676795160592c9746da Mon Sep 17 00:00:00 2001 From: "Flavio S. Glock" Date: Wed, 22 Apr 2026 16:13:48 +0200 Subject: [PATCH 02/11] fix(backend): interpreter fallback on runtime VerifyError The existing compile-time interpreter fallback in PerlLanguageProvider.compileToExecutable only catches VerifyError / ClassFormatError thrown while the JVM class is being defined, instantiated, and looked up. HotSpot, however, defers per-method bytecode verification to the first invocation of each method, so a compiled class that the generator produced with inconsistent stack map frames sails past compileToExecutable and only crashes later when executeCode invokes runtimeCode.apply(). The DBI test suite hits this routinely: t/01basics.t's main body has 200+ top-level statements and blows up with "Type top (locals[203]) is not assignable to reference type" at first invocation, even though class loading appeared to succeed. This change adds a second try/catch at the apply() call site in executeCode. On a recoverable error (same needsInterpreterFallback predicate used by the compile-time path), we recompile the AST via BytecodeCompiler and retry apply() on the resulting InterpretedCode. BEGIN / CHECK / INIT blocks have already run by this point and the main body has not, so re-executing apply() on the interpreted form is safe. JPERL_SHOW_FALLBACK=1 now also prints "Note: Using interpreter fallback (verify error at first call)." when this new path fires. Effect on the bundled DBI test suite (`jcpan -t DBI`): before: 638 subtests, 368 passing, 270 failing after: 946 subtests, 676 passing, 270 failing => 308 additional subtests now execute successfully. The same 270 still fail; those are DBI-level issues (missing install_driver / _new_drh, DBD::File, gofer, ...) that were previously hidden behind the verifier crash. See dev/modules/dbi_test_parity.md for the rest of the plan. Generated with [Devin](https://cli.devin.ai/docs) Co-Authored-By: Devin <158243242+devin-ai-integration[bot]@users.noreply.github.com> --- dev/modules/README.md | 1 + dev/modules/dbi_test_parity.md | 370 ++++++++++++++++++ .../scriptengine/PerlLanguageProvider.java | 42 +- .../org/perlonjava/core/Configuration.java | 4 +- 4 files changed, 410 insertions(+), 7 deletions(-) create mode 100644 dev/modules/dbi_test_parity.md diff --git a/dev/modules/README.md b/dev/modules/README.md index c30c3d4a1..f0e0e25e6 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) | Plan to get `jcpan -t DBI` passing (Phase 1: bytecode verifier bug / interpreter fallback) | | [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..ebaed933b --- /dev/null +++ b/dev/modules/dbi_test_parity.md @@ -0,0 +1,370 @@ +# 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 1 (runtime interpreter fallback on VerifyError, PR TBD): + +| | Files | Subtests | Passing | Failing | +|---|---|---|---|---| +| `jcpan -t DBI` | 200 | 946 | 676 | 270 | + +Previous baseline (after [PR #540](https://github.com/fglock/PerlOnJava/pull/540), +Exporter wiring only): + +| | Files | Subtests | Passing | Failing | +|---|---|---|---|---| +| `jcpan -t DBI` | 200 | 638 | 368 | 270 | + +The remaining failures fall into four categories, listed below in +priority order. Phase 1 is the hard blocker — several entire test files +abort mid-run on PerlOnJava backend errors, so we cannot even see what +DBI-level bugs lie behind them until the backend is fixed or we fall +back to the interpreter. + +--- + +## Phase 1 (priority 1): 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 + +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: Phase 1 complete. Phase 2 is next. + +### 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 TBD. + - 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. + +### Next Steps + +1. Start **Phase 2**: implement `DBI->install_driver`, + `DBI::_new_drh`, `DBI::_new_dbh`, `DBI::_new_sth`, and the + `DBD::_::common` / `db` / `st` base classes. This should unblock + `t/02dbidrv.t`, `t/07kids.t`, `t/10examp.t`, + `t/17handle_error.t`, etc. +2. After Phase 2, re-run `jcpan -t DBI` and refresh the baseline + table in this document. + +### 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. + +--- + +## 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. 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 ed2791fa2..17f347b65 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 = "ba42e2070"; + public static final String gitCommitId = "f552b7301"; /** * 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 22 2026 15:43:32"; + public static final String buildTimestamp = "Apr 22 2026 16:07:18"; // Prevent instantiation private Configuration() { From 154096f1eccfce05e10a7f2335b00df9f70686c3 Mon Sep 17 00:00:00 2001 From: "Flavio S. Glock" Date: Wed, 22 Apr 2026 16:53:25 +0200 Subject: [PATCH 03/11] feat(DBI): driver-architecture + pure-Perl DBD support MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Previously `use DBI; DBI->install_driver("NullP")` died with "Undefined subroutine &DBI::install_driver". The bundled DBI.pm talked to the Java DBI backend only, bypassing the DBI driver architecture (DBD::::driver factories, DBI::_new_drh/dbh/sth, DBD::_::common / dr / db / st base classes). That path covers JDBC drivers (SQLite, H2, ...) but not the pure-Perl DBDs bundled with upstream DBI — DBD::NullP, DBD::ExampleP, DBD::Sponge, DBD::Mem, DBD::File, DBD::DBM — which the DBI self-tests rely on extensively. This change adds the minimum driver-architecture pieces needed by those DBDs, in a new file src/main/perl/lib/DBI/_Handles.pm: * DBI->install_driver / installed_drivers / data_sources / available_drivers / setup_driver; * DBI::_new_drh / _new_dbh / _new_sth (handle factories, returning plain blessed hashrefs — no tie magic); * DBI::_get_imp_data (stub); * 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, visit_child_handles, default connect / connect_cached, quote, quote_identifier, data_sources, disconnect, commit, rollback, ping, finish, fetchrow_array, fetchrow_hashref, rows, bind_col(s), bind_param(_array), execute_array, _set_fbav; * Stub DBI::dr / DBI::db / DBI::st packages so `isa('DBI::dr')` succeeds; DBD::_:: inherits from DBI::. DBI.pm's connect wrapper now detects a pure-Perl DBD (has `driver()` but no `_dsn_to_jdbc`) and routes through `install_driver($name)->connect(...)` instead of the JDBC backend. Lives in a separate .pm for the same per-method bytecode-size reason as DBI/_Utils.pm from PR #540. Effect on `jcpan -t DBI` (stacked on PR #542): before: 200 files, 946 subtests, 676 passing, 270 failing after: 200 files, 1600 subtests, 1240 passing, 360 failing => +564 subtests now pass (+654 newly executed). 10 fewer test files fail overall; the remaining failures are real DBI-level issues (DBI::PurePerl, DBD::File/DBM/Gofer, a handful of handle-tracking edge cases) tracked as Phase 3 in the plan. See dev/modules/dbi_test_parity.md. Generated with [Devin](https://cli.devin.ai/docs) Co-Authored-By: Devin <158243242+devin-ai-integration[bot]@users.noreply.github.com> --- dev/modules/dbi_test_parity.md | 53 +- .../org/perlonjava/core/Configuration.java | 4 +- src/main/perl/lib/DBI.pm | 26 + src/main/perl/lib/DBI/_Handles.pm | 477 ++++++++++++++++++ 4 files changed, 548 insertions(+), 12 deletions(-) create mode 100644 src/main/perl/lib/DBI/_Handles.pm diff --git a/dev/modules/dbi_test_parity.md b/dev/modules/dbi_test_parity.md index ebaed933b..9aa944a52 100644 --- a/dev/modules/dbi_test_parity.md +++ b/dev/modules/dbi_test_parity.md @@ -5,7 +5,16 @@ DBI test suite, 200 test files) pass on PerlOnJava. ## Current Baseline -After Phase 1 (runtime interpreter fallback on VerifyError, PR TBD): +After Phase 2 (driver-architecture pieces: `install_driver`, +`_new_drh` / `_new_dbh` / `_new_sth`, `DBD::_::common / dr / db / st` +base classes): + +| | Files | Subtests | Passing | Failing | +|---|---|---|---|---| +| `jcpan -t DBI` | 200 | 1600 | 1240 | 360 | + +Previous baseline (after Phase 1 — runtime interpreter fallback, +[PR #542](https://github.com/fglock/PerlOnJava/pull/542)): | | Files | Subtests | Passing | Failing | |---|---|---|---|---| @@ -147,6 +156,8 @@ and re-invoke, rather than aborting the process. ## Phase 2 (priority 2): missing DBI core internals +**Status: done (2026-04-22). Pure-Perl DBDs now load and connect.** + Several tests die with: ``` @@ -306,7 +317,7 @@ Triage these once Phase 1 & 2 are done and we have clean output. ## Progress Tracking -### Current Status: Phase 1 complete. Phase 2 is next. +### Current Status: Phase 2 complete. Phase 3 is next. ### Completed @@ -321,7 +332,7 @@ Triage these once Phase 1 & 2 are done and we have clean output. `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 TBD. +- [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 @@ -341,15 +352,37 @@ Triage these once Phase 1 & 2 are done and we have clean output. 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. + ### Next Steps -1. Start **Phase 2**: implement `DBI->install_driver`, - `DBI::_new_drh`, `DBI::_new_dbh`, `DBI::_new_sth`, and the - `DBD::_::common` / `db` / `st` base classes. This should unblock - `t/02dbidrv.t`, `t/07kids.t`, `t/10examp.t`, - `t/17handle_error.t`, etc. -2. After Phase 2, re-run `jcpan -t DBI` and refresh the baseline - table in this document. +1. Start **Phase 3**: skip `DBI::PurePerl` cleanly under PerlOnJava + (or decide to port it), and triage `DBD::File` / `DBD::DBM` + behaviour against `t/49dbd_file.t` and friends. `DBD::Gofer` + can be deferred until the others stabilise. +2. After Phase 3, re-run `jcpan -t DBI` and refresh the baseline. ### Open Questions diff --git a/src/main/java/org/perlonjava/core/Configuration.java b/src/main/java/org/perlonjava/core/Configuration.java index 17f347b65..f03519f39 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 = "f552b7301"; + public static final String gitCommitId = "efbf5541d"; /** * 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 22 2026 16:07:18"; + public static final String buildTimestamp = "Apr 22 2026 16:41:49"; // Prevent instantiation private Configuration() { diff --git a/src/main/perl/lib/DBI.pm b/src/main/perl/lib/DBI.pm index ff2271877..bcaf0032b 100644 --- a/src/main/perl/lib/DBI.pm +++ b/src/main/perl/lib/DBI.pm @@ -198,6 +198,14 @@ use constant { # 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 @@ -231,6 +239,24 @@ require DBI::_Utils; 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'); + } + return $dbh; + } + # fall through to JDBC path if install_driver croaked + } } my $dbh = $orig_connect->($class, $dsn, $user, $pass, $attr); if ($dbh && $driver_name) { diff --git a/src/main/perl/lib/DBI/_Handles.pm b/src/main/perl/lib/DBI/_Handles.pm new file mode 100644 index 000000000..cb5b83a4f --- /dev/null +++ b/src/main/perl/lib/DBI/_Handles.pm @@ -0,0 +1,477 @@ +# 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; + +our %installed_drh; # driver_name => $drh + +# ---- handle factories ----------------------------------------------- + +sub _new_drh { + # called by DBD::::driver() with the fully-qualified ::dr + # package name as $class, plus initial attrs and private data. + my ($class, $initial_attr, $imp_data) = @_; + my $drh = { + # defaults real DBI copies down to children + 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, + }; + $drh->{_private_data} = $imp_data if defined $imp_data; + bless $drh, $class; + return wantarray ? ($drh, $drh) : $drh; +} + +sub _new_dbh { + my ($drh, $attr, $imp_data) = @_; + my $imp_class = $drh->{ImplementorClass} + or Carp::croak("DBI _new_dbh: $drh has no ImplementorClass"); + # driver::dr -> driver::db + (my $db_class = $imp_class) =~ s/::dr$/::db/; + my $dbh = { + Err => \my $h_err, + Errstr => \(my $h_errstr = ''), + State => \my $h_state, + TraceLevel => 0, + %{ $attr || {} }, + ImplementorClass => $db_class, + Driver => $drh, + Kids => 0, + ActiveKids => 0, + Active => 0, # driver's connect() is expected to set Active=1 + Statement => '', + }; + $dbh->{_private_data} = $imp_data if defined $imp_data; + bless $dbh, $db_class; + $drh->{Kids}++; + return wantarray ? ($dbh, $dbh) : $dbh; +} + +sub _new_sth { + my ($dbh, $attr, $imp_data) = @_; + my $imp_class = $dbh->{ImplementorClass} + or Carp::croak("DBI _new_sth: $dbh has no ImplementorClass"); + (my $st_class = $imp_class) =~ s/::db$/::st/; + my $sth = { + 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, + Active => 0, + }; + $sth->{_private_data} = $imp_data if defined $imp_data; + bless $sth, $st_class; + $dbh->{Kids}++; + return wantarray ? ($sth, $sth) : $sth; +} + +# ---- 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 } + +sub data_sources { + my ($class, $driver, $attr) = @_; + my $drh = ref($class) ? $class : $class->install_driver($driver); + return $drh->data_sources($attr); +} + +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). Real DBI additionally makes handles +# pass `isa('DBI::dr')` / `isa('DBI::db')` / `isa('DBI::st')` — +# DBIx::Class and the DBI self-tests rely on this. We achieve that +# by having DBD::_:: inherit from DBI::. + +{ + package DBI::dr; our @ISA = (); + package DBI::db; our @ISA = (); + package DBI::st; our @ISA = (); +} + +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)$/; + return $v; + } + + sub STORE { + my ($h, $key, $val) = @_; + if ($key =~ /^(?:Err|Errstr|State)$/ && ref($h->{$key}) eq 'SCALAR') { + ${ $h->{$key} } = $val; + } else { + $h->{$key} = $val; + } + return 1; + } + + 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 : ''; + } + + sub set_err { + my ($h, $err, $errstr, $state, $method, $rv) = @_; + $errstr = $err unless defined $errstr; + $h->STORE(Err => $err); + $h->STORE(Errstr => $errstr); + $h->STORE(State => $state) if defined $state; + # also update $DBI::err / $DBI::errstr / $DBI::state + $DBI::err = $err; + $DBI::errstr = $errstr; + $DBI::state = defined $state ? $state : ''; + if ($h->{PrintError}) { + warn "DBI: $errstr\n"; + } + if ($h->{RaiseError}) { + die "$errstr\n"; + } + 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); + print STDERR $msg if $level >= $min_level; + 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 dump_handle { + my ($h, $msg, $level) = @_; + $msg = '' unless defined $msg; + my $class = ref($h) || $h; + print STDERR "$msg $class=HASH\n"; + if (ref $h) { + for my $k (sort keys %$h) { + my $v = $h->{$k}; + next if ref $v; + print STDERR " $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; + our @ISA = ('DBI::dr', '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 = ('DBI::db', '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 disconnect { + my $dbh = shift; + $dbh->STORE(Active => 0); + return 1; + } + sub commit { return 1 } + sub rollback { return 1 } + 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 get_info { return undef } + sub last_insert_id { return undef } + sub take_imp_data { return undef } +} + +{ + package DBD::_::st; + our @ISA = ('DBI::st', 'DBD::_::common'); + use strict; + + sub rows { return -1 } + sub finish { + my $sth = shift; + $sth->STORE(Active => 0); + return 1; + } + 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 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; + } + + # 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; + } +} + +1; From 247bf3be0de270446eb578c16214f5b90a712a7f Mon Sep 17 00:00:00 2001 From: "Flavio S. Glock" Date: Wed, 22 Apr 2026 17:53:31 +0200 Subject: [PATCH 04/11] feat(DBI): fill in more DBI internals used by test suite MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Phase 3 first batch of the DBI test-parity plan: add the methods the DBI self-tests and the bundled pure-Perl DBDs (DBD::File / DBD::DBM / DBD::Sponge / DBD::Mem / DBI::DBD::SqlEngine) call on DBI and on handles. Top-level DBI methods / helpers: * DBI->internal (fake DBD::Switch::dr drh, isa('DBI::dr')) * DBI->parse_dsn * DBI->driver_prefix (accepts both 'File' and 'DBD::File') * DBI->dbixs_revision * DBI->install_method / DBI->_install_method * DBI::hash (ported from DBI::PurePerl) * DBI::_concat_hash_sorted * DBI::dbi_profile / dbi_profile_merge / dbi_profile_merge_nodes * DBI->data_sources now accepts "dbi:DRIVER:" form. Trace fix in DBI.pm: * DBI->trace / DBI->trace_msg now work as class methods (previously crashed on strict refs when the invocant was "DBI"). DBD::_::db base class: * do, prepare_cached * selectrow_array / _arrayref / _hashref * selectall_arrayref / _hashref * selectcol_arrayref * type_info stub DBD::_::st base class: * fetchall_arrayref (plain / slice / hash) * fetchall_hashref * _get_fbav * FETCH override computing NAME_lc / NAME_uc / NAME_hash / NAME_lc_hash / NAME_uc_hash from NAME when called via $sth->FETCH(...). Direct $sth->{NAME_lc} access still requires tied-hash semantics, which we do not provide. DBD::_::common base class: * FETCH_many, debug, dbixs_revision, install_method, dump_handle. Effect on `jcpan -t DBI` (stacked on #544): before: 200 files, 1600 subtests, 1240 passing, 360 failing after: 200 files, 5610 subtests, 3978 passing, 1632 failing => +2738 subtests now pass (+4010 more executed). 4 fewer test files fail overall. The remaining 166 files are dominated by (a) DBD::File / DBD::DBM-specific methods not yet wired and (b) tied-hash-dependent attribute access. Cumulative across the four stacked PRs (#540, #542, #544, this one): master: 562 subtests, 308 passing now: 5610 subtests, 3978 passing (~13× more passes) See dev/modules/dbi_test_parity.md. Generated with [Devin](https://cli.devin.ai/docs) Co-Authored-By: Devin <158243242+devin-ai-integration[bot]@users.noreply.github.com> --- dev/modules/dbi_test_parity.md | 64 +++- .../org/perlonjava/core/Configuration.java | 4 +- src/main/perl/lib/DBI.pm | 15 +- src/main/perl/lib/DBI/_Handles.pm | 361 ++++++++++++++++++ 4 files changed, 429 insertions(+), 15 deletions(-) diff --git a/dev/modules/dbi_test_parity.md b/dev/modules/dbi_test_parity.md index 9aa944a52..743ac54fc 100644 --- a/dev/modules/dbi_test_parity.md +++ b/dev/modules/dbi_test_parity.md @@ -5,9 +5,21 @@ DBI test suite, 200 test files) pass on PerlOnJava. ## Current Baseline -After Phase 2 (driver-architecture pieces: `install_driver`, -`_new_drh` / `_new_dbh` / `_new_sth`, `DBD::_::common / dr / db / st` -base classes): +After Phase 3 first batch (additional DBI internals: `internal`, +`parse_dsn`, `hash`, `_concat_hash_sorted`, `dbi_profile`, +`driver_prefix`, `_install_method`, `_get_fbav`, plus base-class +utility methods — `do`, `prepare_cached`, `selectrow_hashref`, +`selectall_hashref`, `selectall_arrayref`, `selectcol_arrayref`, +`fetchall_arrayref`, `fetchall_hashref`, `FETCH_many`, `debug`, +computed `NAME_lc` / `NAME_uc` / `NAME_hash`, and class-method +`trace` / `trace_msg`): + +| | Files | Subtests | Passing | Failing | +|---|---|---|---|---| +| `jcpan -t DBI` | 200 | 5610 | 3978 | 1632 | + +Previous baseline (after Phase 2 — driver-architecture pieces, +[PR #544](https://github.com/fglock/PerlOnJava/pull/544)): | | Files | Subtests | Passing | Failing | |---|---|---|---|---| @@ -27,6 +39,8 @@ Exporter wiring only): |---|---|---|---|---| | `jcpan -t DBI` | 200 | 638 | 368 | 270 | +Original baseline on master: 562 subtests, 308 passing, 254 failing. + The remaining failures fall into four categories, listed below in priority order. Phase 1 is the hard blocker — several entire test files abort mid-run on PerlOnJava backend errors, so we cannot even see what @@ -317,7 +331,7 @@ Triage these once Phase 1 & 2 are done and we have clean output. ## Progress Tracking -### Current Status: Phase 2 complete. Phase 3 is next. +### Current Status: Phase 3 (first batch) in progress. Many more DBI internals filled in. ### Completed @@ -376,13 +390,45 @@ Triage these once Phase 1 & 2 are done and we have clean output. (+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.** PR TBD. + - Added top-level `DBI->internal`, `DBI->parse_dsn`, + `DBI::hash`, `DBI::_concat_hash_sorted`, `DBI::dbi_profile`, + `DBI::dbi_profile_merge`, `DBI::dbi_profile_merge_nodes`, + `DBI->driver_prefix`, `DBI->dbixs_revision`, + `DBI->_install_method`, `DBI->install_method`. + - Fixed `DBI.pm`'s `trace` and `trace_msg` so they work as + class methods (previously crashed on strict refs when $dbh + was "DBI"). + - Added on `DBD::_::db`: `do`, `prepare_cached`, + `selectrow_array`, `selectrow_arrayref`, `selectrow_hashref`, + `selectall_arrayref`, `selectall_hashref`, + `selectcol_arrayref`, `type_info`, and accepted `"dbi:DRIVER:"` + form in `data_sources`. + - Added on `DBD::_::st`: `fetchall_arrayref` (plain / slice / + hash), `fetchall_hashref`, `_get_fbav`, and computed + `NAME_lc` / `NAME_uc` / `NAME_hash` / `NAME_lc_hash` / + `NAME_uc_hash` attributes via an `st::FETCH` override. (Note: + this works when the driver calls `$sth->FETCH('NAME_lc')` + explicitly; direct `$sth->{NAME_lc}` access still needs tied + hashes, which we do not provide.) + - Added on `DBD::_::common`: `FETCH_many`, `debug`, + `dbixs_revision`, `install_method`, `dump_handle` helper. + - Baseline went from 1240/1600 passing to 3978/5610 passing + (+2738 additional subtests now pass; +4010 more execute). + 4 fewer test files fail overall. + ### Next Steps -1. Start **Phase 3**: skip `DBI::PurePerl` cleanly under PerlOnJava - (or decide to port it), and triage `DBD::File` / `DBD::DBM` - behaviour against `t/49dbd_file.t` and friends. `DBD::Gofer` - can be deferred until the others stabilise. -2. After Phase 3, re-run `jcpan -t DBI` and refresh the baseline. +1. Continue **Phase 3**: the remaining 166 failing files are dominated + by (a) DBD::File / DBD::DBM-specific methods (`f_versions`, + `dbm_versions`, `dbm_clear_meta`, `clone`) and (b) attribute + FETCH on computed keys that real DBI handles via tied hashes + (`NAME_lc`, `ChildHandles`, etc.). Tied-hash semantics is the + biggest remaining gap. +2. After that, triage the `zvg_*` / `zvp_*` / `zvx*_*` wrapper + families — most share backends with the base tests, so base + fixes cascade. +3. Periodically re-run `jcpan -t DBI` to track progress. ### Open Questions diff --git a/src/main/java/org/perlonjava/core/Configuration.java b/src/main/java/org/perlonjava/core/Configuration.java index f03519f39..78e1ca254 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 = "efbf5541d"; + public static final String gitCommitId = "861d1b8ad"; /** * 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 22 2026 16:41:49"; + public static final String buildTimestamp = "Apr 22 2026 17:51:26"; // Prevent instantiation private Configuration() { diff --git a/src/main/perl/lib/DBI.pm b/src/main/perl/lib/DBI.pm index bcaf0032b..c8ac2ef2f 100644 --- a/src/main/perl/lib/DBI.pm +++ b/src/main/perl/lib/DBI.pm @@ -610,8 +610,13 @@ sub trace { my ($dbh, $level, $output) = @_; $level ||= 0; - $dbh->{TraceLevel} = $level; - $dbh->{TraceOutput} = $output if defined $output; + if (ref $dbh) { + $dbh->{TraceLevel} = $level; + $dbh->{TraceOutput} = $output if defined $output; + } else { + # class method: DBI->trace(...) sets the process-global level + $DBI::dbi_debug = $level; + } return $level; } @@ -620,9 +625,11 @@ sub trace_msg { my ($dbh, $msg, $level) = @_; $level ||= 0; - 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}) { + if (ref($dbh) && $dbh->{TraceOutput}) { # TODO: Write to custom output print STDERR $msg; } else { diff --git a/src/main/perl/lib/DBI/_Handles.pm b/src/main/perl/lib/DBI/_Handles.pm index cb5b83a4f..674b8a74d 100644 --- a/src/main/perl/lib/DBI/_Handles.pm +++ b/src/main/perl/lib/DBI/_Handles.pm @@ -144,10 +144,154 @@ sub installed_drivers { %installed_drh } 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 @@ -312,6 +456,34 @@ sub _get_imp_data { 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; @@ -401,6 +573,99 @@ sub _get_imp_data { 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); @@ -424,6 +689,7 @@ sub _get_imp_data { 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 } @@ -440,11 +706,97 @@ sub _get_imp_data { $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; @@ -472,6 +824,15 @@ sub _get_imp_data { } 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; From d8d1ccedcaef4f21b111ca5f92cc20a26c54ea27 Mon Sep 17 00:00:00 2001 From: "Flavio S. Glock" Date: Wed, 22 Apr 2026 19:11:48 +0200 Subject: [PATCH 05/11] feat(DBI): tied-handle semantics for pure-Perl DBDs Next slice of the DBI test-parity plan. Two improvements: 1. Handles are now "two-headed", matching real DBI: - INNER handle: a plain blessed hashref (DBD::NullP::db etc.) holding the actual state. - OUTER handle: a reference to an anon hash, tied to DBI::_::Tie, and blessed into DBI::dr / DBI::db / DBI::st. The outer is what user code receives. `ref($dbh) eq 'DBI::db'` now holds (matching real DBI), many self-tests that check for this invariant now pass, and `$dbh->{NAME_lc}` (direct hash access) triggers FETCH on the tie class, which delegates to DBD::_::st::FETCH where computed NAME_lc / NAME_uc / NAME_hash etc. get produced on demand. Previously those only worked via explicit `$dbh->FETCH('NAME_lc')`. 2. Outer-handle method dispatch goes through DBI::_::OuterHandle's AUTOLOAD. Look-up order: - the inner handle's implementor class (driver-specific methods like prepare, execute, f_versions); - the DBI package (Java-registered methods, for the JDBC path where the Java `connect()` returns an untied DBI::db); - DBD::_:: base classes (common methods like errstr, set_err, etc.). `can` and `isa` overrides inspect the same fallback chain so introspection works from either side. Also in this commit: - Populate ChildHandles on parent handles as children are created; visit_child_handles now walks something real. - Add begin_work and clone stubs on DBD::_::db. - Add a default fetch() on DBD::_::st aliased to fetchrow_arrayref. - `use Carp ()` at the top of _Handles.pm (previously used Carp::croak without importing). Effect on `jcpan -t DBI`: before: 200 files, 5610 subtests, 3978 passing, 1632 failing after: 200 files, 5862 subtests, 4116 passing, 1746 failing => +138 more subtests pass, +252 more are executed. 166 files still fail (same as before); the remaining failures are mostly driver-specific logic (flock-deadlock under DBD::DBM, DBD::Sponge missing methods, DBI::Profile flush_to_disk, etc.). See dev/modules/dbi_test_parity.md. Cumulative: master was 562/308 passing; now 4116/5862 (~13.4x more passing subtests). Generated with [Devin](https://cli.devin.ai/docs) Co-Authored-By: Devin <158243242+devin-ai-integration[bot]@users.noreply.github.com> --- dev/modules/dbi_test_parity.md | 78 +++-- .../org/perlonjava/core/Configuration.java | 4 +- src/main/perl/lib/DBI/_Handles.pm | 304 +++++++++++++++--- 3 files changed, 307 insertions(+), 79 deletions(-) diff --git a/dev/modules/dbi_test_parity.md b/dev/modules/dbi_test_parity.md index 743ac54fc..eddc6f0c0 100644 --- a/dev/modules/dbi_test_parity.md +++ b/dev/modules/dbi_test_parity.md @@ -5,35 +5,33 @@ DBI test suite, 200 test files) pass on PerlOnJava. ## Current Baseline -After Phase 3 first batch (additional DBI internals: `internal`, -`parse_dsn`, `hash`, `_concat_hash_sorted`, `dbi_profile`, -`driver_prefix`, `_install_method`, `_get_fbav`, plus base-class -utility methods — `do`, `prepare_cached`, `selectrow_hashref`, -`selectall_hashref`, `selectall_arrayref`, `selectcol_arrayref`, -`fetchall_arrayref`, `fetchall_hashref`, `FETCH_many`, `debug`, -computed `NAME_lc` / `NAME_uc` / `NAME_hash`, and class-method -`trace` / `trace_msg`): +After Phase 3 second batch (tied-handle semantics for pure-Perl DBDs, +plus `begin_work` / `clone` / `fetch` alias, `ChildHandles` +population, dispatch fallback for JDBC-path 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, -[PR #544](https://github.com/fglock/PerlOnJava/pull/544)): +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, -[PR #542](https://github.com/fglock/PerlOnJava/pull/542)): +Previous baseline (after Phase 1 — runtime interpreter fallback): | | Files | Subtests | Passing | Failing | |---|---|---|---|---| | `jcpan -t DBI` | 200 | 946 | 676 | 270 | -Previous baseline (after [PR #540](https://github.com/fglock/PerlOnJava/pull/540), -Exporter wiring only): +Previous baseline (after Exporter wiring only): | | Files | Subtests | Passing | Failing | |---|---|---|---|---| @@ -390,32 +388,32 @@ Triage these once Phase 1 & 2 are done and we have clean output. (+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.** PR TBD. - - Added top-level `DBI->internal`, `DBI->parse_dsn`, - `DBI::hash`, `DBI::_concat_hash_sorted`, `DBI::dbi_profile`, - `DBI::dbi_profile_merge`, `DBI::dbi_profile_merge_nodes`, - `DBI->driver_prefix`, `DBI->dbixs_revision`, - `DBI->_install_method`, `DBI->install_method`. - - Fixed `DBI.pm`'s `trace` and `trace_msg` so they work as - class methods (previously crashed on strict refs when $dbh - was "DBI"). - - Added on `DBD::_::db`: `do`, `prepare_cached`, - `selectrow_array`, `selectrow_arrayref`, `selectrow_hashref`, - `selectall_arrayref`, `selectall_hashref`, - `selectcol_arrayref`, `type_info`, and accepted `"dbi:DRIVER:"` - form in `data_sources`. - - Added on `DBD::_::st`: `fetchall_arrayref` (plain / slice / - hash), `fetchall_hashref`, `_get_fbav`, and computed - `NAME_lc` / `NAME_uc` / `NAME_hash` / `NAME_lc_hash` / - `NAME_uc_hash` attributes via an `st::FETCH` override. (Note: - this works when the driver calls `$sth->FETCH('NAME_lc')` - explicitly; direct `$sth->{NAME_lc}` access still needs tied - hashes, which we do not provide.) - - Added on `DBD::_::common`: `FETCH_many`, `debug`, - `dbixs_revision`, `install_method`, `dump_handle` helper. - - Baseline went from 1240/1600 passing to 3978/5610 passing - (+2738 additional subtests now pass; +4010 more execute). - 4 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.** + - Rewrote `_new_drh` / `_new_dbh` / `_new_sth` to return an + "outer" handle: a blessed reference whose underlying hash is + tied (via `DBI::_::Tie`) to the inner storage. The outer is + blessed into `DBI::dr` / `DBI::db` / `DBI::st`, matching real + DBI's `ref($dbh) eq 'DBI::db'` invariant that many tests and + DBIx::Class rely on. + - Added `DBI::_::Tie` (thin tie class forwarding `FETCH` / + `STORE` / etc. to methods on the inner) and + `DBI::_::OuterHandle` (an AUTOLOAD-based method dispatcher + that routes through the inner's implementor class, falling + back to the Java-registered `DBI::` methods for JDBC-path + handles, and finally to `DBD::_::` base classes). + - Added `_inner_of` / `_outer_of` helpers so driver code that + expects real-DBI's outer/inner distinction works. + - Populated `ChildHandles` on parents (drh -> dbh, dbh -> sth) + as handles are created; `visit_child_handles` now actually + walks something. + - Added `begin_work` and `clone` stubs on `DBD::_::db` and a + default `fetch` alias on `DBD::_::st` that delegates to + `fetchrow_arrayref`. + - Baseline 3978/5610 → 4116/5862 passing (+138 subtests, + +252 more executed). ### Next Steps diff --git a/src/main/java/org/perlonjava/core/Configuration.java b/src/main/java/org/perlonjava/core/Configuration.java index 78e1ca254..2a34365b9 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 = "861d1b8ad"; + public static final String gitCommitId = "0d0083f64"; /** * 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 22 2026 17:51:26"; + public static final String buildTimestamp = "Apr 22 2026 18:59:25"; // Prevent instantiation private Configuration() { diff --git a/src/main/perl/lib/DBI/_Handles.pm b/src/main/perl/lib/DBI/_Handles.pm index 674b8a74d..ba18c638e 100644 --- a/src/main/perl/lib/DBI/_Handles.pm +++ b/src/main/perl/lib/DBI/_Handles.pm @@ -29,17 +29,43 @@ package DBI; use strict; use warnings; +use Carp (); -our %installed_drh; # driver_name => $drh +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 { - # called by DBD::::driver() with the fully-qualified ::dr - # package name as $class, plus initial attrs and private data. my ($class, $initial_attr, $imp_data) = @_; - my $drh = { - # defaults real DBI copies down to children + my $inner = { State => \my $h_state, Err => \my $h_err, Errstr => \(my $h_errstr = ''), @@ -51,42 +77,67 @@ sub _new_drh { ActiveKids => 0, Active => 1, }; - $drh->{_private_data} = $imp_data if defined $imp_data; - bless $drh, $class; - return wantarray ? ($drh, $drh) : $drh; + $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) = @_; - my $imp_class = $drh->{ImplementorClass} + # $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"); - # driver::dr -> driver::db (my $db_class = $imp_class) =~ s/::dr$/::db/; - my $dbh = { + + my $inner = { Err => \my $h_err, Errstr => \(my $h_errstr = ''), State => \my $h_state, TraceLevel => 0, %{ $attr || {} }, ImplementorClass => $db_class, - Driver => $drh, + Driver => $drh_outer, Kids => 0, ActiveKids => 0, - Active => 0, # driver's connect() is expected to set Active=1 + Active => 0, Statement => '', }; - $dbh->{_private_data} = $imp_data if defined $imp_data; - bless $dbh, $db_class; - $drh->{Kids}++; - return wantarray ? ($dbh, $dbh) : $dbh; + $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. + push @{ $drh_inner->{ChildHandles} ||= [] }, $outer; + + return wantarray ? ($outer, $inner) : $outer; } sub _new_sth { my ($dbh, $attr, $imp_data) = @_; - my $imp_class = $dbh->{ImplementorClass} + 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 $sth = { + + my $inner = { Err => \my $h_err, Errstr => \(my $h_errstr = ''), State => \my $h_state, @@ -95,15 +146,164 @@ sub _new_sth { NUM_OF_PARAMS => 0, %{ $attr || {} }, ImplementorClass => $st_class, - Database => $dbh, + Database => $dbh_outer, Active => 0, }; - $sth->{_private_data} = $imp_data if defined $imp_data; - bless $sth, $st_class; - $dbh->{Kids}++; - return wantarray ? ($sth, $sth) : $sth; + $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; + + 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; + 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 { @@ -314,16 +514,9 @@ sub available_drivers { # # Real DBI exposes these as `DBD::_::common` + DBD::_::{dr,db,st}, # where each DBD:::: inherits from DBD::_:: -# (wired by setup_driver above). Real DBI additionally makes handles -# pass `isa('DBI::dr')` / `isa('DBI::db')` / `isa('DBI::st')` — -# DBIx::Class and the DBI self-tests rely on this. We achieve that -# by having DBD::_:: inherit from DBI::. - -{ - package DBI::dr; our @ISA = (); - package DBI::db; our @ISA = (); - package DBI::st; our @ISA = (); -} +# (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; @@ -525,7 +718,10 @@ sub _get_imp_data { { package DBD::_::dr; - our @ISA = ('DBI::dr', 'DBD::_::common'); + # 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 { @@ -564,7 +760,7 @@ sub _get_imp_data { { package DBD::_::db; - our @ISA = ('DBI::db', 'DBD::_::common'); + our @ISA = ('DBD::_::common'); use strict; sub ping { return 0 } # DBDs should override @@ -673,6 +869,29 @@ sub _get_imp_data { } sub commit { return 1 } sub rollback { 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; @@ -697,7 +916,7 @@ sub _get_imp_data { { package DBD::_::st; - our @ISA = ('DBI::st', 'DBD::_::common'); + our @ISA = ('DBD::_::common'); use strict; sub rows { return -1 } @@ -811,6 +1030,17 @@ sub _get_imp_data { 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 From 91119a202b18973a74f2df8725314906b2b89100 Mon Sep 17 00:00:00 2001 From: "Flavio S. Glock" Date: Wed, 22 Apr 2026 19:26:17 +0200 Subject: [PATCH 06/11] feat(DBI): populate ChildHandles and tie-handle cleanups Small follow-up to the tied-handle commit: - `use Scalar::Util ()` at the top of _Handles.pm. - ChildHandles is now pushed onto parent handles in _new_dbh / _new_sth (drh -> dbh, dbh -> sth) using strong refs. - We deliberately do NOT weaken the ChildHandles entries: weak refs to tied handles currently get cleared too eagerly on PerlOnJava, which breaks the immediately-subsequent dispatch on the outer. Real DBI uses weak refs there + an XS destroy path to clean up stale entries; our stand-in is to keep strong refs. This makes t/72childhandles.t fail the "weak ref clears when out of scope" subtests (4 subtests) but lets the earlier and later subtests run cleanly. TODO: switch back to weak refs when the PerlOnJava side of weaken + tied hashes is ironed out. No change to `jcpan -t DBI` numbers over the previous commit; this commit is about correctness of the ChildHandles path. Generated with [Devin](https://cli.devin.ai/docs) Co-Authored-By: Devin <158243242+devin-ai-integration[bot]@users.noreply.github.com> --- src/main/java/org/perlonjava/core/Configuration.java | 4 ++-- src/main/perl/lib/DBI/_Handles.pm | 8 ++++++++ 2 files changed, 10 insertions(+), 2 deletions(-) diff --git a/src/main/java/org/perlonjava/core/Configuration.java b/src/main/java/org/perlonjava/core/Configuration.java index 2a34365b9..f94b27417 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 = "0d0083f64"; + public static final String gitCommitId = "bbdba4548"; /** * 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 22 2026 18:59:25"; + public static final String buildTimestamp = "Apr 22 2026 19:17:35"; // Prevent instantiation private Configuration() { diff --git a/src/main/perl/lib/DBI/_Handles.pm b/src/main/perl/lib/DBI/_Handles.pm index ba18c638e..153acb3b2 100644 --- a/src/main/perl/lib/DBI/_Handles.pm +++ b/src/main/perl/lib/DBI/_Handles.pm @@ -30,6 +30,7 @@ package DBI; use strict; use warnings; use Carp (); +use Scalar::Util (); our %installed_drh; # driver_name => $drh (outer) @@ -123,7 +124,13 @@ sub _new_dbh { $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; } @@ -159,6 +166,7 @@ sub _new_sth { $dbh_inner->{Kids}++; push @{ $dbh_inner->{ChildHandles} ||= [] }, $outer; + # Scalar::Util::weaken($dbh_inner->{ChildHandles}[-1]); # see _new_dbh return wantarray ? ($outer, $inner) : $outer; } From 3fb2ba513a0fcbcc96c73d952c3526982aaf7340 Mon Sep 17 00:00:00 2001 From: "Flavio S. Glock" Date: Wed, 22 Apr 2026 20:11:37 +0200 Subject: [PATCH 07/11] feat(DBI): Profile parsing, transactions, visit_handles, AutoCommit sentinels Third round of Phase 3 improvements on top of the tied-handle foundation from the previous commit: Profile attribute upgrade When a user passes `Profile => "2/DBI::ProfileDumper/File:/tmp/x"` to DBI->connect, real DBI parses that spec and produces a DBI::ProfileDumper object. Now we do the same in - DBD::_::common::STORE (for `$dbh->{Profile} = "spec"`), - _new_dbh (for the spec arriving in the connect attr hash), - _new_sth (which inherits Profile from the parent dbh). Transaction helpers begin_work / commit / rollback now round-trip AutoCommit and BegunWork so `$dbh->{AutoCommit}` and `$dbh->{BegunWork}` reflect reality after each call. Previously commit/rollback were no-ops. AutoCommit sentinel translation Pure-Perl DBDs (DBD::NullP, DBD::ExampleP) signal to DBI "I've handled the AutoCommit attribute myself" by STOREing the magic values -900 / -901. Real DBI's XS translates those back to 0 / 1 on FETCH; we now do the same in DBD::_::common::FETCH so user code sees the expected boolean. DBI->visit_handles Walks %installed_drh and recurses via visit_child_handles, exposing the handle tree to tests/tools. DBI.pm connect wrapper Re-applies 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. Effect on `jcpan -t DBI`: before: 200 files, 5862 subtests, 4116 passing, 1746 failing (166 files failing) after: 200 files, 5878 subtests, 4156 passing, 1722 failing (164 files failing) => +40 subtests pass, 2 fewer files fail overall. Cumulative: master was 562/308 passing; now 4156/5878 (~13.5x more subtests passing). Generated with [Devin](https://cli.devin.ai/docs) Co-Authored-By: Devin <158243242+devin-ai-integration[bot]@users.noreply.github.com> --- dev/modules/dbi_test_parity.md | 56 +++++++------ .../org/perlonjava/core/Configuration.java | 4 +- src/main/perl/lib/DBI.pm | 10 +++ src/main/perl/lib/DBI/_Handles.pm | 84 ++++++++++++++++++- 4 files changed, 125 insertions(+), 29 deletions(-) diff --git a/dev/modules/dbi_test_parity.md b/dev/modules/dbi_test_parity.md index eddc6f0c0..abc2e5fd2 100644 --- a/dev/modules/dbi_test_parity.md +++ b/dev/modules/dbi_test_parity.md @@ -5,9 +5,14 @@ DBI test suite, 200 test files) pass on PerlOnJava. ## Current Baseline -After Phase 3 second batch (tied-handle semantics for pure-Perl DBDs, -plus `begin_work` / `clone` / `fetch` alias, `ChildHandles` -population, dispatch fallback for JDBC-path handles): +After Phase 3 third batch (Profile parsing on connect, transaction +state, `DBI->visit_handles`, `AutoCommit` sentinel translation): + +| | Files | Subtests | Passing | Failing | +|---|---|---|---|---| +| `jcpan -t DBI` | 200 | 5878 | 4156 | 1722 | + +Previous baseline (after Phase 3 second batch — tied handles): | | Files | Subtests | Passing | Failing | |---|---|---|---|---| @@ -392,28 +397,29 @@ Triage these once Phase 1 & 2 are done and we have clean output. - (As before.) Baseline 1240/1600 → 3978/5610 passing. - [x] **2026-04-22 — Phase 3 second batch: tied-handle semantics.** - - Rewrote `_new_drh` / `_new_dbh` / `_new_sth` to return an - "outer" handle: a blessed reference whose underlying hash is - tied (via `DBI::_::Tie`) to the inner storage. The outer is - blessed into `DBI::dr` / `DBI::db` / `DBI::st`, matching real - DBI's `ref($dbh) eq 'DBI::db'` invariant that many tests and - DBIx::Class rely on. - - Added `DBI::_::Tie` (thin tie class forwarding `FETCH` / - `STORE` / etc. to methods on the inner) and - `DBI::_::OuterHandle` (an AUTOLOAD-based method dispatcher - that routes through the inner's implementor class, falling - back to the Java-registered `DBI::` methods for JDBC-path - handles, and finally to `DBD::_::` base classes). - - Added `_inner_of` / `_outer_of` helpers so driver code that - expects real-DBI's outer/inner distinction works. - - Populated `ChildHandles` on parents (drh -> dbh, dbh -> sth) - as handles are created; `visit_child_handles` now actually - walks something. - - Added `begin_work` and `clone` stubs on `DBD::_::db` and a - default `fetch` alias on `DBD::_::st` that delegates to - `fetchrow_arrayref`. - - Baseline 3978/5610 → 4116/5862 passing (+138 subtests, - +252 more executed). + - (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). ### Next Steps diff --git a/src/main/java/org/perlonjava/core/Configuration.java b/src/main/java/org/perlonjava/core/Configuration.java index f94b27417..63485c166 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 = "bbdba4548"; + public static final String gitCommitId = "defa945ab"; /** * 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 22 2026 19:17:35"; + public static final String buildTimestamp = "Apr 22 2026 20:02:51"; // Prevent instantiation private Configuration() { diff --git a/src/main/perl/lib/DBI.pm b/src/main/perl/lib/DBI.pm index c8ac2ef2f..974b540a3 100644 --- a/src/main/perl/lib/DBI.pm +++ b/src/main/perl/lib/DBI.pm @@ -252,6 +252,16 @@ require DBI::_Handles; $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; } diff --git a/src/main/perl/lib/DBI/_Handles.pm b/src/main/perl/lib/DBI/_Handles.pm index 153acb3b2..4aaff74d2 100644 --- a/src/main/perl/lib/DBI/_Handles.pm +++ b/src/main/perl/lib/DBI/_Handles.pm @@ -114,6 +114,11 @@ sub _new_dbh { 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; @@ -156,6 +161,9 @@ sub _new_sth { 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; @@ -350,6 +358,19 @@ sub setup_driver { 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)) { @@ -543,11 +564,25 @@ sub _get_imp_data { # 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 { @@ -556,6 +591,37 @@ sub _get_imp_data { 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 { } @@ -875,8 +941,22 @@ sub _get_imp_data { $dbh->STORE(Active => 0); return 1; } - sub commit { return 1 } - sub rollback { 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; From 7d96611e3afa1ea95d2244097051ece4143c6314 Mon Sep 17 00:00:00 2001 From: "Flavio S. Glock" Date: Wed, 22 Apr 2026 20:28:34 +0200 Subject: [PATCH 08/11] docs(dbi): make the `local $tied->{k}->{kk}` bug the top priority MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit While working on Phase 3 I hit a PerlOnJava interpreter/backend bug that's independent of DBI but blocks DBI's profile-related tests (t/41prof_dump.t, t/42prof_data.t, t/43prof_env.t, plus their zv*_4[1-3]* wrappers — ~20 test files total). Minimal repro: tie %$h, 'Tie', { obj => bless { Path => [1,2,3] }, 'Foo' }; { local $h->{obj}->{Path} = undef; $h->{obj}->meth; # <-- "Can't locate method via package Foo=HASH(0x...)" } After the `local`, `ref($h->{obj})` still reports "Foo", but method dispatch on `$h->{obj}->meth` goes via the stringified form (the literal "Foo=HASH(0x...)" as package name). Without the tie, the same shape works fine. Without the `local`, the same shape works fine. Only the combination trips it. This is a latent correctness issue that will keep surfacing in any CPAN module that uses this idiom, not just DBI. So it's now the single highest-leverage fix on the DBI plan: promoting it to Phase 4 (priority 1) above Phase 1's "finish Phase 3 polish". Updated documents: - dev/modules/dbi_test_parity.md: new Phase 4 section with repro, impact analysis, investigation plan, acceptance criteria, and pointers to the interpreter / JVM / runtime subtrees where the fix is most likely to live. Renumbered the old priorities and pointed Next Steps at Phase 4. - dev/modules/README.md: updated the index line to reflect the new state. No code changes. Generated with [Devin](https://cli.devin.ai/docs) Co-Authored-By: Devin <158243242+devin-ai-integration[bot]@users.noreply.github.com> --- dev/modules/README.md | 2 +- dev/modules/dbi_test_parity.md | 187 ++++++++++++++++++++++++++++++--- 2 files changed, 171 insertions(+), 18 deletions(-) diff --git a/dev/modules/README.md b/dev/modules/README.md index f0e0e25e6..21cbf18c3 100644 --- a/dev/modules/README.md +++ b/dev/modules/README.md @@ -13,7 +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) | Plan to get `jcpan -t DBI` passing (Phase 1: bytecode verifier bug / interpreter fallback) | +| [dbi_test_parity.md](dbi_test_parity.md) | DBI test-suite parity (~13.5× more passes than master; now blocked on a PerlOnJava `local` + tied-hash bug — Phase 4) | | [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 index abc2e5fd2..3389f8118 100644 --- a/dev/modules/dbi_test_parity.md +++ b/dev/modules/dbi_test_parity.md @@ -44,15 +44,153 @@ Previous baseline (after Exporter wiring only): Original baseline on master: 562 subtests, 308 passing, 254 failing. -The remaining failures fall into four categories, listed below in -priority order. Phase 1 is the hard blocker — several entire test files -abort mid-run on PerlOnJava backend errors, so we cannot even see what -DBI-level bugs lie behind them until the backend is fixed or we fall -back to the interpreter. +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 1 (priority 1): fix or fall back from bytecode-gen verifier bug +## Phase 4 (priority 1, NEW): PerlOnJava bug — `local $h->{k}->{kk}` on tied hashes + +**Status: not started.** Blocks several DBI profile tests and is +expected to come up in any module that combines `local` with tied +hash traversal (DBIx::Class, Catalyst, many test frameworks). + +### The bug + +Taking `local` on a nested key of a TIED hash reference corrupts +subsequent reads of the intermediate key. Minimal repro: + +```perl +package Tie; +sub TIEHASH { bless \$_[1], $_[0] } +sub FETCH { ${$_[0]}->{$_[1]} } +sub STORE { ${$_[0]}->{$_[1]} = $_[2] } + +package Foo; +sub meth { print "in meth\n"; } + +package main; +my $obj = bless { Path => [1, 2, 3] }, 'Foo'; +my %storage; +my $h = \%storage; +tie %$h, 'Tie', { obj => $obj }; + +print "h->{obj}=", ref($h->{obj}), "\n"; # -> Foo (correct) +{ + local $h->{obj}->{Path} = undef; + print "type ", ref($h->{obj}), "\n"; # -> Foo (correct) + eval { $h->{obj}->meth; }; + print "err: $@\n" if $@; +} +``` + +Expected: `in meth`. Observed on PerlOnJava: + +``` +h->{obj}=Foo +type Foo +err: Can't locate object method "meth" via package + "Foo=HASH(0x47db50c5)" (perhaps you forgot to load + "Foo=HASH(0x47db50c5)"?) at -e line 19. +``` + +The method-resolution path treats the blessed-ref's stringification +(`Foo=HASH(0x...)`) as the package name. Internally this looks like +the `local` restore hook is leaving the scalar in a state where +`ref()` still reports the class but the SVOK / invocant dispatch +sees the stringified form instead of the ref. + +The same bug occurs without the tie — but with a plain hash +`perl` / `jperl` both behave correctly; the tie is what trips it. + +### Impact on DBI + +Direct blocker for test flows that do `local $h->{Profile}->{Path} += undef` or similar around a `flush_to_disk()` call — that's the +exact shape of `t/41prof_dump.t`, `t/42prof_data.t`, +`t/43prof_env.t`, and their `zv*_41*`, `zv*_42*`, `zv*_43*` +wrappers (~21 test files). Several other Phase 3 improvements +(Profile inheritance, the tied-handle architecture) set up Profile +correctly but can't get past this spot. + +### Plan + +1. **Reproduce in isolation.** Add a minimal test under + `src/test/resources/` (or wherever interpreter-level tests + live) that boils down to the snippet above and asserts the + method call succeeds. It should fail on master and we keep it + as a regression test. + +2. **Isolate where Perl-on-Java goes wrong.** Candidates: + + - **Tie-aware `local` restore.** When we set up `local` on a + lvalue that goes through a tied hash, we need to snapshot + the old value via FETCH, then arrange for a STORE with that + value at scope exit. Somewhere in this flow the *intermediate* + ref that was returned by FETCH gets replaced with a stringified + view, so subsequent reads of the same tied slot produce a + different SV. + + Likely files: the code that implements `local` in + `src/main/java/org/perlonjava/backend/jvm/` (look for + `EmitControlFlow` / `LocalVariable*`) and its interpreter + counterpart in `backend/bytecode/`. Also anything that + handles tie magic in `runtime/`. + + - **Method-dispatch against a ref whose reftype changed.** + Alternatively the scalar may still hold the right ref, but + method dispatch is looking up the class via stringification + rather than `SvSTASH`-equivalent. In that case the fix is in + the method-call opcode in `backend/bytecode/CompileOperator` + or the JVM-side `EmitOperator`. + +3. **Decide on scope of the fix.** The minimal bug is: + + ```perl + local $tied_hash->{key}->{subkey} = ...; # then $tied_hash->{key}->method + ``` + + A tight fix is enough. If easy, also cover + + ```perl + local $tied_hash->{key} = ...; # then method call + ``` + + which may share the same code path. + +4. **Validate.** Re-run `jcpan -t DBI` and confirm `t/41prof_dump.t` + / `t/42prof_data.t` / `t/43prof_env.t` (and their wrappers) + move from "aborts partway with `Can't locate method foo via + package Foo=HASH(...)`" to "real TAP results". Expected delta: + ~20 test files move from fail to pass (assuming the only thing + they were waiting on is this). + +5. **Audit other spots.** Grep CPAN-modules and the bundled + tests for the pattern `\Qlocal \$\E\S*->\{.*\}->\{` — any + module that uses this idiom is likely also broken today. Add + a short note on it in `AGENTS.md` / a skill file so it doesn't + get rediscovered from scratch. + +### Acceptance criteria + +- The minimal test from step 1 passes. +- `./jperl ~/.cpan/build/DBI-1.647-5/t/41prof_dump.t` runs past the + `local $dbh->{Profile}->{Path} = undef; $sth->{Profile}->flush_to_disk;` + block and either passes the test or fails on something unrelated. +- `make` and `jcpan -t DBI` still match-or-improve the baseline. + +--- + +## 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.** @@ -334,7 +472,7 @@ Triage these once Phase 1 & 2 are done and we have clean output. ## Progress Tracking -### Current Status: Phase 3 (first batch) in progress. Many more DBI internals filled in. +### Current Status: Phase 1–3 landed on `fix/dbi-test-parity` (PR #546). Phase 4 is the new top priority — it's a PerlOnJava bug, not DBI work, and needs attention before more DBI polish is worth doing. ### Completed @@ -423,16 +561,18 @@ Triage these once Phase 1 & 2 are done and we have clean output. ### Next Steps -1. Continue **Phase 3**: the remaining 166 failing files are dominated - by (a) DBD::File / DBD::DBM-specific methods (`f_versions`, - `dbm_versions`, `dbm_clear_meta`, `clone`) and (b) attribute - FETCH on computed keys that real DBI handles via tied hashes - (`NAME_lc`, `ChildHandles`, etc.). Tied-hash semantics is the - biggest remaining gap. -2. After that, triage the `zvg_*` / `zvp_*` / `zvx*_*` wrapper - families — most share backends with the base tests, so base - fixes cascade. -3. Periodically re-run `jcpan -t DBI` to track progress. +1. **Phase 4 (TOP PRIORITY): fix the `local $tied->{k}->{kk}` bug** + in the PerlOnJava interpreter/backend. See the Phase 4 section + above. Expected to unblock ~20 DBI test files in the profile + family plus unknown fallout across other CPAN modules. +2. After Phase 4 lands, revisit Phase 3 polish — `HandleError` + flow (`t/17handle_error.t`), trace file support + (`t/09trace.t`, `t/19fhtrace.t`), callback integration + (`t/70callbacks.t`), `t/16destroy.t` handle-state-on-destroy. +3. Phase 3c (DBD::Gofer): likely the next big family of files. + Gofer's `null` transport wants the tied-handle work we already + have, so this may now be close to free. +4. Periodically re-run `jcpan -t DBI` to track progress. ### Open Questions @@ -440,6 +580,9 @@ Triage these once Phase 1 & 2 are done and we have clean output. 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. --- @@ -451,3 +594,13 @@ Triage these once Phase 1 & 2 are done and we have clean output. 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. From d9c535892c08848dfe22d4f8a83a7af188968140 Mon Sep 17 00:00:00 2001 From: "Flavio S. Glock" Date: Wed, 22 Apr 2026 20:47:02 +0200 Subject: [PATCH 09/11] fix(runtime): unwrap TIED_SCALAR in method dispatch MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit `$tied_hash{key}->method(...)` crashed with "Can't locate object method ... via package Foo=HASH(0x...)" when the hash was tied, even though ref() on the same expression returned "Foo". Root cause: RuntimeHash.get() for a tied hash returns a TIED_SCALAR proxy (lazily backed by tiedFetch()) instead of the actual fetched value. This is deliberate — it's how lvalue semantics and STORE dispatch work — but the method-dispatch code in RuntimeCode.callCached / RuntimeCode.call only unwrapped READONLY_SCALAR, not TIED_SCALAR. The TIED_SCALAR shell hit `isReference(invocant) -> false` and fell through to `perlClassName = invocant.toString()`, which stringified the blessed ref to "Foo=HASH(0x...)" and then treated that as a package name. Minimal repro: 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 with "Can't locate ... via package Foo=HASH(0x...)" Fix: mirror the existing TIED_SCALAR handling already present in apply() (RuntimeCode.java lines ~2378 / ~2659 / ~2846) in the method-dispatch entry points callCached() and call(). Unwrap the TIED_SCALAR to its fetched value at the top of each, before any isReference / blessId check or `toString` fallback. Effect: - Minimal repro now passes on both `jperl` and `jperl --interpreter`. - `t/41prof_dump.t` runs 9 subtests (was 7), `t/42prof_data.t` runs 4 (was 3). Remaining failures are unrelated DBI::Profile-on-disk issues. - `jcpan -t DBI`: 200 files, 5886→5890 subtests, 4156→4160 passing, 164/200 files failing (unchanged). - `make` still green. Relevant to any CPAN module that does direct method calls on values retrieved via tied hash access — DBI itself, DBIx::Class, Catalyst-style dispatch tables, etc. Updates dev/modules/dbi_test_parity.md with the refined diagnosis, marks Phase 4 done, and lines up the remaining Phase 3 polish items (profile-on-disk, HandleError, trace file, destroy) as the next steps. Generated with [Devin](https://cli.devin.ai/docs) Co-Authored-By: Devin <158243242+devin-ai-integration[bot]@users.noreply.github.com> --- dev/modules/README.md | 2 +- dev/modules/dbi_test_parity.md | 224 +++++++++--------- .../org/perlonjava/core/Configuration.java | 4 +- .../runtime/runtimetypes/RuntimeCode.java | 15 ++ 4 files changed, 124 insertions(+), 121 deletions(-) diff --git a/dev/modules/README.md b/dev/modules/README.md index 21cbf18c3..0e23bd47b 100644 --- a/dev/modules/README.md +++ b/dev/modules/README.md @@ -13,7 +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; now blocked on a PerlOnJava `local` + tied-hash bug — Phase 4) | +| [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 index 3389f8118..0854ae221 100644 --- a/dev/modules/dbi_test_parity.md +++ b/dev/modules/dbi_test_parity.md @@ -5,8 +5,13 @@ DBI test suite, 200 test files) pass on PerlOnJava. ## Current Baseline -After Phase 3 third batch (Profile parsing on connect, transaction -state, `DBI->visit_handles`, `AutoCommit` sentinel translation): +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 | |---|---|---|---|---| @@ -58,135 +63,102 @@ the single biggest lever. --- -## Phase 4 (priority 1, NEW): PerlOnJava bug — `local $h->{k}->{kk}` on tied hashes +## Phase 4 (priority 1, NEW): PerlOnJava bug — method dispatch on tied hash FETCH -**Status: not started.** Blocks several DBI profile tests and is -expected to come up in any module that combines `local` with tied -hash traversal (DBIx::Class, Catalyst, many test frameworks). +**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 +### The bug (refined diagnosis) -Taking `local` on a nested key of a TIED hash reference corrupts -subsequent reads of the intermediate key. Minimal repro: +Minimal repro: ```perl package Tie; sub TIEHASH { bless \$_[1], $_[0] } sub FETCH { ${$_[0]}->{$_[1]} } -sub STORE { ${$_[0]}->{$_[1]} = $_[2] } package Foo; sub meth { print "in meth\n"; } package main; -my $obj = bless { Path => [1, 2, 3] }, 'Foo'; -my %storage; -my $h = \%storage; -tie %$h, 'Tie', { obj => $obj }; - -print "h->{obj}=", ref($h->{obj}), "\n"; # -> Foo (correct) -{ - local $h->{obj}->{Path} = undef; - print "type ", ref($h->{obj}), "\n"; # -> Foo (correct) - eval { $h->{obj}->meth; }; - print "err: $@\n" if $@; -} +my $obj = bless {}, 'Foo'; +my %h; +tie %h, 'Tie', { obj => $obj }; +$h{obj}->meth; # <-- died ``` -Expected: `in meth`. Observed on PerlOnJava: +Output before the fix: ``` -h->{obj}=Foo -type Foo -err: Can't locate object method "meth" via package - "Foo=HASH(0x47db50c5)" (perhaps you forgot to load - "Foo=HASH(0x47db50c5)"?) at -e line 19. +Can't locate object method "meth" via package + "Foo=HASH(0x7276c8cd)" (perhaps you forgot to load ...) ``` -The method-resolution path treats the blessed-ref's stringification -(`Foo=HASH(0x...)`) as the package name. Internally this looks like -the `local` restore hook is leaving the scalar in a state where -`ref()` still reports the class but the SVOK / invocant dispatch -sees the stringified form instead of the ref. +`ref($h{obj})` returned `"Foo"` (correct) but direct method +dispatch used the scalar's stringification as the package name +(`"Foo=HASH(0x...)"`). -The same bug occurs without the tie — but with a plain hash -`perl` / `jperl` both behave correctly; the tie is what trips it. +### Why -### Impact on DBI +`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...)`. -Direct blocker for test flows that do `local $h->{Profile}->{Path} -= undef` or similar around a `flush_to_disk()` call — that's the -exact shape of `t/41prof_dump.t`, `t/42prof_data.t`, -`t/43prof_env.t`, and their `zv*_41*`, `zv*_42*`, `zv*_43*` -wrappers (~21 test files). Several other Phase 3 improvements -(Profile inheritance, the tied-handle architecture) set up Profile -correctly but can't get past this spot. +The scalar's stringified class name was then used as the package +to look up the method in, and naturally no such package exists. -### Plan +### The fix -1. **Reproduce in isolation.** Add a minimal test under - `src/test/resources/` (or wherever interpreter-level tests - live) that boils down to the snippet above and asserts the - method call succeeds. It should fail on master and we keep it - as a regression test. - -2. **Isolate where Perl-on-Java goes wrong.** Candidates: - - - **Tie-aware `local` restore.** When we set up `local` on a - lvalue that goes through a tied hash, we need to snapshot - the old value via FETCH, then arrange for a STORE with that - value at scope exit. Somewhere in this flow the *intermediate* - ref that was returned by FETCH gets replaced with a stringified - view, so subsequent reads of the same tied slot produce a - different SV. - - Likely files: the code that implements `local` in - `src/main/java/org/perlonjava/backend/jvm/` (look for - `EmitControlFlow` / `LocalVariable*`) and its interpreter - counterpart in `backend/bytecode/`. Also anything that - handles tie magic in `runtime/`. - - - **Method-dispatch against a ref whose reftype changed.** - Alternatively the scalar may still hold the right ref, but - method dispatch is looking up the class via stringification - rather than `SvSTASH`-equivalent. In that case the fix is in - the method-call opcode in `backend/bytecode/CompileOperator` - or the JVM-side `EmitOperator`. - -3. **Decide on scope of the fix.** The minimal bug is: - - ```perl - local $tied_hash->{key}->{subkey} = ...; # then $tied_hash->{key}->method - ``` - - A tight fix is enough. If easy, also cover - - ```perl - local $tied_hash->{key} = ...; # then method call - ``` - - which may share the same code path. - -4. **Validate.** Re-run `jcpan -t DBI` and confirm `t/41prof_dump.t` - / `t/42prof_data.t` / `t/43prof_env.t` (and their wrappers) - move from "aborts partway with `Can't locate method foo via - package Foo=HASH(...)`" to "real TAP results". Expected delta: - ~20 test files move from fail to pass (assuming the only thing - they were waiting on is this). - -5. **Audit other spots.** Grep CPAN-modules and the bundled - tests for the pattern `\Qlocal \$\E\S*->\{.*\}->\{` — any - module that uses this idiom is likely also broken today. Add - a short note on it in `AGENTS.md` / a skill file so it doesn't - get rediscovered from scratch. +`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): -### Acceptance criteria +```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 test from step 1 passes. -- `./jperl ~/.cpan/build/DBI-1.647-5/t/41prof_dump.t` runs past the - `local $dbh->{Profile}->{Path} = undef; $sth->{Profile}->flush_to_disk;` - block and either passes the test or fails on something unrelated. -- `make` and `jcpan -t DBI` still match-or-improve the baseline. +- 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. --- @@ -472,7 +444,7 @@ Triage these once Phase 1 & 2 are done and we have clean output. ## Progress Tracking -### Current Status: Phase 1–3 landed on `fix/dbi-test-parity` (PR #546). Phase 4 is the new top priority — it's a PerlOnJava bug, not DBI work, and needs attention before more DBI polish is worth doing. +### Current Status: Phases 1–4 landed on `fix/dbi-test-parity` (PR #546). Phase 4 fixed a core PerlOnJava bug in method dispatch on tied hash FETCH. ### Completed @@ -559,20 +531,36 @@ Triage these once Phase 1 & 2 are done and we have clean output. - 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). + ### Next Steps -1. **Phase 4 (TOP PRIORITY): fix the `local $tied->{k}->{kk}` bug** - in the PerlOnJava interpreter/backend. See the Phase 4 section - above. Expected to unblock ~20 DBI test files in the profile - family plus unknown fallout across other CPAN modules. -2. After Phase 4 lands, revisit Phase 3 polish — `HandleError` - flow (`t/17handle_error.t`), trace file support - (`t/09trace.t`, `t/19fhtrace.t`), callback integration - (`t/70callbacks.t`), `t/16destroy.t` handle-state-on-destroy. -3. Phase 3c (DBD::Gofer): likely the next big family of files. - Gofer's `null` transport wants the tied-handle work we already - have, so this may now be close to free. -4. Periodically re-run `jcpan -t DBI` to track progress. +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 diff --git a/src/main/java/org/perlonjava/core/Configuration.java b/src/main/java/org/perlonjava/core/Configuration.java index 63485c166..7b099425c 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 = "defa945ab"; + public static final String gitCommitId = "a76f69f19"; /** * 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 22 2026 20:02:51"; + public static final String buildTimestamp = "Apr 22 2026 20:35:31"; // 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); From e2ad030213e852f78018ee3d1056938d771478ff Mon Sep 17 00:00:00 2001 From: "Flavio S. Glock" Date: Wed, 22 Apr 2026 21:09:05 +0200 Subject: [PATCH 10/11] feat(DBI): HandleError severity levels + trace-to-file support MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Phase 5 of the DBI test-parity plan: 1. set_err rewrite (DBD::_::common) Matches real DBI's three severity levels: - err undef : clear Err/Errstr/State, no alerts - err "" : info — just stored, no handlers, no alerts - err 0 or "0" : warning — fires HandleError if RaiseWarn or PrintWarn is set; if RaiseWarn dies, if PrintWarn warns - err truthy : error — fires HandleError unconditionally; then RaiseError dies / PrintError warns Error message format matches real DBI's "IMPL_CLASS METHOD failed|warning: errstr" shape that the self-tests regex against. 2. Trace-to-file support (DBI.pm + DBD::_::common) - DBI->trace($level, $file) now opens and installs a process-global $DBI::tfh filehandle. - DBI->trace(0, undef) closes it and reverts to STDERR. - Introduced DBI::_trace_fh() helper used by DBI::trace_msg, DBD::_::common::trace_msg, and DBD::_::common::dump_handle. - Accepts an already-opened filehandle (GLOB / IO) in addition to a filename. Effect on `jcpan -t DBI`: before: 200 files, 5890 subtests, 4160 passing, 164/200 files failing after: 200 files, 6294 subtests, 4504 passing, 156/200 files failing +344 subtests pass; +404 more subtests now execute (trace and error-handler tests that used to abort mid-run now run to completion). 8 fewer test files fail overall. Per-file: - t/17handle_error.t: 2 → 84 (all passing) - t/09trace.t: 82 → 83 - t/19fhtrace.t: 11 → 19 Plus cascade improvements in the zv*_ wrappers that wrap the above. Cumulative across PR #546 (master → now): 562 subtests / 308 passing --> 6294 subtests / 4504 passing (~14.6x more passing subtests). See dev/modules/dbi_test_parity.md. Generated with [Devin](https://cli.devin.ai/docs) Co-Authored-By: Devin <158243242+devin-ai-integration[bot]@users.noreply.github.com> --- dev/modules/dbi_test_parity.md | 32 ++++++++- .../org/perlonjava/core/Configuration.java | 4 +- src/main/perl/lib/DBI.pm | 56 +++++++++++---- src/main/perl/lib/DBI/_Handles.pm | 72 +++++++++++++++++-- 4 files changed, 141 insertions(+), 23 deletions(-) diff --git a/dev/modules/dbi_test_parity.md b/dev/modules/dbi_test_parity.md index 0854ae221..80e2c0570 100644 --- a/dev/modules/dbi_test_parity.md +++ b/dev/modules/dbi_test_parity.md @@ -5,7 +5,13 @@ DBI test suite, 200 test files) pass on PerlOnJava. ## Current Baseline -After Phase 4 (tied-hash method-dispatch fix): +After Phase 5 (HandleError / set_err severity levels, 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 | |---|---|---|---|---| @@ -444,7 +450,7 @@ Triage these once Phase 1 & 2 are done and we have clean output. ## Progress Tracking -### Current Status: Phases 1–4 landed on `fix/dbi-test-parity` (PR #546). Phase 4 fixed a core PerlOnJava bug in method dispatch on tied hash FETCH. +### Current Status: Phases 1–5 landed on `fix/dbi-test-parity` (PR #546). HandleError and trace-to-file fixed in Phase 5. ### Completed @@ -545,6 +551,28 @@ Triage these once Phase 1 & 2 are done and we have clean output. 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).** + ### Next Steps 1. **Profile-on-disk internals.** `t/41prof_dump.t` / diff --git a/src/main/java/org/perlonjava/core/Configuration.java b/src/main/java/org/perlonjava/core/Configuration.java index 7b099425c..04d411ca9 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 = "a76f69f19"; + public static final String gitCommitId = "65b225caa"; /** * 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 22 2026 20:35:31"; + public static final String buildTimestamp = "Apr 22 2026 20:57:58"; // Prevent instantiation private Configuration() { diff --git a/src/main/perl/lib/DBI.pm b/src/main/perl/lib/DBI.pm index 974b540a3..2bcf11a46 100644 --- a/src/main/perl/lib/DBI.pm +++ b/src/main/perl/lib/DBI.pm @@ -618,33 +618,65 @@ sub bind_columns { sub trace { my ($dbh, $level, $output) = @_; - $level ||= 0; + my $old_level; if (ref $dbh) { - $dbh->{TraceLevel} = $level; - $dbh->{TraceOutput} = $output if defined $output; + $old_level = $dbh->{TraceLevel} || 0; + $dbh->{TraceLevel} = $level if defined $level; } else { # class method: DBI->trace(...) sets the process-global level - $DBI::dbi_debug = $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 = ref($dbh) ? ($dbh->{TraceLevel} || 0) : ($DBI::dbi_debug || 0); if ($level <= $current_level) { - if (ref($dbh) && $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 index 4aaff74d2..fc82d0778 100644 --- a/src/main/perl/lib/DBI/_Handles.pm +++ b/src/main/perl/lib/DBI/_Handles.pm @@ -644,6 +644,23 @@ sub _get_imp_data { return defined $s ? $s : ''; } + # set_err(err, errstr [, state, method, rv]) — standard DBI error + # setter. Tries to match real DBI's semantics, which treat the + # three kinds of err values distinctly: + # + # err truthy — real error. HandleError is always fired; + # 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. + # + # The test suite probes each of these combinations, see + # t/17handle_error.t. sub set_err { my ($h, $err, $errstr, $state, $method, $rv) = @_; $errstr = $err unless defined $errstr; @@ -654,12 +671,49 @@ sub _get_imp_data { $DBI::err = $err; $DBI::errstr = $errstr; $DBI::state = defined $state ? $state : ''; - if ($h->{PrintError}) { - warn "DBI: $errstr\n"; + + # Clearing case: set_err(undef, undef) — no further work. + return $rv if !defined $err; + + # Classify the severity. Real DBI prioritises err > "0" > "" + # by length. + my $is_error = $err ? 1 : 0; + my $is_warning = !$is_error && defined $err && length($err) > 0; + my $is_info = !$is_error && !$is_warning; + return $rv if $is_info; + + # Build a real-DBI-style formatted message ("impl_class method + # failed|warning: errstr") — the test regex keys off this. + 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 : ''); + + # Decide whether HandleError should fire. + # - Real errors always fire it. + # - Warnings only fire it 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; } - if ($h->{RaiseError}) { - die "$errstr\n"; + + 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 } @@ -680,7 +734,10 @@ sub _get_imp_data { my ($h, $msg, $min_level) = @_; $min_level ||= 1; my $level = ref($h) ? ($h->{TraceLevel} || 0) : ($DBI::dbi_debug || 0); - print STDERR $msg if $level >= $min_level; + if ($level >= $min_level) { + my $fh = DBI::_trace_fh(); + print $fh $msg; + } return 1; } @@ -755,12 +812,13 @@ sub _get_imp_data { my ($h, $msg, $level) = @_; $msg = '' unless defined $msg; my $class = ref($h) || $h; - print STDERR "$msg $class=HASH\n"; + 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 STDERR " $k = ", (defined $v ? $v : 'undef'), "\n"; + print $fh " $k = ", (defined $v ? $v : 'undef'), "\n"; } } return 1; From f1020e4cfa319f4cd35d0493ad3f93260d3b8e11 Mon Sep 17 00:00:00 2001 From: "Flavio S. Glock" Date: Wed, 22 Apr 2026 22:28:19 +0200 Subject: [PATCH 11/11] feat(DBI): HandleSetErr, errstr accumulation, Callbacks, :preparse_flags MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Phase 6 of the DBI test-parity plan. Four related improvements in DBI/_Handles.pm: 1. HandleSetErr callback set_err now runs $h->{HandleSetErr}->($h, $err, $errstr, $state, $method) first. If it returns a true value the rest of set_err is short-circuited. The callback can mutate $_[1..3] in-place to override err/errstr/state before they're stored (matching real DBI::PurePerl::set_err behaviour). 2. Errstr accumulation + priority promotion set_err no longer overwrites Errstr on every call; it appends with real DBI's annotations: - "\n$msg" when the message is new - " [err was X now Y]" when err changes - " [state was X now Y]" when state changes (ignoring S1000 seed) Err is only promoted when the new value is higher priority (truthy > "0" > "" > undef by length). This matches what t/08keeperr.t asserts about the running Errstr / Err state across a sequence of set_err calls. 3. Callbacks DBI::_::OuterHandle::AUTOLOAD now checks $h->{Callbacks}{$method} (falling back to the "*" wildcard) before dispatching. Callback gets $self plus the original args; $_ is localised to the method name; the callback's return value in scalar / list context short- circuits the real method dispatch (matching real DBI's callback protocol). 4. :preparse_flags export tag Added as an empty tag so `use DBI qw(:preparse_flags)` works in tests that probe the import even when they don't actually use the preparser (which we don't implement). Effect on `jcpan -t DBI`: before: 200 files, 6294 subtests, 4504 passing after: 200 files, 6570 subtests, 4940 passing => +436 subtests now pass. Per-file: t/08keeperr.t: 17 → 84 passing (7 remain failing) t/70callbacks.t: 36 → 67 passing (14 remain failing) t/17handle_error.t: all 84 still passing (no regression) Also updates dev/modules/dbi_test_parity.md: - Baseline table updated to Phase 6. - New Open Questions entry describing the DBI::PurePerl reuse opportunity — upstream already implements most of what DBI/_Handles.pm does; a future PR could teach DBI.pm to require DBI::PurePerl unconditionally and delete most of _Handles.pm. Not done in this PR because it's a risky architectural change on top of 4900+ passing subtests. Cumulative across PR #546: master was 562/308 passing; now 6570/4940 (~16x more passes). Generated with [Devin](https://cli.devin.ai/docs) Co-Authored-By: Devin <158243242+devin-ai-integration[bot]@users.noreply.github.com> --- dev/modules/dbi_test_parity.md | 58 ++++++- .../org/perlonjava/core/Configuration.java | 6 +- src/main/perl/lib/DBI/_Handles.pm | 155 ++++++++++++++---- src/main/perl/lib/DBI/_Utils.pm | 5 + 4 files changed, 191 insertions(+), 33 deletions(-) diff --git a/dev/modules/dbi_test_parity.md b/dev/modules/dbi_test_parity.md index 80e2c0570..05c0a4feb 100644 --- a/dev/modules/dbi_test_parity.md +++ b/dev/modules/dbi_test_parity.md @@ -5,7 +5,14 @@ DBI test suite, 200 test files) pass on PerlOnJava. ## Current Baseline -After Phase 5 (HandleError / set_err severity levels, trace-to-file): +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 | |---|---|---|---|---| @@ -450,7 +457,7 @@ Triage these once Phase 1 & 2 are done and we have clean output. ## Progress Tracking -### Current Status: Phases 1–5 landed on `fix/dbi-test-parity` (PR #546). HandleError and trace-to-file fixed in Phase 5. +### Current Status: Phases 1–6 landed on `fix/dbi-test-parity` (PR #546). Callbacks, HandleSetErr, and errstr accumulation landed in Phase 6. ### Completed @@ -573,6 +580,27 @@ Triage these once Phase 1 & 2 are done and we have clean output. +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` / @@ -599,6 +627,32 @@ Triage these once Phase 1 & 2 are done and we have clean output. - 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. --- diff --git a/src/main/java/org/perlonjava/core/Configuration.java b/src/main/java/org/perlonjava/core/Configuration.java index 04d411ca9..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 = "65b225caa"; + 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 20:57:58"; + public static final String buildTimestamp = "Apr 23 2026 07:38:18"; // Prevent instantiation private Configuration() { diff --git a/src/main/perl/lib/DBI/_Handles.pm b/src/main/perl/lib/DBI/_Handles.pm index fc82d0778..d1a023c20 100644 --- a/src/main/perl/lib/DBI/_Handles.pm +++ b/src/main/perl/lib/DBI/_Handles.pm @@ -270,6 +270,34 @@ sub _outer_of { 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) { @@ -645,10 +673,10 @@ sub _get_imp_data { } # set_err(err, errstr [, state, method, rv]) — standard DBI error - # setter. Tries to match real DBI's semantics, which treat the - # three kinds of err values distinctly: + # setter. Tries to match real DBI's semantics: # - # err truthy — real error. HandleError is always fired; + # 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 @@ -659,40 +687,111 @@ sub _get_imp_data { # err "" — info. Just stored; no alerts, no handler. # err undef — clear Err/Errstr/State; no alerts. # - # The test suite probes each of these combinations, see - # t/17handle_error.t. + # 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; - $h->STORE(Err => $err); - $h->STORE(Errstr => $errstr); - $h->STORE(State => $state) if defined $state; - # also update $DBI::err / $DBI::errstr / $DBI::state - $DBI::err = $err; - $DBI::errstr = $errstr; - $DBI::state = defined $state ? $state : ''; - - # Clearing case: set_err(undef, undef) — no further work. - return $rv if !defined $err; - - # Classify the severity. Real DBI prioritises err > "0" > "" - # by length. - my $is_error = $err ? 1 : 0; - my $is_warning = !$is_error && defined $err && length($err) > 0; - my $is_info = !$is_error && !$is_warning; - return $rv if $is_info; - - # Build a real-DBI-style formatted message ("impl_class method - # failed|warning: errstr") — the test regex keys off this. + + # 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 : ''); - # Decide whether HandleError should fire. - # - Real errors always fire it. - # - Warnings only fire it when RaiseWarn or PrintWarn is set. + # HandleError: errors always fire it; warnings only when + # RaiseWarn or PrintWarn is set. my $may_handle = $is_error || ($is_warning && ($h->{RaiseWarn} || $h->{PrintWarn})); diff --git a/src/main/perl/lib/DBI/_Utils.pm b/src/main/perl/lib/DBI/_Utils.pm index 6b789540c..5a40478ec 100644 --- a/src/main/perl/lib/DBI/_Utils.pm +++ b/src/main/perl/lib/DBI/_Utils.pm @@ -44,6 +44,11 @@ our (@EXPORT, @EXPORT_OK, %EXPORT_TAGS); 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);