+ * Closing the JDBC {@code PreparedStatement} here breaks real DBI semantics and + * modules that recycle handles (DBIx::Simple statement cache, etc.). Perl's driver + * finish ends the active cursor, not the lifetime of the prepared statement. * * @param args RuntimeArray containing: * [0] - Statement handle (sth) @@ -749,23 +795,20 @@ public static RuntimeList disconnect(RuntimeArray args, int ctx) { public static RuntimeList finish(RuntimeArray args, int ctx) { RuntimeHash sth = args.get(0).hashDeref(); - // Close the JDBC PreparedStatement to release locks - RuntimeScalar stmtScalar = sth.get("statement"); - if (stmtScalar != null && stmtScalar.value instanceof PreparedStatement stmt) { + RuntimeScalar prevResultRef = sth.get("execute_result"); + if (prevResultRef != null && RuntimeScalarType.isReference(prevResultRef)) { try { - if (!stmt.isClosed()) { - stmt.close(); + RuntimeHash prevResult = prevResultRef.hashDeref(); + RuntimeScalar rsScalar = prevResult.get("resultset"); + if (rsScalar != null && rsScalar.value instanceof ResultSet rs) { + if (!rs.isClosed()) { + rs.close(); + } } - } catch (Exception e) { - // Ignore close errors — statement may already be closed + } catch (Exception ignored) { + // Best effort — cursor may already be closed } } - // Also close any open ResultSet - RuntimeScalar rsScalar = sth.get("execute_result"); - if (rsScalar != null && RuntimeScalarType.isReference(rsScalar)) { - Object rsObj = rsScalar.hashDeref(); - // execute_result may be stored differently; check raw value - } sth.put("Active", new RuntimeScalar(false)); return new RuntimeScalar(1).getList(); diff --git a/src/main/java/org/perlonjava/runtime/regex/RegexPreprocessor.java b/src/main/java/org/perlonjava/runtime/regex/RegexPreprocessor.java index 5781391f6..de0e5e9ba 100644 --- a/src/main/java/org/perlonjava/runtime/regex/RegexPreprocessor.java +++ b/src/main/java/org/perlonjava/runtime/regex/RegexPreprocessor.java @@ -134,7 +134,55 @@ static String preProcessRegex(String s, RegexFlags regexFlags) { StringBuilder sb = new StringBuilder(); handleRegex(s, 0, sb, regexFlags, false); String result = sb.toString(); - return result; + return preferOmniHolderLiteralAlternation(result); + } + + /** + * Perl prefers the longest matching alternative when several branches succeed at the same + * offset; {@link Pattern} tries alternatives strictly left-to-right. DBIx::Simple's omniholder + * substitution uses {@code ($quoted|\(\?\?\))}: the nullable quoted repetition matches the empty + * string everywhere, so Java never reaches the literal {@code (??)} branch and SQL stays + * unchanged — JDBC then rejects {@code (??)} as invalid SQL. + *
+ * Detect the usual Java-preprocessed shape {@code ( (?FLAGS:(?:'…'|"…")*)|\(\?\?\) )}
+ * (single outer capturing group) and swap alternatives so the omniholder literal is tried
+ * first.
+ */
+ static String preferOmniHolderLiteralAlternation(String javaPattern) {
+ final String omniBranch = "\\(\\?\\?\\)";
+ final String needle = "|" + omniBranch;
+ if (javaPattern.length() < omniBranch.length() + 4
+ || javaPattern.charAt(0) != '('
+ || javaPattern.charAt(javaPattern.length() - 1) != ')') {
+ return javaPattern;
+ }
+ int pipeIdx = javaPattern.lastIndexOf(needle);
+ if (pipeIdx <= 1) {
+ return javaPattern;
+ }
+ int omniStart = pipeIdx + 1;
+ if (!javaPattern.startsWith(omniBranch, omniStart)) {
+ return javaPattern;
+ }
+ int closingParenIdx = omniStart + omniBranch.length();
+ if (closingParenIdx != javaPattern.length() - 1 || javaPattern.charAt(closingParenIdx) != ')') {
+ return javaPattern;
+ }
+ String leftAlt = javaPattern.substring(1, pipeIdx);
+ // Narrow heuristic so arbitrary ( A | \(??\) ) patterns are untouched.
+ if (!looksLikeQuotedStarAlternate(leftAlt)) {
+ return javaPattern;
+ }
+ return "(" + omniBranch + "|" + leftAlt + ")";
+ }
+
+ /** Left branch produced from Perl {@code (?:'[^']*'|"[^"]*")*} plus inline (?FLAGS: … ). */
+ private static boolean looksLikeQuotedStarAlternate(String leftAlt) {
+ if (!leftAlt.startsWith("(?")) {
+ return false;
+ }
+ // Typical preprocessing embeds both quote flavours inside a non-capturing cluster.
+ return leftAlt.contains("(?:'[^") && leftAlt.contains("|\"[^");
}
/**
diff --git a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeCode.java b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeCode.java
index b11f36bd1..3747a237b 100644
--- a/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeCode.java
+++ b/src/main/java/org/perlonjava/runtime/runtimetypes/RuntimeCode.java
@@ -349,6 +349,69 @@ public static int effectiveCallContext(int callContext) {
: callContext;
}
+ /**
+ * Perl collapses a multi-value list returned from a subroutine when the callee runs in
+ * scalar context: only the last element survives as the actual return SV. PerlOnJava
+ * historically returned the raw {@link RuntimeList} and relied on the caller (e.g.
+ * chained {@code ->}) to call {@link RuntimeList#scalar()}, which ran too late — mortal
+ * temporaries from intermediate values (DBI execute results, etc.) could be flushed and
+ * tear down shared JDBC state before the outer method ran.
+ */
+ public static RuntimeList coerceScalarCallResult(RuntimeList result, int effectiveContext) {
+ if (result == null) {
+ return null;
+ }
+ if (result instanceof RuntimeControlFlowList) {
+ return result;
+ }
+ if (effectiveContext == RuntimeContextType.SCALAR && result.elements.size() > 1) {
+ return new RuntimeList(result.scalar());
+ }
+ return result;
+ }
+
+ /**
+ * Keep the blessed invocant's referent alive for the duration of a method dispatch.
+ * Nested {@code MortalList.flushAboveMark()} (e.g. from {@link RuntimeScalar#set})
+ * can otherwise dequeue deferred decrements and run DESTROY on chain temporaries such as
+ * {@code $db->query(...)->arrays} mid-callee — JDBC cursors appear truncated vs a lexical
+ * holding the intermediate result (DBIx::Simple).
+ */
+ private static RuntimeBase acquireMethodInvocantHold(RuntimeScalar runtimeScalar) {
+ RuntimeScalar v = runtimeScalar;
+ while (v != null && v.type == RuntimeScalarType.READONLY_SCALAR) {
+ v = (RuntimeScalar) v.value;
+ }
+ if (v == null || !RuntimeScalarType.isReference(v)) {
+ return null;
+ }
+ if (!(v.value instanceof RuntimeBase base)) {
+ return null;
+ }
+ if (base.blessId == 0) {
+ return null;
+ }
+ if (base.refCount == Integer.MIN_VALUE || base.currentlyDestroying) {
+ return null;
+ }
+ if (base.refCount < 0) {
+ return null;
+ }
+ base.traceRefCount(+1, "RuntimeCode.method invocant hold (+1)");
+ base.refCount++;
+ return base;
+ }
+
+ private static void releaseMethodInvocantHold(RuntimeBase holdBase) {
+ if (holdBase == null) {
+ return;
+ }
+ holdBase.traceRefCount(-1, "RuntimeCode.method invocant hold release (-1)");
+ if (holdBase.refCount > 0 && holdBase.refCount != Integer.MIN_VALUE && !holdBase.currentlyDestroying) {
+ holdBase.refCount--;
+ }
+ }
+
public static boolean isLvalueCode(RuntimeCode code) {
return code != null && code.attributes != null && code.attributes.contains("lvalue");
}
@@ -2182,6 +2245,8 @@ private static RuntimeList callCachedInner(int callsiteId,
return callCached(callsiteId, runtimeScalar.tiedFetch(), method,
currentSub, args, callContext);
}
+ RuntimeBase pjMethodInvHold = acquireMethodInvocantHold(runtimeScalar);
+ try {
// 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())
@@ -2230,13 +2295,15 @@ private static RuntimeList callCachedInner(int callsiteId,
MortalList.pushMark();
try {
// Prefer PerlSubroutine interface over MethodHandle
+ RuntimeList out;
if (cachedCode.subroutine != null) {
- return cachedCode.subroutine.apply(a, effectiveContext);
+ out = cachedCode.subroutine.apply(a, effectiveContext);
} else if (cachedCode.isStatic) {
- return (RuntimeList) cachedCode.methodHandle.invoke(a, effectiveContext);
+ out = (RuntimeList) cachedCode.methodHandle.invoke(a, effectiveContext);
} else {
- return (RuntimeList) cachedCode.methodHandle.invoke(cachedCode.codeObject, a, effectiveContext);
+ out = (RuntimeList) cachedCode.methodHandle.invoke(cachedCode.codeObject, a, effectiveContext);
}
+ return coerceScalarCallResult(out, effectiveContext);
} finally {
MortalList.popMark();
}
@@ -2294,34 +2361,30 @@ private static RuntimeList callCachedInner(int callsiteId,
}
}
- // Fall back to regular call
- return call(runtimeScalar, method, currentSub, args, callContext);
+ // Fall back without nesting through call(...) — avoids double refcount hold
+ // (this outer frame already holds the invocant for the inlined-cache miss path).
+ RuntimeArray aFallback = new RuntimeArray();
+ aFallback.elements.add(runtimeScalar);
+ for (RuntimeBase arg : args) {
+ arg.setArrayOfAlias(aFallback);
+ }
+ return dispatchPerlMethodAfterSelfInjected(runtimeScalar, method, currentSub, aFallback, callContext);
+ } finally {
+ releaseMethodInvocantHold(pjMethodInvHold);
+ }
}
/**
- * Call a method in a Perl-like class hierarchy using the C3 linearization algorithm.
- *
- * @param runtimeScalar The object to call the method on.
- * @param method The method to resolve.
- * @param currentSub The subroutine to resolve SUPER::method in.
- * @param args The arguments to pass to the method.
- * @param callContext The call context.
- * @return The result of the method call.
+ * Dispatches {@code METHOD $self, ...} after {@code $self} is already element 0 of {@code args}.
+ * Caller must unwrap TIED_SCALAR and apply {@link #acquireMethodInvocantHold}/{@link
+ * #releaseMethodInvocantHold} unless another frame already retains the blessed invocant.
*/
- public static RuntimeList call(RuntimeScalar runtimeScalar,
- RuntimeScalar method,
- 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);
+ private static RuntimeList dispatchPerlMethodAfterSelfInjected(
+ RuntimeScalar runtimeScalar,
+ RuntimeScalar method,
+ RuntimeScalar currentSub,
+ RuntimeArray args,
+ int callContext) {
// System.out.println("call ->" + method + " " + currentPackage + " " + args + " " + callContext);
@@ -2513,6 +2576,38 @@ public static RuntimeList call(RuntimeScalar runtimeScalar,
}
}
+ /**
+ * Call a method in a Perl-like class hierarchy using the C3 linearization algorithm.
+ *
+ * @param runtimeScalar The object to call the method on.
+ * @param method The method to resolve.
+ * @param currentSub The subroutine to resolve SUPER::method in.
+ * @param args The arguments to pass to the method.
+ * @param callContext The call context.
+ * @return The result of the method call.
+ */
+ public static RuntimeList call(RuntimeScalar runtimeScalar,
+ RuntimeScalar method,
+ 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);
+ }
+
+ RuntimeBase invHold = acquireMethodInvocantHold(runtimeScalar);
+ // insert `this` into the parameter list
+ args.elements.addFirst(runtimeScalar);
+ try {
+ return dispatchPerlMethodAfterSelfInjected(runtimeScalar, method, currentSub, args, callContext);
+ } finally {
+ releaseMethodInvocantHold(invHold);
+ }
+ }
+
/**
* Implementation of Perl's caller() builtin.
* This version doesn't have access to __SUB__, so it can't honor set_subname for JVM code.
@@ -3030,8 +3125,9 @@ public static RuntimeList apply(RuntimeScalar runtimeScalar, RuntimeArray a, int
// caller's dynamic scope — e.g., after local $SIG{__WARN__} unwinds,
// causing Test::Warn to miss warnings from DESTROY.
MortalList.flushAboveMark();
+ return result;
}
- return result;
+ return coerceScalarCallResult(result, effectiveContext);
}
} catch (PerlNonLocalReturnException e) {
// Non-local return from map/grep block
@@ -4011,7 +4107,7 @@ public RuntimeList apply(RuntimeArray a, int callContext) {
} else {
result = (RuntimeList) this.methodHandle.invoke(this.codeObject, a, effectiveContext);
}
- return result;
+ return coerceScalarCallResult(result, effectiveContext);
} finally {
if (warningBits != null) {
WarningBitsRegistry.popCurrent();
@@ -4128,7 +4224,7 @@ public RuntimeList apply(String subroutineName, RuntimeArray a, int callContext)
} else {
result = (RuntimeList) this.methodHandle.invoke(this.codeObject, a, effectiveContext);
}
- return result;
+ return coerceScalarCallResult(result, effectiveContext);
} finally {
if (warningBits != null) {
WarningBitsRegistry.popCurrent();
diff --git a/src/main/perl/lib/DBI.pm b/src/main/perl/lib/DBI.pm
index 6553d24ac..3e17190cf 100644
--- a/src/main/perl/lib/DBI.pm
+++ b/src/main/perl/lib/DBI.pm
@@ -933,8 +933,11 @@ sub fetch {
sub fetchall_arrayref {
my ($sth, $slice, $max_rows) = @_;
- # Return undef if statement handle is inactive
- return undef unless $sth->{Database}{Active};
+ # Match Perl DBI: gate on the sth's Active flag (pending/current result set),
+ # not Database->{Active} (dbh-level connection flag). JDBC-backed handles keep
+ # Database->{Active} accurate but clear sth->{Active} after DML executes; using
+ # Database here makes fetchall_arrayref spuriously return [] after SELECT execute().
+ return undef unless $sth->{Active};
my @rows;
my $row_count = 0;
@@ -1001,8 +1004,7 @@ sub fetchall_arrayref {
sub fetchall_hashref {
my ($sth, $key_field) = @_;
- # Return undef if statement handle is inactive
- return undef unless $sth->{Database}{Active};
+ return undef unless $sth->{Active};
my %results;
diff --git a/src/main/perl/lib/DBIx/Simple.pm b/src/main/perl/lib/DBIx/Simple.pm
new file mode 100644
index 000000000..3371c3857
--- /dev/null
+++ b/src/main/perl/lib/DBIx/Simple.pm
@@ -0,0 +1,1140 @@
+use 5.006;
+use strict;
+use DBI;
+use Carp ();
+
+$DBIx::Simple::VERSION = '1.37';
+$Carp::Internal{$_} = 1
+ for qw(DBIx::Simple DBIx::Simple::Result DBIx::Simple::DeadObject);
+
+my $no_raiseerror = $ENV{PERL_DBIX_SIMPLE_NO_RAISEERROR};
+
+my $quoted = qr/(?:'[^']*'|"[^"]*")*/; # 'foo''bar' simply matches the (?:) twice
+my $quoted_mysql = qr/(?:(?:[^\\']*(?:\\.[^\\']*)*)'|"(?:[^\\"]*(?:\\.[^\\"]*)*)")*/;
+
+my %statements; # "$db" => { "$st" => $st, ... }
+my %old_statements; # "$db" => [ [ $query, $st ], ... ]
+my %keep_statements; # "$db" => $int
+
+my $err_message = '%s no longer usable (because of %%s)';
+my $err_cause = '%s at %s line %d';
+
+package DBIx::Simple;
+
+### private helper subs
+
+sub _dummy { bless \my $dummy, 'DBIx::Simple::Dummy' }
+sub _swap {
+ my ($hash1, $hash2) = @_;
+ my $tempref = ref $hash1;
+ my $temphash = { %$hash1 };
+ %$hash1 = %$hash2;
+ bless $hash1, ref $hash2;
+ %$hash2 = %$temphash;
+ bless $hash2, $tempref;
+}
+
+### constructor
+
+sub connect {
+ my ($class, @arguments) = @_;
+ my $self = { lc_columns => 1, result_class => 'DBIx::Simple::Result' };
+ if (defined $arguments[0] and UNIVERSAL::isa($arguments[0], 'DBI::db')) {
+ $self->{dont_disconnect} = 1;
+ $self->{dbh} = shift @arguments;
+ Carp::carp("Additional arguments for $class->connect are ignored")
+ if @arguments;
+ } else {
+ $arguments[3]->{PrintError} = 0
+ unless defined $arguments[3] and exists $arguments[3]{PrintError};
+ $arguments[3]->{RaiseError} = 1
+ unless $no_raiseerror
+ or defined $arguments[3] and exists $arguments[3]{RaiseError};
+ $self->{dbh} = DBI->connect(@arguments);
+ }
+
+ return undef unless $self->{dbh};
+
+ $self->{dbd} = $self->{dbh}->{Driver}->{Name};
+ bless $self, $class;
+
+ $statements{$self} = {};
+ $old_statements{$self} = [];
+ # PerlOnJava/JDBC: statement recycling is unsafe — finishing one Result invalidates the
+ # cached Perl DBI::st wrapper while Java keeps one PreparedStatement; the next recycle
+ # yields an undef sth and crashes DBIx::Simple::query (sqlite.t).
+ $keep_statements{$self} = DBI::_is_jdbc_handle($self->{dbh}) ? 0 : 16;
+
+ return $self;
+}
+
+sub new {
+ my ($class) = shift;
+ $class->connect(@_);
+}
+
+### properties
+
+sub keep_statements : lvalue { $keep_statements{ $_[0] } }
+sub lc_columns : lvalue { $_[0]->{lc_columns} }
+sub result_class : lvalue { $_[0]->{result_class} }
+
+sub abstract : lvalue {
+ require SQL::Abstract;
+ $_[0]->{abstract} ||= SQL::Abstract->new;
+}
+
+sub error {
+ my ($self) = @_;
+ return 'DBI error: ' . (ref $self ? $self->{dbh}->errstr : $DBI::errstr);
+}
+
+sub dbh { $_[0]->{dbh} }
+
+### private methods
+
+# Replace (??) with (?, ?, ?, ...)
+sub _replace_omniholder {
+ my ($self, $query, $binds) = @_;
+ return if $$query !~ /\(\?\?\)/;
+ my $omniholders = 0;
+ my $q = $self->{dbd} =~ /mysql/ ? $quoted_mysql : $quoted;
+ $$query =~ s[($q|\(\?\?\))] {
+ $1 eq '(??)'
+ ? do {
+ Carp::croak('There can be only one omniholder')
+ if $omniholders++;
+ '(' . join(', ', ('?') x @$binds) . ')'
+ }
+ : $1
+ }eg;
+}
+
+# Invalidate and clean up
+sub _die {
+ my ($self, $cause) = @_;
+
+ defined and $_->_die($cause, 0)
+ for values %{ $statements{$self} },
+ map $$_[1], @{ $old_statements{$self} };
+ delete $statements{$self};
+ delete $old_statements{$self};
+ delete $keep_statements{$self};
+
+ unless ($self->{dont_disconnect}) {
+ # Conditional, because destruction order is not guaranteed
+ # during global destruction.
+ $self->{dbh}->disconnect() if defined $self->{dbh};
+ }
+
+ _swap(
+ $self,
+ bless {
+ what => 'Database object',
+ cause => $cause
+ }, 'DBIx::Simple::DeadObject'
+ ) unless $cause =~ /DESTROY/; # Let's not cause infinite loops :)
+}
+
+### public methods
+
+sub query {
+ my ($self, $query, @binds) = @_;
+ $self->{success} = 0;
+
+ $self->_replace_omniholder(\$query, \@binds);
+
+ my $st;
+ my $sth;
+
+ my $old = $old_statements{$self};
+
+ if (defined( my $i = (grep $old->[$_][0] eq $query, 0..$#$old)[0] )) {
+ $st = splice(@$old, $i, 1)->[1];
+ $sth = $st->{sth};
+ } else {
+ eval { $sth = $self->{dbh}->prepare($query) } or do {
+ if ($@) {
+ $@ =~ s/ at \S+ line \d+\.\n\z//;
+ Carp::croak($@);
+ }
+ $self->{reason} = "Prepare failed ($DBI::errstr)";
+ return _dummy;
+ };
+
+ # $self is quoted on purpose, to pass along the stringified version,
+ # and avoid increasing reference count.
+ $st = bless {
+ db => "$self",
+ sth => $sth,
+ query => $query
+ }, 'DBIx::Simple::Statement';
+ $statements{$self}{$st} = $st;
+ }
+
+ eval { $sth->execute(@binds) } or do {
+ if ($@) {
+ $@ =~ s/ at \S+ line \d+\.\n\z//;
+ Carp::croak($@);
+ }
+
+ $self->{reason} = "Execute failed ($DBI::errstr)";
+ return _dummy;
+ };
+
+ $self->{success} = 1;
+
+ return bless { st => $st, lc_columns => $self->{lc_columns} }, $self->{result_class};
+}
+
+sub begin_work { $_[0]->{dbh}->begin_work }
+sub begin { $_[0]->begin_work }
+sub commit { $_[0]->{dbh}->commit }
+sub rollback { $_[0]->{dbh}->rollback }
+sub func { shift->{dbh}->func(@_) }
+
+sub last_insert_id {
+ my ($self) = @_;
+
+ ($self->{dbi_version} ||= DBI->VERSION) >= 1.38 or Carp::croak(
+ "DBI v1.38 required for last_insert_id" .
+ "--this is only $self->{dbi_version}, stopped"
+ );
+
+ return shift->{dbh}->last_insert_id(@_);
+}
+
+sub disconnect {
+ my ($self) = @_;
+ $self->_die(sprintf($err_cause, "$self->disconnect", (caller)[1, 2]));
+ return 1;
+}
+
+sub DESTROY {
+ my ($self) = @_;
+ $self->_die(sprintf($err_cause, "$self->DESTROY", (caller)[1, 2]));
+}
+
+### public methods wrapping SQL::Abstract
+
+for my $method (qw/select insert update delete/) {
+ no strict 'refs';
+ *$method = sub {
+ my $self = shift;
+ return $self->query($self->abstract->$method(@_));
+ }
+}
+
+### public method wrapping SQL::Interp
+
+sub iquery {
+ require SQL::Interp;
+ my $self = shift;
+ return $self->query( SQL::Interp::sql_interp(@_) );
+}
+
+package DBIx::Simple::Dummy;
+
+use overload
+ '""' => sub { shift },
+ bool => sub { 0 };
+
+sub new { bless \my $dummy, shift }
+sub AUTOLOAD { return }
+
+package DBIx::Simple::DeadObject;
+
+sub _die {
+ my ($self) = @_;
+ Carp::croak(
+ sprintf(
+ "(This should NEVER happen!) " .
+ sprintf($err_message, $self->{what}),
+ $self->{cause}
+ )
+ );
+}
+
+sub AUTOLOAD {
+ my ($self) = @_;
+ Carp::croak(
+ sprintf(
+ sprintf($err_message, $self->{what}),
+ $self->{cause}
+ )
+ );
+}
+sub DESTROY { }
+
+package DBIx::Simple::Statement;
+
+sub _die {
+ my ($self, $cause, $save) = @_;
+
+ $self->{sth}->finish() if defined $self->{sth};
+ $self->{dead} = 1;
+
+ my $stringy_db = "$self->{db}";
+ my $stringy_self = "$self";
+
+ my $foo = bless {
+ what => 'Statement object',
+ cause => $cause
+ }, 'DBIx::Simple::DeadObject';
+
+ DBIx::Simple::_swap($self, $foo);
+
+ my $old = $old_statements{ $foo->{db} };
+ my $keep = $keep_statements{ $foo->{db} };
+
+ if ($save and $keep) {
+ $foo->{dead} = 0;
+ shift @$old until @$old + 1 <= $keep;
+ push @$old, [ $foo->{query}, $foo ];
+ }
+
+ delete $statements{ $stringy_db }{ $stringy_self };
+}
+
+sub DESTROY {
+ # This better only happen during global destruction...
+ return if $_[0]->{dead};
+ $_[0]->_die('Ehm', 0);
+}
+
+package DBIx::Simple::Result;
+
+sub _die {
+ my ($self, $cause) = @_;
+ if ($cause) {
+ $self->{st}->_die($cause, 1);
+ DBIx::Simple::_swap(
+ $self,
+ bless {
+ what => 'Result object',
+ cause => $cause,
+ }, 'DBIx::Simple::DeadObject'
+ );
+ } else {
+ $cause = $self->{st}->{cause};
+ DBIx::Simple::_swap(
+ $self,
+ bless {
+ what => 'Result object',
+ cause => $cause
+ }, 'DBIx::Simple::DeadObject'
+ );
+ Carp::croak(
+ sprintf(
+ sprintf($err_message, $self->{what}),
+ $cause
+ )
+ );
+ }
+}
+
+sub func { shift->{st}->{sth}->func(@_) }
+sub attr { my $dummy = $_[0]->{st}->{sth}->{$_[1]} }
+
+sub columns {
+ $_[0]->_die if ref $_[0]->{st} eq 'DBIx::Simple::DeadObject';
+ my $c = $_[0]->{st}->{sth}->{ $_[0]->{lc_columns} ? 'NAME_lc' : 'NAME' };
+ return wantarray ? @$c : $c;
+}
+
+sub bind {
+ $_[0]->_die if ref $_[0]->{st} eq 'DBIx::Simple::DeadObject';
+ $_[0]->{st}->{sth}->bind_columns(\@_[1..$#_]);
+}
+
+
+### Single
+
+sub fetch {
+ $_[0]->_die if ref $_[0]->{st} eq 'DBIx::Simple::DeadObject';
+ return $_[0]->{st}->{sth}->fetch;
+}
+
+sub into {
+ $_[0]->_die if ref $_[0]->{st} eq 'DBIx::Simple::DeadObject';
+ my $sth = $_[0]->{st}->{sth};
+ $sth->bind_columns(\@_[1..$#_]) if @_ > 1;
+ return $sth->fetch;
+}
+
+sub list {
+ $_[0]->_die if ref $_[0]->{st} eq 'DBIx::Simple::DeadObject';
+ return $_[0]->{st}->{sth}->fetchrow_array if wantarray;
+ return($_[0]->{st}->{sth}->fetchrow_array)[-1];
+}
+
+sub array {
+ $_[0]->_die if ref $_[0]->{st} eq 'DBIx::Simple::DeadObject';
+ my $row = $_[0]->{st}->{sth}->fetchrow_arrayref or return;
+ return [ @$row ];
+}
+
+sub hash {
+ $_[0]->_die if ref $_[0]->{st} eq 'DBIx::Simple::DeadObject';
+ return $_[0]->{st}->{sth}->fetchrow_hashref(
+ $_[0]->{lc_columns} ? 'NAME_lc' : 'NAME'
+ );
+}
+
+sub kv_list {
+ $_[0]->_die if ref $_[0]->{st} eq 'DBIx::Simple::DeadObject';
+ my @keys = $_[0]->columns;
+ my $values = $_[0]->array or return;
+ Carp::croak("Different numbers of column names and values")
+ if @keys != @$values;
+ return map { $keys[$_], $values->[$_] } 0 .. $#keys if wantarray;
+ return [ map { $keys[$_], $values->[$_] } 0 .. $#keys ];
+}
+
+sub kv_array {
+ $_[0]->_die if ref $_[0]->{st} eq 'DBIx::Simple::DeadObject';
+ scalar shift->kv_list(@_);
+}
+
+sub object {
+ $_[0]->_die if ref $_[0]->{st} eq 'DBIx::Simple::DeadObject';
+ my $self = shift;
+ my $class = shift || ':RowObject';
+ $class =~ s/^:/DBIx::Simple::Result::/;
+ if (not $class->can('new_from_dbix_simple') || $class->can('new')) {
+ (my $filename = "$class.pm") =~ s[::][/]g;
+ require $filename;
+ }
+ if ($class->can('new_from_dbix_simple')) {
+ return scalar $class->new_from_dbix_simple($self, @_);
+ }
+ if ($class->can('new')) {
+ return $class->new( $self->kv_list );
+ }
+ Carp::croak(
+ qq(Can't locate object method "new_from_dbix_simple" or "new" ) .
+ qq(via package "$class".)
+ );
+}
+
+### Slurp
+
+sub flat {
+ $_[0]->_die if ref $_[0]->{st} eq 'DBIx::Simple::DeadObject';
+ return map @$_, $_[0]->arrays if wantarray;
+ return [ map @$_, $_[0]->arrays ];
+}
+
+sub arrays {
+ $_[0]->_die if ref $_[0]->{st} eq 'DBIx::Simple::DeadObject';
+ return @{ $_[0]->{st}->{sth}->fetchall_arrayref } if wantarray;
+ return $_[0]->{st}->{sth}->fetchall_arrayref;
+}
+
+sub hashes {
+ $_[0]->_die if ref $_[0]->{st} eq 'DBIx::Simple::DeadObject';
+ my @return;
+ my $dummy;
+ push @return, $dummy while $dummy = $_[0]->hash;
+ return wantarray ? @return : \@return;
+}
+
+sub kv_flat {
+ $_[0]->_die if ref $_[0]->{st} eq 'DBIx::Simple::DeadObject';
+ return map @$_, $_[0]->kv_arrays if wantarray;
+ return [ map @$_, $_[0]->kv_arrays ];
+}
+
+sub kv_arrays {
+ $_[0]->_die if ref $_[0]->{st} eq 'DBIx::Simple::DeadObject';
+ my @return;
+ my $dummy;
+ push @return, $dummy while $dummy = $_[0]->kv_array;
+ return wantarray ? @return : \@return;
+}
+
+sub objects {
+ $_[0]->_die if ref $_[0]->{st} eq 'DBIx::Simple::DeadObject';
+ my $self = shift;
+ my $class = shift || ':RowObject';
+ $class =~ s/^:/DBIx::Simple::Result::/;
+ if (not $class->can('new_from_dbix_simple') || $class->can('new')) {
+ (my $package = "$class.pm") =~ s[::][/]g;
+ require $package;
+ }
+ if ($class->can('new_from_dbix_simple')) {
+ return $class->new_from_dbix_simple($self, @_) if wantarray;
+ return [ $class->new_from_dbix_simple($self, @_) ];
+ }
+ if ($class->can('new')) {
+ return map { $class->new( @$_ ) } $self->kv_arrays if wantarray;
+ return [ map { $class->new( @$_ ) } $self->kv_arrays ];
+ }
+ Carp::croak(
+ qq(Can't locate object method "new_from_dbix_simple" or "new" ) .
+ qq(via package "$class" (perhaps you forgot to load "$class"?))
+ );
+}
+
+sub _map {
+ my ($keys, $values) = @_;
+ my %return;
+ @return{@$keys} = @$values;
+ return wantarray ? %return : \%return;
+}
+
+sub _group {
+ my ($keys, $values) = @_;
+ my %return;
+ push @{ $return{shift @$keys} }, shift @$values while @$values;
+ return wantarray ? %return : \%return;
+}
+
+sub _keys_and_hashes {
+ $_[0]->_die if ref $_[0]->{st} eq 'DBIx::Simple::DeadObject';
+ my ($self, $keyname) = @_;
+ Carp::croak('Key column name not optional') if not defined $keyname;
+ my @rows = $self->hashes;
+ my @keys;
+ push @keys, delete $_->{$keyname} for @rows;
+ return \@keys, \@rows;
+}
+
+sub _keys_and_arrays {
+ $_[0]->_die if ref $_[0]->{st} eq 'DBIx::Simple::DeadObject';
+ my ($self, $keyindex) = @_;
+ $keyindex += 0;
+ my @rows = $self->arrays;
+ my @keys;
+ push @keys, splice @$_, $keyindex, 1 for @rows;
+ return \@keys, \@rows;
+}
+
+sub group_hashes { return _group shift->_keys_and_hashes(@_) }
+sub map_hashes { return _map shift->_keys_and_hashes(@_) }
+sub group_arrays { return _group shift->_keys_and_arrays(@_) }
+sub map_arrays { return _map shift->_keys_and_arrays(@_) }
+
+sub map {
+ $_[0]->_die if ref $_[0]->{st} eq 'DBIx::Simple::DeadObject';
+ return map @$_, @{ $_[0]->{st}->{sth}->fetchall_arrayref } if wantarray;
+ return { map @$_, @{ $_[0]->{st}->{sth}->fetchall_arrayref } };
+}
+
+sub group {
+ $_[0]->_die if ref $_[0]->{st} eq 'DBIx::Simple::DeadObject';
+ my %return;
+ while (my $row = $_[0]->fetch) {
+ push @{ $return{ $row->[0] } }, $row->[1];
+ }
+ return wantarray ? %return : \%return;
+}
+
+sub rows {
+ $_[0]->_die if ref $_[0]->{st} eq 'DBIx::Simple::DeadObject';
+ $_[0]->{st}->{sth}->rows;
+}
+
+sub xto {
+ $_[0]->_die if ref $_[0]->{st} eq 'DBIx::Simple::DeadObject';
+ require DBIx::XHTML_Table;
+ my $self = shift;
+ my $attr = ref $_[0] ? $_[0] : { @_ };
+
+ # Old DBD::SQLite (.29) spits out garbage if done *after* fetching.
+ my $columns = $self->{st}->{sth}->{NAME};
+
+ return DBIx::XHTML_Table->new(
+ scalar $self->arrays,
+ $columns,
+ $attr
+ );
+}
+
+sub html {
+ $_[0]->_die if ref $_[0]->{st} eq 'DBIx::Simple::DeadObject';
+ my $self = shift;
+ my $attr = ref $_[0] ? $_[0] : { @_ };
+ return $self->xto($attr)->output($attr);
+}
+
+sub text {
+ $_[0]->_die if ref $_[0]->{st} eq 'DBIx::Simple::DeadObject';
+ my ($self, $type) = @_;
+ my $text_table = defined $type && length $type
+ ? 0
+ : eval { require Text::Table; $type = 'table'; 1 };
+ $type ||= 'neat';
+ if ($type eq 'box' or $type eq 'table') {
+ my $box = $type eq 'box';
+ $text_table or require Text::Table;
+ my @columns = map +{ title => $_, align_title => 'center' },
+ @{ $self->{st}->{sth}->{NAME} };
+ my $c = 0;
+ splice @columns, $_ + $c++, 0, \' | ' for 1 .. $#columns;
+ my $table = Text::Table->new(
+ ($box ? \'| ' : ()),
+ @columns,
+ ($box ? \' |' : ())
+ );
+ $table->load($self->arrays);
+ my $rule = $table->rule(qw/- +/);
+ return join '',
+ ($box ? $rule : ()),
+ $table->title, $rule, $table->body,
+ ($box ? $rule : ());
+ }
+ Carp::carp("Unknown type '$type'; using 'neat'") if $type ne 'neat';
+ return join '', map DBI::neat_list($_) . "\n", $self->arrays;
+}
+
+sub finish {
+ $_[0]->_die if ref $_[0]->{st} eq 'DBIx::Simple::DeadObject';
+ my ($self) = @_;
+ $self->_die(
+ sprintf($err_cause, "$self->finish", (caller)[1, 2])
+ );
+}
+
+sub DESTROY {
+ return if ref $_[0]->{st} eq 'DBIx::Simple::DeadObject';
+ my ($self) = @_;
+ $self->_die(
+ sprintf($err_cause, "$self->DESTROY", (caller)[1, 2])
+ );
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+DBIx::Simple - Very complete easy-to-use OO interface to DBI
+
+=head1 SYNOPSIS
+
+=head2 DBIx::Simple
+
+ $db = DBIx::Simple->connect(...) # or ->new
+
+ $db->keep_statements = 16
+ $db->lc_columns = 1
+ $db->result_class = 'DBIx::Simple::Result';
+
+ $db->begin_work $db->commit
+ $db->rollback $db->disconnect
+ $db->func(...) $db->last_insert_id
+
+ $result = $db->query(...)
+
+=head2 DBIx::SImple + SQL::Interp
+
+ $result = $db->iquery(...)
+
+=head2 DBIx::Simple + SQL::Abstract
+
+ $db->abstract = SQL::Abstract->new(...)
+
+ $result = $db->select(...)
+ $result = $db->insert(...)
+ $result = $db->update(...)
+ $result = $db->delete(...)
+
+=head2 DBIx::Simple::Result
+
+ @columns = $result->columns
+
+ $result->into($foo, $bar, $baz)
+ $row = $result->fetch
+
+ @row = $result->list @rows = $result->flat
+ $row = $result->array @rows = $result->arrays
+ $row = $result->hash @rows = $result->hashes
+ @row = $result->kv_list @rows = $result->kv_flat
+ $row = $result->kv_array @rows = $result->kv_arrays
+ $obj = $result->object @objs = $result->objects
+
+ %map = $result->map %grouped = $result->group
+ %map = $result->map_hashes(...) %grouped = $result->group_hashes(...)
+ %map = $result->map_arrays(...) %grouped = $result->group_arrays(...)
+
+ $rows = $result->rows
+
+ $dump = $result->text
+
+ $result->finish
+
+=head2 DBIx::Simple::Result + DBIx::XHTML_Table
+
+ $html = $result->html(...)
+
+ $table_object = $result->xto(...)
+
+=head2 Examples
+
+Please read L