X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=t%2Fstorage%2Ftxn_scope_guard.t;h=6c6d1df0e02770007a374fb2f1fdd3c26b7b8cf1;hb=d85ef5e2867bc0360a72090aeaea4308792651e8;hp=2df2ab6156d470f90a692ce01cd5241dd4b6fa8b;hpb=35cf7d1af791226b0acfea95828c003e64bf4975;p=dbsrgits%2FDBIx-Class.git

diff --git a/t/storage/txn_scope_guard.t b/t/storage/txn_scope_guard.t
index 2df2ab6..6c6d1df 100644
--- a/t/storage/txn_scope_guard.t
+++ b/t/storage/txn_scope_guard.t
@@ -4,6 +4,10 @@ use warnings;
 use Test::More;
 use Test::Warn;
 use Test::Exception;
+
+use List::Util 'shuffle';
+use DBIx::Class::_Util 'sigwarn_silencer';
+
 use lib qw(t/lib);
 use DBICTest;
 
@@ -90,10 +94,8 @@ use DBICTest;
 {
   my $schema = DBICTest->init_schema;
 
-  no strict 'refs';
   no warnings 'redefine';
-
-  local *{DBIx::Class::Storage::DBI::txn_rollback} = sub { die 'die die my darling' };
+  local *DBIx::Class::Storage::DBI::txn_rollback = sub { die 'die die my darling' };
   Class::C3->reinitialize() if DBIx::Class::_ENV_::OLD_MRO;
 
   throws_ok (sub {
@@ -117,37 +119,9 @@ use DBICTest;
 
 # make sure it warns *big* on failed rollbacks
 # test with and without a poisoned $@
-for my $pre_poison (0,1) {
-for my $post_poison (0,1) {
-
-  my $schema = DBICTest->init_schema(no_populate => 1);
-
-  no strict 'refs';
-  no warnings 'redefine';
-  local *{DBIx::Class::Storage::DBI::txn_rollback} = sub { die 'die die my darling' };
-  Class::C3->reinitialize() if DBIx::Class::_ENV_::OLD_MRO;
-
-#The warn from within a DESTROY callback freaks out Test::Warn, do it old-school
-=begin
-  warnings_exist (
-    sub {
-      my $guard = $schema->txn_scope_guard;
-      $schema->resultset ('Artist')->create ({ name => 'bohhoo'});
-
-      # this should freak out the guard rollback
-      # but it won't work because DBD::SQLite is buggy
-      # instead just install a toxic rollback above
-      #$schema->storage->_dbh( $schema->storage->_dbh->clone );
-    },
-    [
-      qr/A DBIx::Class::Storage::TxnScopeGuard went out of scope without explicit commit or error. Rolling back./,
-      qr/\*+ ROLLBACK FAILED\!\!\! \*+/,
-    ],
-    'proper warnings generated on out-of-scope+rollback failure'
-  );
-=cut
-
-# delete this once the above works properly (same test)
+require DBICTest::AntiPattern::TrueZeroLen;
+require DBICTest::AntiPattern::NullObject;
+{
   my @want = (
     qr/A DBIx::Class::Storage::TxnScopeGuard went out of scope without explicit commit or error. Rolling back./,
     qr/\*+ ROLLBACK FAILED\!\!\! \*+/,
@@ -163,30 +137,70 @@ for my $post_poison (0,1) {
     }
   };
 
-  {
-    eval { die 'pre-GIFT!' if $pre_poison };
-    my $guard = $schema->txn_scope_guard;
-    eval { die 'post-GIFT!' if $post_poison };
-    $schema->resultset ('Artist')->create ({ name => 'bohhoo'});
-  }
+  no warnings 'redefine';
+  local *DBIx::Class::Storage::DBI::txn_rollback = sub { die 'die die my darling' };
+  Class::C3->reinitialize() if DBIx::Class::_ENV_::OLD_MRO;
 
-  local $TODO = 'Do not know how to deal with trapped exceptions occuring after guard instantiation...'
-    if ( $post_poison and (
-      # take no chances on installation
-      DBICTest::RunMode->is_plain
-        or
-      # this always fails
-      ! $pre_poison
-        or
-      # I do not understand why but on <= 5.8.8 and on 5.10.0 "$pre_poison && $post_poison" passes...
-      ( "$]" > 5.008008 and "$]" < 5.010000 ) or "$]" > 5.010000
-    ));
+  my @poisons = shuffle (
+    undef,
+    DBICTest::AntiPattern::TrueZeroLen->new,
+    DBICTest::AntiPattern::NullObject->new,
+    'GIFT!',
+  );
 
-  is (@w, 2, "Both expected warnings found - \$\@ pre-poison: $pre_poison, post-poison: $post_poison" );
+  for my $pre_poison (@poisons) {
+    for my $post_poison (@poisons) {
 
-  # just to mask off warning since we could not disconnect above
-  $schema->storage->_dbh->disconnect;
-}}
+      @w = ();
+
+      my $schema = DBICTest->init_schema(no_populate => 1);
+
+      # the actual scope where the guard is created/freed
+      {
+        # in this particular case these are not the warnings we are looking for
+        local $SIG{__WARN__} = sigwarn_silencer qr/implementing the so called null-object-pattern/;
+
+        # if is inside the eval, to clear $@ in the undef case
+        eval { die $pre_poison if defined $pre_poison };
+
+        my $guard = $schema->txn_scope_guard;
+
+        eval { die $post_poison if defined $post_poison };
+
+        $schema->resultset ('Artist')->create ({ name => "bohhoo, too bad we'll roll you back"});
+      }
+
+      local $TODO = 'Do not know how to deal with trapped exceptions occuring after guard instantiation...'
+        if ( defined $post_poison and (
+          # take no chances on installation
+          DBICTest::RunMode->is_plain
+            or
+          # I do not understand why but on <= 5.8.8 and on 5.10.0
+          # "$pre_poison == $post_poison == string" passes...
+          # so todoify 5.8.9 and 5.10.1+, and deal with the rest below
+          ( ( "$]" > 5.008008 and "$]" < 5.010000 ) or "$]" > 5.010000 )
+            or
+          ! defined $pre_poison
+            or
+          length ref $pre_poison
+            or
+          length ref $post_poison
+        ));
+
+      is (@w, 2, sprintf 'Both expected warnings found - $@ poisonstate:   pre-poison:%s   post-poison:%s',
+        map {
+          ! defined $_      ? 'UNDEF'
+        : ! length ref $_   ? $_
+                            : ref $_
+
+        } ($pre_poison, $post_poison)
+      );
+
+      # just to mask off warning since we could not disconnect above
+      $schema->storage->_dbh->disconnect;
+    }
+  }
+}
 
 # add a TODO to catch when Text::Balanced is finally fixed
 # https://rt.cpan.org/Public/Bug/Display.html?id=74994