Improve error reporting when we encounter broken exception objects

Undo parts of 935ea66 (which inadevrtently broke 153a6b3), while
keeping the entire shebang running after issuing a stern warning.

Changes

@@ -18,6 +18,8 @@ Revision history for DBIx::Class
           order_by specification and distinct and/or complex prefetch
         - Fix unbound growth of a resultset during repeated execute/exhaust
           cycles (GHPR#29)
+        - Work around (and be very vocal about the fact) when DBIC encounters
+          an exception object with broken string overloading
         - Clarify ambiguous behavior of distinct when used with ResultSetColumn
           i.e. $rs->search({}, { distinct => 1 })->get_column (...)
         - Setting quote_names propagates to SQL::Translator when producing

lib/DBIx/Class/Storage/BlockRunner.pm

@@ -5,6 +5,7 @@ use Sub::Quote 'quote_sub';
 use DBIx::Class::Exception;
 use DBIx::Class::Carp;
 use Context::Preserve 'preserve_context';
+use DBIx::Class::_Util 'is_exception';
 use Scalar::Util qw(weaken blessed reftype);
 use Try::Tiny;
 use Moo;
@@ -154,7 +155,7 @@ sub _run {
     }
 
     # something above threw an error (could be the begin, the code or the commit)
-    if ($run_err ne '') {
+    if ( is_exception $run_err ) {
 
       # attempt a rollback if we did begin in the first place
       if ($txn_begin_ok) {

lib/DBIx/Class/Storage/TxnScopeGuard.pm

@@ -5,6 +5,7 @@ use warnings;
 use Try::Tiny;
 use Scalar::Util qw/weaken blessed refaddr/;
 use DBIx::Class;
+use DBIx::Class::_Util 'is_exception';
 use DBIx::Class::Carp;
 use namespace::clean;
 
@@ -23,9 +24,9 @@ sub new {
   # FIXME FRAGILE - any eval that fails but *does not* rethrow between here
   # and the unwind will trample over $@ and invalidate the entire mechanism
   # There got to be a saner way of doing this...
-  if (defined $@ and "$@" ne '') {
+  if (is_exception $@) {
     weaken(
-      $guard->{existing_exception_ref} = (ref $@ eq '') ? \$@ : $@
+      $guard->{existing_exception_ref} = (ref($@) eq '') ? \$@ : $@
     );
   }
 
@@ -58,14 +59,12 @@ sub DESTROY {
   return unless $self->{dbh};
 
   my $exception = $@ if (
-    defined $@
-      and
-    "$@" ne ''
+    is_exception $@
       and
     (
       ! defined $self->{existing_exception_ref}
         or
-      refaddr( ref $@ eq '' ? \$@ : $@ ) != refaddr($self->{existing_exception_ref})
+      refaddr( ref($@) eq '' ? \$@ : $@ ) != refaddr($self->{existing_exception_ref})
     )
   );
 

lib/DBIx/Class/_Util.pm

@@ -49,11 +49,15 @@ BEGIN {
   }
 }
 
-use Carp;
-use Scalar::Util qw(refaddr weaken);
+# FIXME - this is not supposed to be here
+# Carp::Skip to the rescue soon
+use DBIx::Class::Carp '^DBIx::Class|^DBICTest';
+
+use Carp 'croak';
+use Scalar::Util qw(refaddr weaken blessed reftype);
 
 use base 'Exporter';
-our @EXPORT_OK = qw(sigwarn_silencer modver_gt_or_eq fail_on_internal_wantarray refcount);
+our @EXPORT_OK = qw(sigwarn_silencer modver_gt_or_eq fail_on_internal_wantarray refcount is_exception);
 
 sub sigwarn_silencer {
   my $pattern = shift;
@@ -74,6 +78,54 @@ sub refcount {
   B::svref_2object($_[0])->REFCNT;
 }
 
+sub is_exception ($) {
+  my $e = $_[0];
+
+  my ($not_blank, $suberror);
+  {
+    local $@;
+    eval {
+      $not_blank = ($e ne '') ? 1 : 0;
+      1;
+    } or $suberror = $@;
+  }
+
+  if (defined $suberror) {
+    if (length (my $class = blessed($e) )) {
+      carp_unique( sprintf(
+        'External exception object %s=%s(0x%x) implements partial (broken) '
+      . 'overloading preventing it 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 '
+      . '"exception substitution". DBIx::Class tries to work around this '
+      . 'as much as possible, but other parts of your software stack may '
+      . 'not be even aware of this. Please submit a bugreport against the '
+      . 'distribution containing %s and in the meantime apply a fix similar '
+      . '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 ",
+        $class,
+        reftype $e,
+        refaddr $e,
+        $class,
+        'http://v.gd/DBIC_overload_tempfix/',
+        $suberror,
+      ));
+
+      # workaround, keeps spice flowing
+      $not_blank = ("$e" ne '') ? 1 : 0;
+    }
+    else {
+      # not blessed yet failed the 'ne'... this makes 0 sense...
+      # just throw further
+      die $suberror
+    }
+  }
+
+  return $not_blank;
+}
+
 sub modver_gt_or_eq {
   my ($mod, $ver) = @_;
 

t/storage/txn_scope_guard.t

@@ -197,51 +197,24 @@ for my $post_poison (0,1) {
 
   require Text::Balanced;
 
-  my $great_success;
-  {
-    local $TODO = 'RT#74994 *STILL* not fixed';
-
-    lives_ok {
-      # this is what poisons $@
-      Text::Balanced::extract_bracketed( '(foo', '()' );
-
-      my $s = DBICTest->init_schema( deploy => 0 );
-      my $g = $s->txn_scope_guard;
-      $g->commit;
-      $great_success++;
-    } 'Text::Balanced is no longer screwing up $@';
-  }
-
-  # delete all of this when T::B dep is bumped
-  unless ($great_success) {
-
-# hacky workaround for desperate folk
-# intended to be copypasted into your app
-    {
-      require Text::Balanced;
-      require overload;
-
-      local $@;
-
-      # this is what poisons $@
-      Text::Balanced::extract_bracketed( '(foo', '()' );
+  my @w;
+  local $SIG{__WARN__} = sub {
+    $_[0] =~ /External exception object .+? \Qimplements partial (broken) overloading/
+      ? push @w, @_
+      : warn @_
+  };
 
-      if ($@ and overload::Overloaded($@) and ! overload::Method($@,'fallback') ) {
-        my $class = ref $@;
-        eval "package $class; overload->import(fallback => 1);"
-      }
-    }
-# end of hacky workaround
+  lives_ok {
+    # this is what poisons $@
+    Text::Balanced::extract_bracketed( '(foo', '()' );
 
-    lives_ok {
-      # this is what poisons $@
-      Text::Balanced::extract_bracketed( '(foo', '()' );
+    my $s = DBICTest::Schema->connect('dbi:SQLite::memory:');
+    my $g = $s->txn_scope_guard;
+    $g->commit;
+  } 'Broken Text::Balanced is not screwing up txn_guard';
 
-      my $s = DBICTest->init_schema( deploy => 0 );
-      my $g = $s->txn_scope_guard;
-      $g->commit;
-    } 'Monkeypatched Text::Balanced is no longer screwing up $@';
-  }
+  local $TODO = 'RT#74994 *STILL* not fixed';
+  is(scalar @w, 0, 'no warnings \o/');
 }
 
 done_testing;

xt/standalone_testschema_resultclasses.t

@@ -14,7 +14,7 @@ use lib 't/lib';
 my $worker = sub {
   my $fn = shift;
 
-  if (my @offenders = grep { $_ ne 'DBIx/Class/_Util.pm' } grep { $_ =~ /(^|\/)DBI/ } keys %INC) {
+  if (my @offenders = grep { $_ !~ m{DBIx/Class/(?:_Util|Carp)\.pm} } grep { $_ =~ /(^|\/)DBI/ } keys %INC) {
     die "Wtf - DBI* modules present in %INC: @offenders";
   }