Improve error reporting when we encounter broken exception objects

[dbsrgits/DBIx-Class-Historic.git] / lib / DBIx / Class / _Util.pm

diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm
index 0afe2ea..6b8f87c 100644 (file)
--- a/lib/DBIx/Class/_Util.pm
+++ b/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) = @_;