[svn:dbi] r9947 - in dbi/trunk: lib/DBI/Gofer lib/DBI/Gofer/Transport t

[timbo]

Author: timbo
Date: Sun Sep 16 10:26:45 2007
New Revision: 9947

Modified:
   dbi/trunk/lib/DBI/Gofer/Execute.pm
   dbi/trunk/lib/DBI/Gofer/Transport/Base.pm
   dbi/trunk/t/05thrclone.t

Log:
Fix t/05thrclone.t to work with Test::More >= 0.71 thanks to Jerry D. Hedden 
and Michael G Schwern.
Minor tweaks to Gofer.


Modified: dbi/trunk/lib/DBI/Gofer/Execute.pm
==============================================================================
--- dbi/trunk/lib/DBI/Gofer/Execute.pm  (original)
+++ dbi/trunk/lib/DBI/Gofer/Execute.pm  Sun Sep 16 10:26:45 2007
@@ -289,8 +289,9 @@
     $response ||= $self->new_response_with_err(undef, $@, $current_dbh);
 
     if (my $check_response_sub = $self->check_response_sub) {
-        eval { $check_response_sub->($response, $self, $request) };
-        warn "check_response_sub failed: $@" if $@;
+        # not protected with an eval so it can choose to throw an exception
+        my $new = $check_response_sub->($response, $self, $request);
+        $response = $new if ref $new;
     }
 
     undef $current_dbh;
@@ -698,7 +699,7 @@
 
 If defined, it must be a reference to a subroutine that will 'check' the 
response.
 It is passed the response object, the executor, and the request object.
-The return value is ignored, though the sub may alter the response object.
+The sub may alter the response object and return undef, or return a new 
response object.
 
 This mechanism can be used to, for example, terminate the service if specific
 database errors are seen.

Modified: dbi/trunk/lib/DBI/Gofer/Transport/Base.pm
==============================================================================
--- dbi/trunk/lib/DBI/Gofer/Transport/Base.pm   (original)
+++ dbi/trunk/lib/DBI/Gofer/Transport/Base.pm   Sun Sep 16 10:26:45 2007
@@ -10,6 +10,8 @@
 use strict;
 use warnings;
 
+use DBI;
+
 use base qw(DBI::Util::_accessor);
 
 our $VERSION = sprintf("0.%06d", q$Revision$ =~ /(\d+)/o);

Modified: dbi/trunk/t/05thrclone.t
==============================================================================
--- dbi/trunk/t/05thrclone.t    (original)
+++ dbi/trunk/t/05thrclone.t    Sun Sep 16 10:26:45 2007
@@ -18,24 +18,14 @@
 }
 
 my $threads = 10;
-
-plan tests => 3 + 4 * $threads;
-
-# Something about DBD::Gofer causes a problem. Older versions didn't leak. It
-# started at some point in development but I didn't track it down at the time
-# so the exact change that made it start is now lost in the mists of time.
-# XXX doesn't seem to be happening any more
-warn " You can ignore the $threads 'Scalars leaked' messages you may see here 
(or send me a patch to fix the underlying problem)\n"
-    if 0 && $ENV{DBI_AUTOPROXY} && not $ENV{DBI_PUREPERL};
+plan tests => 4 + 4 * $threads;
 
 {
     package threads_sub;
     use base qw(threads);
 }
 
-BEGIN {
-       use_ok('DBI');
-}
+use_ok('DBI');
 
 $DBI::neat_maxlen = 12345;
 cmp_ok($DBI::neat_maxlen, '==', 12345, '... assignment of neat_maxlen was 
successful');