From: Peter Rabbitson <ribasushi@cpan.org>
Date: Tue, 15 Jul 2014 01:48:40 +0000 (+0200)
Subject: Add one extra is_exception check (missed a spot during 841efcb3f)
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=9bea2000ccd0828327e98c3e17c0be3e7df5c593;p=dbsrgits%2FDBIx-Class-Historic.git

Add one extra is_exception check (missed a spot during 841efcb3f)

In addition tweak the message so that carp_unique can in fact catch it
properly, and test that the proper amount of warnings is in fact emitted
---

diff --git a/Changes b/Changes
index 0b56392..6cd1d01 100644
--- a/Changes
+++ b/Changes
@@ -34,6 +34,8 @@ Revision history for DBIx::Class
           without bombing out (RT#93244)
         - Fix set_inflated_column incorrectly handling \[] literals (GH#44)
         - Ensure that setting a column to a literal invariably marks it dirty
+        - Work around exception objects with broken string overloading in one
+          additional codepath (missed in 0.08260)
         - Fix inability to handle multiple consecutive transactions with
           savepoints on DBD::SQLite < 1.39
 
diff --git a/lib/DBIx/Class/Storage/BlockRunner.pm b/lib/DBIx/Class/Storage/BlockRunner.pm
index 8dae0c9..70ded7e 100644
--- a/lib/DBIx/Class/Storage/BlockRunner.pm
+++ b/lib/DBIx/Class/Storage/BlockRunner.pm
@@ -144,7 +144,7 @@ sub _run {
     my $storage = $self->storage;
     my $cur_depth = $storage->transaction_depth;
 
-    if (defined $txn_init_depth and $run_err eq '') {
+    if (defined $txn_init_depth and ! is_exception $run_err) {
       my $delta_txn = (1 + $txn_init_depth) - $cur_depth;
 
       if ($delta_txn) {
diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm
index 612efa7..a7c1b50 100644
--- a/lib/DBIx/Class/_Util.pm
+++ b/lib/DBIx/Class/_Util.pm
@@ -118,8 +118,8 @@ sub is_exception ($) {
   if (defined $suberror) {
     if (length (my $class = blessed($e) )) {
       carp_unique( sprintf(
-        'External exception object %s implements partial (broken) '
-      . 'overloading preventing it from being used in simple ($x eq $y) '
+        'External exception class %s implements partial (broken) overloading '
+      . 'preventing its instances from being used in simple ($x eq $y) '
       . 'comparisons. Given Perl\'s "globally cooperative" exception '
       . 'handling this type of brokenness is extremely dangerous on '
       . 'exception objects, as it may (and often does) result in silent '
@@ -130,7 +130,7 @@ sub is_exception ($) {
       . 'to the one shown at %s, in order to ensure your exception handling '
       . 'is saner application-wide. What follows is the actual error text '
       . "as generated by Perl itself:\n\n%s\n ",
-        refdesc $e,
+        $class,
         $class,
         'http://v.gd/DBIC_overload_tempfix/',
         $suberror,
diff --git a/t/storage/txn.t b/t/storage/txn.t
index efe3641..06af849 100644
--- a/t/storage/txn.t
+++ b/t/storage/txn.t
@@ -407,4 +407,41 @@ warnings_are {
 
 } [], 'No warnings on AutoCommit => 0 with txn_do';
 
+
+# make sure we are not fucking up the stacktrace on broken overloads
+{
+  package DBICTest::BrokenOverload;
+
+  use overload '""' => sub { $_[0] };
+}
+
+{
+  my @w;
+  local $SIG{__WARN__} = sub {
+    $_[0] =~ /\QExternal exception class DBICTest::BrokenOverload implements partial (broken) overloading preventing its instances from being used in simple (\E\$x eq \$y\Q) comparisons/
+      ? push @w, @_
+      : warn @_
+  };
+
+  my $s = DBICTest->init_schema(no_deploy => 1);
+  $s->stacktrace(0);
+  my $g = $s->storage->txn_scope_guard;
+  my $broken_exception = bless {}, 'DBICTest::BrokenOverload';
+
+  # FIXME - investigate what confuses the regex engine below
+
+  # do not reformat - line-num part of the test
+  my $ln = __LINE__ + 6;
+  throws_ok {
+    $s->txn_do( sub {
+      $s->txn_do( sub {
+        $s->storage->_dbh->disconnect;
+        die $broken_exception
+      });
+    })
+  } qr/\QTransaction aborted: $broken_exception. Rollback failed: lost connection to storage at @{[__FILE__]} line $ln\E\n/;  # FIXME wtf - ...\E$/m doesn't work here
+
+  is @w, 1, 'One matching warning only';
+}
+
 done_testing;
diff --git a/t/storage/txn_scope_guard.t b/t/storage/txn_scope_guard.t
index 4a2c14b..2f6a00d 100644
--- a/t/storage/txn_scope_guard.t
+++ b/t/storage/txn_scope_guard.t
@@ -199,7 +199,7 @@ for my $post_poison (0,1) {
 
   my @w;
   local $SIG{__WARN__} = sub {
-    $_[0] =~ /External exception object .+? \Qimplements partial (broken) overloading/
+    $_[0] =~ /External exception class .+? \Qimplements partial (broken) overloading/
       ? push @w, @_
       : warn @_
   };