From: Peter Rabbitson <ribasushi@cpan.org>
Date: Thu, 7 Jan 2016 17:26:02 +0000 (+0100)
Subject: The complete fix for intermittent t/750firebird.t failures (RT#110979)
X-Git-Tag: v0.082840~28
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=5e65042b;p=dbsrgits%2FDBIx-Class.git

The complete fix for intermittent t/750firebird.t failures (RT#110979)

( amalgam cherry-pick of 63af9ced2 and 2c649fafe )

It makes no sense to throw values away in case the finish() failed - they are
good regardless. Not sure what I was thinking at the time :(
---

diff --git a/Changes b/Changes
index 7cc0b6a..6be7110 100644
--- a/Changes
+++ b/Changes
@@ -1,5 +1,9 @@
 Revision history for DBIx::Class
 
+    * Fixes
+        - Work around unreliable $sth->finish() on INSERT ... RETURNING within
+          DBD::Firebird on some compiler/driver combinations (RT#110979)
+
 0.082821 2016-02-11 17:58 (UTC)
     * Fixes
         - Fix t/52leaks.t failures on compilerless systems (RT#104429)
diff --git a/lib/DBIx/Class/Storage/DBI.pm b/lib/DBIx/Class/Storage/DBI.pm
index 51c72e9..0af543a 100644
--- a/lib/DBIx/Class/Storage/DBI.pm
+++ b/lib/DBIx/Class/Storage/DBI.pm
@@ -1975,12 +1975,30 @@ sub insert {
 
   my %returned_cols = %$to_insert;
   if (my $retlist = $sqla_opts->{returning}) {  # if IR is supported - we will get everything in one set
-    @ir_container = try {
-      local $SIG{__WARN__} = sub {};
-      my @r = $sth->fetchrow_array;
-      $sth->finish;
-      @r;
-    } unless @ir_container;
+
+    unless( @ir_container ) {
+      try {
+
+        # FIXME - need to investigate why Caelum silenced this in 4d4dc518
+        local $SIG{__WARN__} = sub {};
+
+        @ir_container = $sth->fetchrow_array;
+        $sth->finish;
+
+      } catch {
+        # Evict the $sth from the cache in case we got here, since the finish()
+        # is crucial, at least on older Firebirds, possibly on other engines too
+        #
+        # It would be too complex to make this a proper subclass override,
+        # and besides we already take the try{} penalty, adding a catch that
+        # triggers infrequently is a no-brainer
+        #
+        if( my $kids = $self->_dbh->{CachedKids} ) {
+          $kids->{$_} == $sth and delete $kids->{$_}
+            for keys %$kids
+        }
+      };
+    }
 
     @returned_cols{@$retlist} = @ir_container if @ir_container;
   }
diff --git a/t/750firebird.t b/t/750firebird.t
index 1d06387..1066132 100644
--- a/t/750firebird.t
+++ b/t/750firebird.t
@@ -5,6 +5,7 @@ use Test::More;
 use Test::Exception;
 use DBIx::Class::Optional::Dependencies ();
 use Scope::Guard ();
+use List::Util 'shuffle';
 use Try::Tiny;
 use lib qw(t/lib);
 use DBICTest;
@@ -36,26 +37,15 @@ plan skip_all => join (' ',
 
 my $schema;
 
-my @test_order = map { "DBICTEST_FIREBIRD$_" }
-  DBICTest::RunMode->is_plain
-    ? ('', '_INTERBASE', '_ODBC')   # Least likely to fail
-    : ('_ODBC', '_INTERBASE' , ''); # Most likely to fail
+for my $prefix (shuffle keys %$env2optdep) { SKIP: {
 
-for my $prefix (@test_order) { SKIP: {
+  skip ("Testing with ${prefix}_DSN needs " . DBIx::Class::Optional::Dependencies->req_missing_for( $env2optdep->{$prefix} ), 1)
+    unless  DBIx::Class::Optional::Dependencies->req_ok_for($env2optdep->{$prefix});
 
   my ($dsn, $user, $pass) = map { $ENV{"${prefix}_$_"} } qw/DSN USER PASS/;
 
-  next unless $dsn;
-
   note "Testing with ${prefix}_DSN";
 
-  skip ("Testing with ${prefix}_DSN needs " . DBIx::Class::Optional::Dependencies->req_missing_for( $env2optdep->{$prefix} ), 1)
-    unless  DBIx::Class::Optional::Dependencies->req_ok_for($env2optdep->{$prefix});
-
-  skip ("DBD::InterBase crashes if Firebird or ODBC are also loaded", 1)
-    if $prefix eq 'DBICTEST_FIREBIRD_INTERBASE' and
-      ($ENV{DBICTEST_FIREBIRD_DSN} or $ENV{DBICTEST_FIREBIRD_ODBC_DSN});
-
   $schema = DBICTest::Schema->connect($dsn, $user, $pass, {
     auto_savepoint  => 1,
     quote_names     => 1,