From: Peter Rabbitson <ribasushi@cpan.org>
Date: Mon, 12 Jul 2010 02:55:25 +0000 (+0200)
Subject: Rewrite the DBI connector to use Try::Tiny, avoid a leak by evoking a callback codere... 
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=b720efd16eb1e747c3d12697f57edb708f67280a;p=dbsrgits%2FDBIx-Class-Historic.git

Rewrite the DBI connector to use Try::Tiny, avoid a leak by evoking a callback coderef installer coderef :D
---

diff --git a/lib/DBIx/Class/Storage/DBI.pm b/lib/DBIx/Class/Storage/DBI.pm
index 8aacfa1..9e4256c 100644
--- a/lib/DBIx/Class/Storage/DBI.pm
+++ b/lib/DBIx/Class/Storage/DBI.pm
@@ -1166,9 +1166,7 @@ sub _connect {
     $DBI::connect_via = 'connect';
   }
 
-  # FIXME - this should have been Try::Tiny, but triggers a leak-bug in perl(!)
-  # related to coderef refcounting. A failing test has been submitted to T::T
-  my $connect_ok = eval {
+  try {
     if(ref $info[0] eq 'CODE') {
        $dbh = $info[0]->();
     }
@@ -1181,32 +1179,37 @@ sub _connect {
     }
 
     unless ($self->unsafe) {
-      my $weak_self = $self;
-      weaken $weak_self;
-      $dbh->{HandleError} = sub {
+
+      # this odd anonymous coderef dereference is in fact really
+      # necessary to avoid the unwanted effect described in perl5
+      # RT#75792
+      sub {
+        my $weak_self = $_[0];
+        weaken $weak_self;
+
+        $_[1]->{HandleError} = sub {
           if ($weak_self) {
             $weak_self->throw_exception("DBI Exception: $_[0]");
           }
           else {
             # the handler may be invoked by something totally out of
             # the scope of DBIC
-            croak ("DBI Exception: $_[0]");
+            croak ("DBI Exception (unhandled by DBIC, ::Schema GCed): $_[0]");
           }
-      };
+        };
+      }->($self, $dbh);
+
       $dbh->{ShowErrorStatement} = 1;
       $dbh->{RaiseError} = 1;
       $dbh->{PrintError} = 0;
     }
-
-    1;
-  };
-
-  my $possible_err = $@;
-  $DBI::connect_via = $old_connect_via if $old_connect_via;
-
-  unless ($connect_ok) {
-    $self->throw_exception("DBI Connection failed: $possible_err")
   }
+  catch {
+    $self->throw_exception("DBI Connection failed: $_")
+  }
+  finally {
+    $DBI::connect_via = $old_connect_via if $old_connect_via;
+  };
 
   $self->_dbh_autocommit($dbh->{AutoCommit});
   $dbh;
diff --git a/t/storage/error.t b/t/storage/error.t
index e57d892..d3b28aa 100644
--- a/t/storage/error.t
+++ b/t/storage/error.t
@@ -11,10 +11,44 @@ use_ok( 'DBICTest::Schema' );
 
 my $schema = DBICTest->init_schema;
 
+my $e_start = quotemeta('DBIx::Class::');
+
 warnings_are ( sub {
-  throws_ok (sub {
-    $schema->resultset('CD')->create({ title => 'vacation in antarctica' });
-  }, qr/NULL/);  # as opposed to some other error
+  throws_ok (
+    sub {
+      $schema->resultset('CD')->create({ title => 'vacation in antarctica' })
+    },
+    qr/$e_start.+constraint failed.+NULL/s
+  );  # as opposed to some other error
 }, [], 'No warnings besides exception' );
 
+my $dbh = $schema->storage->dbh;
+
+throws_ok (
+  sub {
+    $dbh->do ('INSERT INTO nonexistent_table VALUES (1)')
+  },
+  qr/$e_start.+DBI Exception.+no such table/,
+  'DBI exceptions properly handled by dbic-installed callback'
+);
+
+# destruction of everything except the $dbh should use the proper
+# exception fallback:
+
+# FIXME
+# These explicit disconnections on loss of $storage don't seem
+# right... disable it here for the test anyway
+{
+  local $dbh->{Callbacks}{disconnect} = sub { 1 };
+
+  undef ($schema);
+  throws_ok (
+    sub {
+      $dbh->do ('INSERT INTO nonexistent_table VALUES (1)')
+    },
+    qr/DBI Exception.+unhandled by DBIC.+no such table/,
+    'callback works after $schema is gone'
+  );
+}
+
 done_testing;