Really fix the DBD::SQLite ping() issue

Apparently DBD::SQLite is notoriously bad at synchronizing its internal
transaction state with {AutoCommit}
https://metacpan.org/source/ADAMK/DBD-SQLite-1.37/lib/DBD/SQLite.pm#L921
There is a function http://www.sqlite.org/c3ref/get_autocommit.html
but DBD::SQLite does not expose it (nor does it seem to properly use it)

Furthermore the detection is rather broken as described in RT#80087.
Bend over backwards to attempt to preserve as much sanity as possible.
While at it issue a non-trappable warning so that folks fix the offending
codepath (which arguably is still broken)

It is possible to have a proper "connection", and have "ping" return
false anyway (e.g. corrupted file). In such cases DBD::SQLite still
keeps the actual file handle open. We don't really want this to happen,
so force-close the handle via DBI itself (this solves a bunch of Win32
test failures)

diff --git a/Changes b/Changes
index 7c4900f..4b4afe1 100644 (file)
--- a/Changes
+++ b/Changes
@@ -1,5 +1,9 @@
 Revision history for DBIx::Class
 
+    * Fixes
+        - Really fix inadequate $dbh->ping SQLite implementation (what shipped
+          in 0.08201 tickled other deficiencies in DBD::SQLite itself)
+
 0.08202 2012-10-06
     * Re-dist due to murphy strike
 

diff --git a/lib/DBIx/Class/Storage/DBI/SQLite.pm b/lib/DBIx/Class/Storage/DBI/SQLite.pm
index 309767f..846f23a 100644 (file)
--- a/lib/DBIx/Class/Storage/DBI/SQLite.pm
+++ b/lib/DBIx/Class/Storage/DBI/SQLite.pm
@@ -94,7 +94,82 @@ sub _exec_svp_rollback {
 
 sub _ping {
   my $self = shift;
-  try { $self->_dbh->do('SELECT * FROM sqlite_master LIMIT 1'); 1 };
+
+  # Be extremely careful what we do here. SQLite is notoriously bad at
+  # synchronizing its internal transaction state with {AutoCommit}
+  # https://metacpan.org/source/ADAMK/DBD-SQLite-1.37/lib/DBD/SQLite.pm#L921
+  # There is a function http://www.sqlite.org/c3ref/get_autocommit.html
+  # but DBD::SQLite does not expose it (nor does it seem to properly use it)
+
+  # Therefore only execute a "ping" when we have no other choice *AND*
+  # scrutinize the thrown exceptions to make sure we are where we think we are
+  my $dbh = $self->_dbh or return undef;
+  return undef unless $dbh->FETCH('Active');
+  return undef unless $dbh->ping;
+
+  # since we do not have access to sqlite3_get_autocommit(), do a trick
+  # to attempt to *safely* determine what state are we *actually* in.
+  # FIXME
+  # also using T::T here leads to bizarre leaks - will figure it out later
+  my $really_not_in_txn = do {
+    local $@;
+
+    # older versions of DBD::SQLite do not properly detect multiline BEGIN/COMMIT
+    # statements to adjust their {AutoCommit} state. Hence use such a statement
+    # pair here as well, in order to escape from poking {AutoCommit} needlessly
+    # https://rt.cpan.org/Public/Bug/Display.html?id=80087
+    eval {
+      # will fail instantly if already in a txn
+      $dbh->do("-- multiline\nBEGIN");
+      $dbh->do("-- multiline\nCOMMIT");
+      1;
+    } or do {
+      ($@ =~ /transaction within a transaction/)
+        ? 0
+        : undef
+      ;
+    };
+  };
+
+  my $ping_fail;
+
+  # if we were unable to determine this - we may very well be dead
+  if (not defined $really_not_in_txn) {
+    $ping_fail = 1;
+  }
+  # check the AC sync-state
+  elsif ($really_not_in_txn xor $dbh->{AutoCommit}) {
+    carp_unique (sprintf
+      'Internal transaction state of handle %s (apparently %s a transaction) does not seem to '
+    . 'match its AutoCommit attribute setting of %s - this is an indication of a '
+    . 'potentially serious bug in your transaction handling logic',
+      $dbh,
+      $really_not_in_txn ? 'NOT in' : 'in',
+      $dbh->{AutoCommit} ? 'TRUE' : 'FALSE',
+    );
+
+    # it is too dangerous to execute anything else in this state
+    # assume everything works (safer - worst case scenario next statement throws)
+    return 1;
+  }
+  else {
+    # do the actual test
+    $ping_fail = ! try { $dbh->do('SELECT * FROM sqlite_master LIMIT 1'); 1 };
+  }
+
+  if ($ping_fail) {
+    # it is possible to have a proper "connection", and have "ping" return
+    # false anyway (e.g. corrupted file). In such cases DBD::SQLite still
+    # keeps the actual file handle open. We don't really want this to happen,
+    # so force-close the handle via DBI itself
+    #
+    local $@; # so that we do not clober the real error as set above
+    eval { $dbh->disconnect }; # if it fails - it fails
+    return undef # the actual RV of _ping()
+  }
+  else {
+    return 1;
+  }
 }
 
 sub deployment_statements {

diff --git a/t/752sqlite.t b/t/752sqlite.t
index 5918c83..272021b 100644 (file)
--- a/t/752sqlite.t
+++ b/t/752sqlite.t
@@ -4,6 +4,7 @@ use warnings;
 use Test::More;
 use Test::Exception;
 use Test::Warn;
+use Time::HiRes 'time';
 use Config;
 
 use lib qw(t/lib);
@@ -43,6 +44,77 @@ use DBICTest;
     'rollback from inner transaction';
 }
 
+# check that we work somewhat OK with braindead SQLite transaction handling
+#
+# As per https://metacpan.org/source/ADAMK/DBD-SQLite-1.37/lib/DBD/SQLite.pm#L921
+# SQLite does *not* try to synchronize
+
+for my $prefix_comment (qw/Begin_only Commit_only Begin_and_Commit/) {
+  note "Testing with comment prefixes on $prefix_comment";
+
+  # FIXME warning won't help us for the time being
+  # perhaps when (if ever) DBD::SQLite gets fixed,
+  # we can do something extra here
+  local $SIG{__WARN__} = sub { warn @_ if $_[0] !~ /Internal transaction state .+? does not seem to match/ }
+    unless $ENV{TEST_VERBOSE};
+
+  my ($c_begin, $c_commit) = map { $prefix_comment =~ $_ ? 1 : 0 } (qr/Begin/, qr/Commit/);
+
+  my $schema = DBICTest->init_schema( no_deploy => 1 );
+  my $ars = $schema->resultset('Artist');
+
+  ok (! $schema->storage->connected, 'No connection yet');
+
+  $schema->storage->dbh->do(<<'DDL');
+CREATE TABLE artist (
+  artistid INTEGER PRIMARY KEY NOT NULL,
+  name varchar(100),
+  rank integer DEFAULT 13,
+  charfield char(10) NULL
+);
+DDL
+
+  my $artist = $ars->create({ name => 'Artist_' . time() });
+  is ($ars->count, 1, 'Inserted artist ' . $artist->name);
+
+  ok ($schema->storage->connected, 'Connected');
+  ok ($schema->storage->_dbh->{AutoCommit}, 'DBD not in txn yet');
+
+  $schema->storage->dbh->do(join "\n",
+    $c_begin ? '-- comment' : (),
+    'BEGIN TRANSACTION'
+  );
+  ok ($schema->storage->connected, 'Still connected');
+  {
+    local $TODO = 'SQLite is retarded wrt detecting BEGIN' if $c_begin;
+    ok (! $schema->storage->_dbh->{AutoCommit}, "DBD aware of txn begin with comments on $prefix_comment");
+  }
+
+  $schema->storage->dbh->do(join "\n",
+    $c_commit ? '-- comment' : (),
+    'COMMIT'
+  );
+  ok ($schema->storage->connected, 'Still connected');
+  {
+    local $TODO = 'SQLite is retarded wrt detecting COMMIT' if $c_commit;
+    ok ($schema->storage->_dbh->{AutoCommit}, "DBD aware txn ended with comments on $prefix_comment");
+  }
+
+  is ($ars->count, 1, 'Inserted artists still there');
+
+  {
+    # this never worked in the 1st place
+    local $TODO = 'SQLite is retarded wrt detecting COMMIT' if ! $c_begin and $c_commit;
+
+    lives_ok {
+      $schema->storage->txn_do (sub {
+        ok ($ars->find({ name => $artist->name }), "Artist still where we left it after cycle with comments on $prefix_comment");
+      });
+    } "Succesfull transaction with comments on $prefix_comment";
+  }
+}
+
+
 my $schema = DBICTest->init_schema();
 
 # make sure the side-effects of RT#67581 do not result in data loss