Normalize _parse_rs_attrs - no functional changes

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

diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm
index bf8b830..2d2de30 100644 (file)
--- a/lib/DBIx/Class/_Util.pm
+++ b/lib/DBIx/Class/_Util.pm
@@ -71,7 +71,7 @@ use base 'Exporter';
 our @EXPORT_OK = qw(
   sigwarn_silencer modver_gt_or_eq modver_gt_or_eq_and_lt
   fail_on_internal_wantarray fail_on_internal_call
-  refdesc refcount hrefaddr is_exception detect_reinvoked_destructor
+  refdesc refcount hrefaddr is_exception detected_reinvoked_destructor
   quote_sub qsub perlstring serialize deep_clone
   UNRESOLVABLE_CONDITION
 );
@@ -165,6 +165,27 @@ sub is_exception ($) {
       die $suberror
     }
   }
+  elsif (
+    # a ref evaluating to '' is definitively a "null object"
+    ( not $not_blank )
+      and
+    length( my $class = ref $e )
+  ) {
+    carp_unique( sprintf(
+      "Objects of external exception class '%s' stringify to '' (the "
+    . 'empty string), implementing the so called null-object-pattern. '
+    . 'Given Perl\'s "globally cooperative" exception handling using this '
+    . 'class of exceptions is extremely dangerous, as it may (and often '
+    . 'does) result in silent discarding of errors. DBIx::Class tries to '
+    . 'work around this as much as possible, but other parts of your '
+    . 'software stack may not be even aware of the problem. Please submit '
+    . 'a bugreport against the distribution containing %s.',
+
+      ($class) x 2,
+    ));
+
+    $not_blank = 1;
+  }
 
   return $not_blank;
 }
@@ -181,22 +202,21 @@ sub is_exception ($) {
 
   # This is almost invariably invoked from within DESTROY
   # throwing exceptions won't work
-  sub detect_reinvoked_destructor {
+  sub detected_reinvoked_destructor {
 
     # quick "garbage collection" pass - prevents the registry
     # from slowly growing with a bunch of undef-valued keys
     defined $destruction_registry->{$_} or delete $destruction_registry->{$_}
       for keys %$destruction_registry;
 
-    unless (length ref $_[0]) {
-      printf STDERR '%s() expects a reference %s',
+    if (! length ref $_[0]) {
+      printf STDERR '%s() expects a blessed reference %s',
         (caller(0))[3],
         Carp::longmess,
       ;
       return undef; # don't know wtf to do
     }
-
-    if (! defined $destruction_registry->{ my $addr = refaddr($_[0]) } ) {
+    elsif (! defined $destruction_registry->{ my $addr = refaddr($_[0]) } ) {
       weaken( $destruction_registry->{$addr} = $_[0] );
       return 0;
     }