[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