From: Konstantin A. Pustovalov <konstantin.pustovalov@gmail.com>
Date: Mon, 21 Jan 2013 20:40:58 +0000 (+0400)
Subject: Ensure the stack properly deals and warns on Null-Pattern exception objects
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=84e4e006;p=dbsrgits%2FDBIx-Class-Historic.git

Ensure the stack properly deals and warns on Null-Pattern exception objects

Reuse the existing is_exception() utility to catch any and all instances of
objects stringifying to "" before passing them onwards
---

diff --git a/Changes b/Changes
index e4b1733..c1e5aa1 100644
--- a/Changes
+++ b/Changes
@@ -17,6 +17,8 @@ Revision history for DBIx::Class
     * Fixes
         - Ensure failing on_connect* / on_disconnect* are dealt with properly,
           notably on_connect* failures now properly abort the entire connect
+        - Make sure exception objects stringifying to '' are properly handled
+          and warned about (GH#15)
         - Fix corner case of stringify-only overloaded objects being used in
           create()/populate()
         - Fix several corner cases with Many2Many over custom relationships
diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm
index 8d25ec0..2d2de30 100644
--- a/lib/DBIx/Class/_Util.pm
+++ b/lib/DBIx/Class/_Util.pm
@@ -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;
 }
diff --git a/t/33exception_wrap.t b/t/33exception_wrap.t
index fdee230..40a7ea0 100644
--- a/t/33exception_wrap.t
+++ b/t/33exception_wrap.t
@@ -3,6 +3,7 @@ use warnings;
 
 use Test::More;
 use Test::Exception;
+use Test::Warn;
 
 use lib qw(t/lib);
 
@@ -23,4 +24,20 @@ is_deeply (
   'Exception-arrayref contents preserved',
 );
 
+for my $ap (qw(
+  DBICTest::AntiPattern::TrueZeroLen
+  DBICTest::AntiPattern::NullObject
+)) {
+  eval "require $ap";
+
+  warnings_like {
+    eval {
+      $schema->txn_do (sub { die $ap->new });
+    };
+
+    isa_ok $@, $ap;
+  } qr/\QObjects of external exception class '$ap' stringify to '' (the empty string)/,
+    'Proper warning on encountered antipattern';
+}
+
 done_testing;
diff --git a/t/34exception_action.t b/t/34exception_action.t
index b81e568..b35c7dc 100644
--- a/t/34exception_action.t
+++ b/t/34exception_action.t
@@ -90,4 +90,30 @@ throws_ok \&$throw,
 throws_ok { $schema->storage->throw_exception('floob') }
   qr/DBICTest::Exception is handling this: floob/;
 
+# test antipatterns
+for my $ap (qw(
+  DBICTest::AntiPattern::TrueZeroLen
+  DBICTest::AntiPattern::NullObject
+)) {
+  eval "require $ap";
+  my $exp_warn = qr/\QObjects of external exception class '$ap' stringify to '' (the empty string)/;
+
+  # make sure an exception_action can replace $@ with an antipattern
+  $schema->exception_action(sub { die $ap->new });
+  warnings_like {
+    eval { $throw->() };
+    isa_ok $@, $ap;
+  } $exp_warn, 'proper warning on antipattern encountered within exception_action';
+
+  # and make sure that the retrhow works
+  $schema->exception_action(sub { die @_ });
+  warnings_like {
+    eval {
+      $schema->txn_do (sub { die $ap->new });
+    };
+
+    isa_ok $@, $ap;
+  } $exp_warn, 'Proper warning on encountered antipattern';
+}
+
 done_testing;
diff --git a/t/lib/DBICTest/AntiPattern/NullObject.pm b/t/lib/DBICTest/AntiPattern/NullObject.pm
new file mode 100644
index 0000000..dc99c96
--- /dev/null
+++ b/t/lib/DBICTest/AntiPattern/NullObject.pm
@@ -0,0 +1,16 @@
+package DBICTest::AntiPattern::NullObject;
+
+use warnings;
+use strict;
+
+use overload
+  'bool'   => sub { 0 },
+  '""'     => sub { '' },
+  '0+'     => sub { 0 },
+  fallback => 1
+;
+
+our $null = bless {}, __PACKAGE__;
+sub AUTOLOAD { $null }
+
+1;
diff --git a/t/lib/DBICTest/AntiPattern/TrueZeroLen.pm b/t/lib/DBICTest/AntiPattern/TrueZeroLen.pm
new file mode 100644
index 0000000..aa7190a
--- /dev/null
+++ b/t/lib/DBICTest/AntiPattern/TrueZeroLen.pm
@@ -0,0 +1,14 @@
+package DBICTest::AntiPattern::TrueZeroLen;
+
+use warnings;
+use strict;
+
+use overload
+  'bool'   => sub { 1 },
+  '""'     => sub { '' },
+  fallback => 1
+;
+
+sub new { bless {}, shift }
+
+1;