[Bast-commits] r3301 - in trunk/DBIx-Safe: . lib lib/DBIx

syber at dev.catalyst.perl.org syber at dev.catalyst.perl.org
Fri May 11 12:28:45 GMT 2007


Author: syber
Date: 2007-05-11 12:28:38 +0100 (Fri, 11 May 2007)
New Revision: 3301

Added:
   trunk/DBIx-Safe/lib/
   trunk/DBIx-Safe/lib/DBIx/
   trunk/DBIx-Safe/lib/DBIx/Safe.pm
Log:
version alpha (0.001)

Added: trunk/DBIx-Safe/lib/DBIx/Safe.pm
===================================================================
--- trunk/DBIx-Safe/lib/DBIx/Safe.pm	                        (rev 0)
+++ trunk/DBIx-Safe/lib/DBIx/Safe.pm	2007-05-11 11:28:38 UTC (rev 3301)
@@ -0,0 +1,285 @@
+package DBIx::Safe;
+use base 'DBI';
+use strict;
+
+our $VERSION = '0.1';
+our ($errstr, $err);
+use Exception::Class;
+use constant PRIV => 'private_DBIx-Safe_data';
+
+sub connect {
+    my ($this, $dsn, $user, $pass, $attrs) = @_;
+
+    my $self_attrs = $this->get_self_attrs($attrs);
+    my $self = $this->SUPER::connect($dsn, $user, $pass, $attrs);
+    $self_attrs->{AutoCommit} = $self->{AutoCommit};
+    $self->{PRIV()} = $self_attrs;
+
+    return $self;
+}
+
+sub get_self_attrs {
+    my ($this, $attrs) = @_;
+    return {
+        retries  => (delete $attrs->{SafeRetries})  || 15,
+        interval => (delete $attrs->{SafeInterval}) ||  2,
+        timeout  => (delete $attrs->{SafeTimeout})  ||  5,
+    };
+}
+
+
+package DBIx::Safe::db;
+use base 'DBI::db';
+use strict;
+
+use constant PRIV => DBIx::Safe::PRIV();
+
+sub clone {
+    my $self = shift;
+    my $new_self = $self->SUPER::clone(@_) or return;
+    $new_self->{PRIV()} = { %{ $self->{PRIV()} } };
+    return $new_self;
+}
+
+#Extension. For example if you use HEAP tables on MYSQL and
+#administrator restarted database then all HEAP data would be lost.
+#Setting callback on afterReconnect which refills tables will get
+#you out of troubles (Possible copying DBIC's onConnectDo functionality
+#but this was written before i had seen this feature in DBIC).
+sub set_callback {
+    my ($self, %callbacks) = @_;
+    my $old = $self->{PRIV()}->{callback} || {};
+    $self->{PRIV()}->{callback} = {%$old, %callbacks};
+    return;
+}
+
+sub exc_conn_trans {
+    my $self = shift;
+    my $msg = 'Connection to database lost while in transaction';
+    $DBIx::Safe::errstr = $msg;
+    $DBIx::Safe::err    = 3;
+    $self->{RaiseError} and die $msg or
+    $self->{PrintError} and warn $msg;
+}
+
+sub exc_conn {
+    my $self = shift;
+    my $msg = 'Connection to database lost (retries exceeded)';
+    $DBIx::Safe::errstr = $msg;
+    $DBIx::Safe::err    = 2;
+    $self->{RaiseError} and die $msg or
+    $self->{PrintError} and warn $msg;
+}
+
+sub exc_flush {
+    my $self = shift;
+    $DBIx::Safe::errstr = undef;
+    $DBIx::Safe::err    = undef;
+}
+
+sub exc_std {
+    my ($self, $e) = @_;
+    $DBIx::Safe::errstr = 'standart DBI error';
+    $DBIx::Safe::err    = 1;
+    return unless $self->{RaiseError};
+    $e->rethrow;
+}
+
+foreach my $func (qw/
+    prepare do statistics_info begin_work commit rollback
+    selectrow_array selectrow_arrayref selectall_arrayref
+    selectall_hashref
+/)
+{
+    no strict 'refs';
+    *$func = sub {
+        my $self = shift;
+        my $super_method = "SUPER::$func";
+        my $data = $self->{PRIV()};
+        return $self->$super_method(@_) if $data->{Intercept}; #Already protected
+
+        my ($retval, @retval);
+        my $wa = wantarray;
+        my $autocommit = $self->{AutoCommit};
+
+        while(1) {
+
+            $data->{Intercept} = 1;
+            eval {
+                defined $wa ? $wa ? (@retval = $self->$super_method(@_)) :
+                                    ($retval = $self->$super_method(@_)) :
+                                    $self->$super_method(@_);
+            };
+            $data->{Intercept} = 0;
+
+            last unless $DBI::errstr or $@;
+
+            my $e = Exception::Class::Base->new( $DBI::errstr or $@ );
+            return unless $self->take_measures($e, undef, $autocommit);
+        }
+
+        return $wa ? @retval : $retval;
+    };
+}
+
+sub ping {
+    my $self = shift;
+    return 1 if $self->SUPER::ping;
+    my $in_trans = !$self->{AutoCommit};
+    return unless $self->reconnect;
+    $self->exc_conn_trans if $in_trans;
+    return 1;
+}
+
+sub take_measures {
+    my ($self, $e, $sth, $autocommit) = @_;
+    $self->exc_flush;
+    $self->SUPER::ping and return $self->exc_std($e);
+
+    my $is_disconnect_method = 'is_disconnect_'.lc($self->{Driver}->{Name});
+    if ($self->$is_disconnect_method($e)) {
+        warn "Disconnected!\n" if $self->{PrintError};
+        return unless $self->reconnect($sth);
+        $self->exc_conn_trans, return unless $autocommit;
+        return 1;
+    }
+
+    $self->exc_std($e);
+    return;
+}
+
+sub is_disconnect_mysql {
+    my $self = shift;
+    $_ = shift;
+    return 1 if /lost\s+connection/i or /can't\s+connect/i or
+                /server\s+shutdown/i or /MySQL\s+server\s+has\s+gone\s+away/i;
+    return;
+}
+
+sub is_disconnect_pg {
+    my $self = shift;
+    $_ = shift;
+    return 1 if /server\s+closed\s+the\s+connection\s+unexpectedly/i or
+                /terminating connection/;
+    return;
+}
+*is_disconnect_pgpp = *is_disconnect_pg;
+
+sub is_disconnect_sqlite {} #SQLite has no connection problems. Isn't that right?
+*is_disconnect_sqlite2 = *is_disconnect_sqlite;
+
+sub is_disconnect_oracle {
+    #Suggestions?
+}
+
+sub is_disconnect_sybase {
+    #Suggestions?
+}
+
+sub reconnect {
+    my ($self, $sth) = @_;
+    my $data = $self->{PRIV()};
+    my $new_dbh;
+
+    for (my $i = 1; (!$data->{retries} || $i <= $data->{retries}); $i++) {
+        warn "Reconnect try #$i\n" if $self->{PrintError};
+        my $alarm;
+        $SIG{ALRM} = sub {
+            alarm(0);
+            die($alarm = 1);
+        };
+        eval {
+            alarm($data->{timeout});
+            eval {
+                local $^W = 0;
+                $new_dbh = $self->clone;
+            };
+            alarm(0);
+        };
+        if ($new_dbh) {
+            warn "Reconnected!\n" if $self->{PrintError};
+            last;
+        }
+        sleep $data->{interval};
+    }
+
+    ($self->disconnect, $self->exc_conn, return) unless $new_dbh;
+
+    $self->swap_inner_handle($new_dbh);
+    $self->{PRIV()}    = $data;
+    $new_dbh->{PRIV()} = undef;
+    $new_dbh->STORE('Active', 0);
+
+    if ($sth) {
+        my $new_sth = $self->prepare_cached($sth->{Statement});
+        $sth->swap_inner_handle($new_sth, 1);
+        $new_sth->finish;
+    }
+    $self->STORE('CachedKids', {});
+
+    #Now autocommit is broken (has been copied from disconnected handle)
+    $self->{AutoCommit} = $data->{AutoCommit}; #Set initial value
+    $new_dbh->disconnect;
+
+    #Call callback. Currently only one supported.
+    if($self->{PRIV()}{callback} && (my $code = $self->{PRIV()}{callback}{afterReconnect})) {
+        $code->($self, $sth) if ref $code eq 'CODE';
+    }
+
+    return 1;
+}
+
+sub txn_do {
+
+}
+
+#DEPRECATED
+
+##This is a workaround. It is here because select???_* code
+##written inside C do not call perl sth's execute.
+##And therefore disconnections can not be safely handled.
+#foreach my $nm (qw/all_hashref all_arrayref row_arrayref row_array/) {
+#    no strict 'refs';
+#    my $func = "select$nm";
+#    *$func = sub { shift->DBD::_::db::$func(@_) };
+#}
+
+
+
+package DBIx::Safe::st;
+use base 'DBI::st';
+use strict;
+
+foreach my $func (qw/execute execute_array execute_for_fetch/) {
+    no strict 'refs';
+    *$func = sub {
+        my $self = shift;
+        my $super_method = "SUPER::$func";
+        my $dbh = $self->{Database};
+        my $data = $dbh->{PRIV()};
+        return $self->$super_method(@_) if $data->{Intercept}; #Already protected
+
+        my ($retval, @retval);
+        my $wa = wantarray;
+        my $autocommit = $dbh->{AutoCommit};
+
+        while(1) {
+
+            $data->{Intercept} = 1;
+            eval {
+                defined $wa ? $wa ? (@retval = $self->$super_method(@_)) :
+                                    ($retval = $self->$super_method(@_)) :
+                                    $self->$super_method(@_);
+            };
+            $data->{Intercept} = 0;
+
+            last unless $DBI::errstr or $@;
+
+            my $e = Exception::Class::Base->new( $DBI::errstr or $@ );
+            return unless $dbh->take_measures($e, $self, $autocommit);
+        }
+        return $wa ? @retval : $retval;
+    };
+}
+
+1;




More information about the Bast-commits mailing list