The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
Changes 013
DBIx-RetryOverDisconnects-0.07.tar.gz --
MANIFEST 10
META.yml 11
lib/DBIx/RetryOverDisconnects.pm 620
5 files changed (This is a version diff) 834
@@ -1,5 +1,18 @@
 Revision history for Perl extension DBIx::RetryOverDisconnects.
 
+0.12  08.02.2013
+        - https://rt.cpan.org/Ticket/Display.html?id=83205 (txn_do doesn't rollback after last retry)
+
+0.11  05.02.2013
+        - [rt.cpan.org #83138] take_measures - SUPER::ping throws an exception, Laurent Dami
+        - [rt.cpan.org #83139] infinite ping() loop under connect_cached, Laurent Dami
+
+0.10  05.02.2013
+        - [rt.cpan.org #83140] no localization of @_, 10x Laurent Dami
+
+0.09  31.01.2013
+        - Add more error messages support for PostgreSQL and PGBouncer
+
 0.08  20.10.2012
         - Update Module::Install version
 
diff --git a/var/tmp/source/SYBER/DBIx-RetryOverDisconnects-0.08/DBIx-RetryOverDisconnects-0.08/DBIx-RetryOverDisconnects-0.07.tar.gz b/var/tmp/source/SYBER/DBIx-RetryOverDisconnects-0.08/DBIx-RetryOverDisconnects-0.08/DBIx-RetryOverDisconnects-0.07.tar.gz
deleted file mode 100644
index b9710ea9..00000000
Binary files a/var/tmp/source/SYBER/DBIx-RetryOverDisconnects-0.08/DBIx-RetryOverDisconnects-0.08/DBIx-RetryOverDisconnects-0.07.tar.gz and /dev/null differ
@@ -1,5 +1,4 @@
 Changes
-DBIx-RetryOverDisconnects-0.07.tar.gz
 inc/Module/AutoInstall.pm
 inc/Module/Install.pm
 inc/Module/Install/AutoInstall.pm
@@ -24,4 +24,4 @@ requires:
   perl: 5.6.0
 resources:
   license: http://dev.perl.org/licenses/
-version: 0.08
+version: 0.12
@@ -3,7 +3,7 @@ use base 'DBI';
 use strict;
 use 5.006;
 
-our $VERSION = '0.08';
+our $VERSION = '0.12';
 our ($errstr, $err);
 use Exception::Class qw(DBIx::RetryOverDisconnects::Exception);
 DBIx::RetryOverDisconnects::Exception->Trace(1);
@@ -189,8 +189,11 @@ use constant PRIV => DBIx::RetryOverDisconnects::PRIV();
 sub clone {
     my $self = shift;
     local $^W = 0;
+    my $data =  $self->{PRIV()};
+    $data->{is_cloning} = 1;
     my $new_self = $self->SUPER::clone(@_) or return;
-    $new_self->{PRIV()} = { %{ $self->{PRIV()} } };
+    delete $data->{is_cloning};
+    $new_self->{PRIV()} = {%$data};
     return $new_self;
 }
 
@@ -305,6 +308,7 @@ foreach my $func (qw/
         while(1) {
 
             $data->{Intercept} = 1;
+            local $@;
             my $ok = eval {
                 defined $wa ? $wa ? (@retval = $self->$super_method(@_)) :
                                     ($retval = $self->$super_method(@_)) :
@@ -333,6 +337,7 @@ ping and if it is false then it reconnects.
 sub ping {
     my $self = shift;
     return 1 if $self->SUPER::ping;
+    return if $self->{PRIV()}{is_cloning};
     my $in_trans = !$self->{AutoCommit};
     $self->reconnect;
     $self->exc_conn_trans->throw if $in_trans;
@@ -342,7 +347,8 @@ sub ping {
 sub take_measures {
     my ($self, $e, $sth, $autocommit) = @_;
     $self->exc_flush;
-    $self->SUPER::ping and $self->exc_std($e)->rethrow;
+    local $@;
+    $self->exc_std($e)->rethrow if eval { $self->SUPER::ping };
 
     my $is_disconnect_method = 'is_disconnect_'.lc($self->{Driver}->{Name});
     if ($self->$is_disconnect_method($e)) {
@@ -367,7 +373,11 @@ sub is_disconnect_pg {
     my $self = shift;
     local $_ = shift;
     return 1 if /server\s+closed\s+the\s+connection\s+unexpectedly/i or
-                /terminating connection/;
+                /terminating connection/ or
+                /no\s+more\s+connections\s+allowed/ or # pgbouncer
+                /no\s+working\s+server\s+connection/ or # pgbouncer 1.4.2
+                /_timeout/ or # pgbouncer
+                /pgbouncer\s+cannot\s+connect\s+to\s+server/; # pgbouncer 1.5+
     return;
 }
 *is_disconnect_pgpp = *is_disconnect_pg;
@@ -403,6 +413,7 @@ sub reconnect {
             alarm(0);
             die($alarm = 1);
         };
+        local $@;
         eval {
             alarm($data->{timeout});
             eval {
@@ -469,8 +480,10 @@ sub txn_do {
     return $coderef->(@_) unless $self->{AutoCommit};
 
     my $wa = wantarray;
-    my (@result, $result, $i);
+    my (@result, $result);
+    my $i = 0;
     while ('preved') {
+        local $@;
         my $ok = eval {
             $self->begin_work;
             defined $wa ? $wa ? (@result = $coderef->(@_)) :
@@ -481,7 +494,7 @@ sub txn_do {
         };
         last if $ok;
 
-        $self->exc_conn_trans_fatal->throw if $self->{PRIV()}{txn_retries} <= ++$i;
+        $self->exc_conn_trans_fatal->throw if $self->{PRIV()}{txn_retries} <= $i++;
         next if $self->is_trans_disconnect;
         $@->rethrow if $self->is_fatal_disconnect;
         my $txn_err = $@;
@@ -516,6 +529,7 @@ foreach my $func (qw/execute execute_array execute_for_fetch/) {
         while(1) {
 
             $data->{Intercept} = 1;
+            local $@;
             my $ok = eval {
                 defined $wa ? $wa ? (@retval = $self->$super_method(@_)) :
                                     ($retval = $self->$super_method(@_)) :