It seems the upcoming DBD::SQLite fixes the txn sync issues

Short circuit the travesty introduced in 2aeb3c7f

diff --git a/lib/DBIx/Class/Storage/DBI/SQLite.pm b/lib/DBIx/Class/Storage/DBI/SQLite.pm
index db46ce2..72146db 100644 (file)
--- a/lib/DBIx/Class/Storage/DBI/SQLite.pm
+++ b/lib/DBIx/Class/Storage/DBI/SQLite.pm
@@ -147,69 +147,78 @@ sub _ping {
   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 {
+  my $ping_fail;
+
+  # older DBD::SQLite does not properly synchronize commit state between
+  # the libsqlite and the $dbh
+  unless (defined $DBD::SQLite::__DBIC_TXN_SYNC_SANE__) {
     local $@;
+    $DBD::SQLite::__DBIC_TXN_SYNC_SANE__ = eval { DBD::SQLite->VERSION(1.38_02); 1 }
+      ? 1
+      : 0
+    ;
+  }
 
-    # 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
-      ;
+  # fallback to travesty
+  unless ($DBD::SQLite::__DBIC_TXN_SYNC_SANE__) {
+    # 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 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;
+    }
   }
 
-  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;
-  }
+  # do the actual test and return on no failure
+  ( $ping_fail ||= ! try { $dbh->do('SELECT * FROM sqlite_master LIMIT 1'); 1 } )
+    or return 1; # the actual RV of _ping()
+
+  # ping failed (or so it seems) - need to do some cleanup
+  # 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
+  undef; # the actual RV of _ping()
 }
 
 sub deployment_statements {

diff --git a/t/752sqlite.t b/t/752sqlite.t
index 1a511f2..fc28037 100644 (file)
--- a/t/752sqlite.t
+++ b/t/752sqlite.t
@@ -48,6 +48,14 @@ use DBICTest;
 #
 # As per https://metacpan.org/source/ADAMK/DBD-SQLite-1.37/lib/DBD/SQLite.pm#L921
 # SQLite does *not* try to synchronize
+#
+# However DBD::SQLite 1.38_02 seems to fix this, with an accompanying test:
+# https://metacpan.org/source/ADAMK/DBD-SQLite-1.38_02/t/54_literal_txn.t
+
+my $lit_txn_todo = eval { DBD::SQLite->VERSION(1.38_02) }
+  ? undef
+  : "DBD::SQLite before 1.38_02 is retarded wrt detecting literal BEGIN/COMMIT statements"
+;
 
 for my $prefix_comment (qw/Begin_only Commit_only Begin_and_Commit/) {
   note "Testing with comment prefixes on $prefix_comment";
@@ -56,7 +64,7 @@ for my $prefix_comment (qw/Begin_only Commit_only Begin_and_Commit/) {
   # 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};
+    if ( $lit_txn_todo && !$ENV{TEST_VERBOSE} );
 
   my ($c_begin, $c_commit) = map { $prefix_comment =~ $_ ? 1 : 0 } (qr/Begin/, qr/Commit/);
 
@@ -86,7 +94,7 @@ DDL
   );
   ok ($schema->storage->connected, 'Still connected');
   {
-    local $TODO = 'SQLite is retarded wrt detecting BEGIN' if $c_begin;
+    local $TODO = $lit_txn_todo if $c_begin;
     ok (! $schema->storage->_dbh->{AutoCommit}, "DBD aware of txn begin with comments on $prefix_comment");
   }
 
@@ -96,7 +104,7 @@ DDL
   );
   ok ($schema->storage->connected, 'Still connected');
   {
-    local $TODO = 'SQLite is retarded wrt detecting COMMIT' if $c_commit and ! $c_begin;
+    local $TODO = $lit_txn_todo if $c_commit and ! $c_begin;
     ok ($schema->storage->_dbh->{AutoCommit}, "DBD aware txn ended with comments on $prefix_comment");
   }
 
@@ -104,7 +112,7 @@ DDL
 
   {
     # this never worked in the 1st place
-    local $TODO = 'SQLite is retarded wrt detecting COMMIT' if ! $c_begin and $c_commit;
+    local $TODO = $lit_txn_todo if ! $c_begin and $c_commit;
 
     # odd argument passing, because such nested crefs leak on 5.8
     lives_ok {