::DBI:Replicated - merge connect_info from master to replicants
[dbsrgits/DBIx-Class.git] / lib / DBIx / Class / Storage / DBI / Replicated / Pool.pm
index 8f0d66d..1b50a70 100644 (file)
@@ -3,17 +3,22 @@ package DBIx::Class::Storage::DBI::Replicated::Pool;
 use Moose;
 use MooseX::AttributeHelpers;
 use DBIx::Class::Storage::DBI::Replicated::Replicant;
-use List::Util qw(sum);
+use List::Util 'sum';
+use Scalar::Util 'reftype';
+use Carp::Clan qw/^DBIx::Class/;
+use MooseX::Types::Moose qw/Num Int ClassName HashRef/;
+
+use namespace::clean -except => 'meta';
 
 =head1 NAME
 
-DBIx::Class::Storage::DBI::Replicated::Pool; Manage a pool of replicants
+DBIx::Class::Storage::DBI::Replicated::Pool - Manage a pool of replicants
 
 =head1 SYNOPSIS
 
 This class is used internally by L<DBIx::Class::Storage::DBI::Replicated>.  You
 shouldn't need to create instances of this class.
-    
+  
 =head1 DESCRIPTION
 
 In a replicated storage type, there is at least one replicant to handle the
@@ -36,11 +41,28 @@ return a number of seconds that the replicating database is lagging.
 =cut
 
 has 'maximum_lag' => (
-    is=>'ro',
-    isa=>'Num',
-    required=>1,
-    lazy=>1,
-    default=>0,
+  is=>'rw',
+  isa=>Num,
+  required=>1,
+  lazy=>1,
+  default=>0,
+);
+
+=head2 last_validated
+
+This is an integer representing a time since the last time the replicants were
+validated. It's nothing fancy, just an integer provided via the perl time 
+builtin.
+
+=cut
+
+has 'last_validated' => (
+  is=>'rw',
+  isa=>Int,
+  reader=>'last_validated',
+  writer=>'_last_validated',
+  lazy=>1,
+  default=>0,
 );
 
 =head2 replicant_type ($classname)
@@ -52,13 +74,13 @@ just leave this alone.
 =cut
 
 has 'replicant_type' => (
-    is=>'ro',
-    isa=>'ClassName',
-    required=>1,
-    default=>'DBIx::Class::Storage::DBI',
-    handles=>{
-       'create_replicant' => 'new',
-    }, 
+  is=>'ro',
+  isa=>ClassName,
+  required=>1,
+  default=>'DBIx::Class::Storage::DBI',
+  handles=>{
+    'create_replicant' => 'new',
+  },  
 );
 
 =head2 replicants
@@ -66,13 +88,13 @@ has 'replicant_type' => (
 A hashref of replicant, with the key being the dsn and the value returning the
 actual replicant storage.  For example if the $dsn element is something like:
 
-    "dbi:SQLite:dbname=dbfile"
-    
+  "dbi:SQLite:dbname=dbfile"
+  
 You could access the specific replicant via:
 
-    $schema->storage->replicants->{'dbname=dbfile'}
-    
-This attributes also supports the following helper methods
+  $schema->storage->replicants->{'dbname=dbfile'}
+  
+This attributes also supports the following helper methods:
 
 =over 4
 
@@ -101,17 +123,17 @@ removes the replicant under $key from the pool
 =cut
 
 has 'replicants' => (
-    is=>'rw',
-    metaclass => 'Collection::Hash',
-    isa=>'HashRef[DBIx::Class::Storage::DBI]',
-    default=>sub {{}},
-    provides  => {
-               'set' => 'set_replicant',
-               'get' => 'get_replicant',            
-               'empty' => 'has_replicants',
-               'count' => 'num_replicants',
-               'delete' => 'delete_replicant',
-       },
+  is=>'rw',
+  metaclass => 'Collection::Hash',
+  isa=>HashRef['DBIx::Class::Storage::DBI'],
+  default=>sub {{}},
+  provides  => {
+    'set' => 'set_replicant',
+    'get' => 'get_replicant',            
+    'empty' => 'has_replicants',
+    'count' => 'num_replicants',
+    'delete' => 'delete_replicant',
+  },
 );
 
 =head1 METHODS
@@ -127,23 +149,72 @@ L</replicants> attribute.
 =cut
 
 sub connect_replicants {
-       my $self = shift @_;
-       my $schema = shift @_;
-       
-       my @newly_created = ();
-       foreach my $connect_info (@_) {
-               
-               my $replicant = $self->create_replicant($schema);
-               $replicant->connect_info($connect_info);        
-               $replicant->ensure_connected;
-               DBIx::Class::Storage::DBI::Replicated::Replicant->meta->apply($replicant);
-               
-               my ($key) = ($connect_info->[0]=~m/^dbi\:.+\:(.+)$/);
-               $self->set_replicant( $key => $replicant);      
-               push @newly_created, $replicant;
-       }
-       
-       return @newly_created;
+  my $self = shift @_;
+  my $schema = shift @_;
+  
+  my @newly_created = ();
+  foreach my $connect_info (@_) {
+    $connect_info = [ $connect_info ]
+      if reftype $connect_info ne 'ARRAY';
+
+    croak "coderef replicant connect_info not supported"
+      if ref $connect_info->[0] && reftype $connect_info->[0] eq 'CODE';
+
+    my $replicant = $self->connect_replicant($schema, $connect_info);
+
+    my $key = $connect_info->[0];
+    $key = $key->{dsn} if ref $key && reftype $key eq 'HASH';
+    ($key) = ($key =~ m/^dbi\:.+\:(.+)$/);
+
+    $self->set_replicant( $key => $replicant);  
+    push @newly_created, $replicant;
+  }
+  
+  return @newly_created;
+}
+
+=head2 connect_replicant ($schema, $connect_info)
+
+Given a schema object and a hashref of $connect_info, connect the replicant
+and return it.
+
+=cut
+
+sub connect_replicant {
+  my ($self, $schema, $connect_info) = @_;
+  my $replicant = $self->create_replicant($schema);
+  $replicant->connect_info($connect_info);
+  $self->_safely_ensure_connected($replicant);
+  DBIx::Class::Storage::DBI::Replicated::Replicant->meta->apply($replicant);  
+  return $replicant;
+}
+
+=head2 _safely_ensure_connected ($replicant)
+
+The standard ensure_connected method with throw an exception should it fail to
+connect.  For the master database this is desirable, but since replicants are
+allowed to fail, this behavior is not desirable.  This method wraps the call
+to ensure_connected in an eval in order to catch any generated errors.  That
+way a slave to go completely offline (ie, the box itself can die) without
+bringing down your entire pool of databases.
+
+=cut
+
+sub _safely_ensure_connected {
+  my ($self, $replicant, @args) = @_;
+  eval {
+    $replicant->ensure_connected(@args);
+  }; 
+  if ($@) {
+    $replicant
+      ->debugobj
+      ->print(
+        sprintf( "Exception trying to ->ensure_connected for replicant %s, error is %s",
+          $replicant->_dbi_connect_info->[0], $@)
+        );
+       return;
+  }
+  return 1;
 }
 
 =head2 connected_replicants
@@ -151,11 +222,11 @@ sub connect_replicants {
 Returns true if there are connected replicants.  Actually is overloaded to
 return the number of replicants.  So you can do stuff like:
 
-    if( my $num_connected = $storage->has_connected_replicants ) {
-       print "I have $num_connected connected replicants";
-    } else {
-       print "Sorry, no replicants.";
-    }
+  if( my $num_connected = $storage->has_connected_replicants ) {
+    print "I have $num_connected connected replicants";
+  } else {
+    print "Sorry, no replicants.";
+  }
 
 This method will actually test that each replicant in the L</replicants> hashref
 is actually connected, try not to hit this 10 times a second.
@@ -163,10 +234,10 @@ is actually connected, try not to hit this 10 times a second.
 =cut
 
 sub connected_replicants {
-       my $self = shift @_;
-       return sum( map {
-               $_->connected ? 1:0
-       } $self->all_replicants );
+  my $self = shift @_;
+  return sum( map {
+    $_->connected ? 1:0
+  } $self->all_replicants );
 }
 
 =head2 active_replicants
@@ -178,10 +249,10 @@ should automatically reconnect them for us when we hit them with a query.
 =cut
 
 sub active_replicants {
-    my $self = shift @_;
-    return ( grep {$_} map {
-        $_->active ? $_:0
-    } $self->all_replicants );
+  my $self = shift @_;
+  return ( grep {$_} map {
+    $_->active ? $_:0
+  } $self->all_replicants );
 }
 
 =head2 all_replicants
@@ -192,8 +263,8 @@ array is given, nor should any meaning be derived.
 =cut
 
 sub all_replicants {
-       my $self = shift @_;
-       return values %{$self->replicants};
+  my $self = shift @_;
+  return values %{$self->replicants};
 }
 
 =head2 validate_replicants
@@ -212,13 +283,43 @@ connection is not following a master or is lagging.
 Calling this method will generate queries on the replicant databases so it is
 not recommended that you run them very often.
 
+This method requires that your underlying storage engine supports some sort of
+native replication mechanism.  Currently only MySQL native replication is
+supported.  Your patches to make other replication types work are welcomed.
+
 =cut
 
 sub validate_replicants {
-       my $self = shift @_;
-       foreach my $replicant($self->all_replicants) {
-               
-       }
+  my $self = shift @_;
+  foreach my $replicant($self->all_replicants) {
+    if($self->_safely_ensure_connected($replicant)) {
+      my $is_replicating = $replicant->is_replicating;
+      unless(defined $is_replicating) {
+        $replicant->debugobj->print("Storage Driver ".ref($self)." Does not support the 'is_replicating' method.  Assuming you are manually managing.\n");
+        next;
+      } else {
+        if($is_replicating) {
+          my $lag_behind_master = $replicant->lag_behind_master;
+          unless(defined $lag_behind_master) {
+            $replicant->debugobj->print("Storage Driver ".ref($self)." Does not support the 'lag_behind_master' method.  Assuming you are manually managing.\n");
+            next;
+          } else {
+            if($lag_behind_master <= $self->maximum_lag) {
+              $replicant->active(1);
+            } else {
+              $replicant->active(0);  
+            }
+          }    
+        } else {
+          $replicant->active(0);
+        }
+      }
+    } else {
+      $replicant->active(0);
+    }
+  }
+  ## Mark that we completed this validation.  
+  $self->_last_validated(time);  
 }
 
 =head1 AUTHOR
@@ -231,4 +332,6 @@ You may distribute this code under the same terms as Perl itself.
 
 =cut
 
+__PACKAGE__->meta->make_immutable;
+
 1;