1 package DBIx::Class::Storage::DBI::Replicated::Pool;
6 use Scalar::Util qw(reftype);
8 use Carp::Clan qw/^DBIx::Class/;
10 use DBIx::Class::Storage::DBI::Replicated::Types
11 qw(PositiveInteger Number DBICStorageDBI ClassName HashRef);
15 DBIx::Class::Storage::DBI::Replicated::Pool - Manage a pool of replicants
19 This class is used internally by L<DBIx::Class::Storage::DBI::Replicated>. You
20 shouldn't need to create instances of this class.
24 In a replicated storage type, there is at least one replicant to handle the
25 read-only traffic. The Pool class manages this replicant, or list of
26 replicants, and gives some methods for querying information about their status.
30 This class defines the following attributes.
32 =head2 maximum_lag ($num)
34 This is a number which defines the maximum allowed lag returned by the
35 L<DBIx::Class::Storage::DBI/lag_behind_master> method. The default is 0. In
36 general, this should return a larger number when the replicant is lagging
37 behind its master, however the implementation of this is database specific, so
38 don't count on this number having a fixed meaning. For example, MySQL will
39 return a number of seconds that the replicating database is lagging.
43 has 'maximum_lag' => (
52 This is an integer representing a time since the last time the replicants were
53 validated. It's nothing fancy, just an integer provided via the perl L<time|perlfunc/time>
58 has 'last_validated' => (
65 =head2 replicant_type ($classname)
67 Base class used to instantiate replicants that are in the pool. Unless you
68 need to subclass L<DBIx::Class::Storage::DBI::Replicated::Replicant> you should
69 just leave this alone.
73 has 'replicant_type' => (
76 default=> sub{'DBIx::Class::Storage::DBI'},
78 'create_replicant' => 'new',
84 A hashref of replicants, with the key being the dsn and the value returning the
85 actual replicant storage. For example, if the $dsn element is something like:
87 "dbi:SQLite:dbname=dbfile"
89 You could access the specific replicant via:
91 $schema->storage->replicants->{'dbname=dbfile'}
98 default => sub { +{} },
101 has next_unknown_replicant_id => (
104 default => sub { 1 },
107 sub inc_unknown_replicant_id {
109 my $next = $self->next_unknown_replicant_id + 1;
110 $self->next_unknown_replicant_id($next);
116 Reference to the master Storage.
122 isa =>DBICStorageDBI,
128 This class defines the following methods.
130 =head2 connect_replicants ($schema, Array[$connect_info])
132 Given an array of $dsn or connect_info structures suitable for connected to a
133 database, create an L<DBIx::Class::Storage::DBI::Replicated::Replicant> object
134 and store it in the L</replicants> attribute.
138 sub connect_replicants {
140 my $schema = shift @_;
142 my @newly_created = ();
143 foreach my $connect_info (@_) {
144 $connect_info = [ $connect_info ]
145 if reftype $connect_info ne 'ARRAY';
147 my $connect_coderef =
148 (reftype($connect_info->[0])||'') eq 'CODE' ? $connect_info->[0]
149 : (reftype($connect_info->[0])||'') eq 'HASH' &&
150 $connect_info->[0]->{dbh_maker};
154 ## yes this is evil, but it only usually happens once (for coderefs)
155 ## this will fail if the coderef does not actually DBI::connect
156 no warnings 'redefine';
157 my $connect = \&DBI::connect;
158 local *DBI::connect = sub {
162 $self->connect_replicant($schema, $connect_info);
168 if (!$connect_coderef) {
169 $dsn = $connect_info->[0];
170 $dsn = $dsn->{dsn} if (reftype($dsn)||'') eq 'HASH';
173 # all attempts to get the DSN failed
174 $key = "UNKNOWN_" . $self->next_unknown_replicant_id;
175 $self->inc_unknown_replicant_id;
179 $replicant->dsn($dsn);
180 ($key) = ($dsn =~ m/^dbi\:.+\:(.+)$/i);
184 $replicant->id($key);
186 $replicant->debugobj->print("Could not create an ID for the replicant!");
189 ## Add the new replicant to the list
192 %{$self->replicants},
195 push @newly_created, $replicant;
198 return @newly_created;
201 =head2 connect_replicant ($schema, $connect_info)
203 Given a schema object and a hashref of $connect_info, connect the replicant
208 sub connect_replicant {
209 my ($self, $schema, $connect_info) = @_;
210 my $replicant = $self->create_replicant($schema);
211 $replicant->connect_info($connect_info);
213 ## It is undesirable for catalyst to connect at ->connect_replicants time, as
214 ## connections should only happen on the first request that uses the database.
215 ## So we try to set the driver without connecting, however this doesn't always
216 ## work, as a driver may need to connect to determine the DB version, and this
219 ## Why this is necessary at all, is that we need to have the final storage
220 ## class to apply the Replicant role.
222 $self->_safely($replicant, '->_determine_driver', sub {
223 $replicant->_determine_driver
226 Role::Tiny->apply_roles_to_object($replicant, 'DBIx::Class::Storage::DBI::Replicated::Replicant');
228 # link back to master
229 $replicant->master($self->master);
234 =head2 _safely_ensure_connected ($replicant)
236 The standard ensure_connected method with throw an exception should it fail to
237 connect. For the master database this is desirable, but since replicants are
238 allowed to fail, this behavior is not desirable. This method wraps the call
239 to ensure_connected in an eval in order to catch any generated errors. That
240 way a slave can go completely offline (e.g. the box itself can die) without
241 bringing down your entire pool of databases.
245 sub _safely_ensure_connected {
246 my ($self, $replicant, @args) = @_;
248 return $self->_safely($replicant, '->ensure_connected', sub {
249 $replicant->ensure_connected(@args)
253 =head2 _safely ($replicant, $name, $code)
255 Execute C<$code> for operation C<$name> catching any exceptions and printing an
256 error message to the C<<$replicant->debugobj>>.
258 Returns 1 on success and undef on failure.
263 my ($self, $replicant, $name, $code) = @_;
269 $replicant->debugobj->print(sprintf(
270 "Exception trying to $name for replicant %s, error is %s",
271 $replicant->_dbi_connect_info->[0], $_)
277 =head2 connected_replicants
279 Returns true if there are connected replicants. Actually is overloaded to
280 return the number of replicants. So you can do stuff like:
282 if( my $num_connected = $storage->has_connected_replicants ) {
283 print "I have $num_connected connected replicants";
285 print "Sorry, no replicants.";
288 This method will actually test that each replicant in the L</replicants> hashref
289 is actually connected, try not to hit this 10 times a second.
293 sub connected_replicants {
295 return List::Util::sum( map {
297 } $self->all_replicants );
300 =head2 active_replicants
302 This is an array of replicants that are considered to be active in the pool.
303 This does not check to see if they are connected, but if they are not, DBIC
304 should automatically reconnect them for us when we hit them with a query.
308 sub active_replicants {
310 return ( grep {$_} map {
312 } $self->all_replicants );
315 =head2 all_replicants
317 Just a simple array of all the replicant storages. No particular order to the
318 array is given, nor should any meaning be derived.
324 return values %{$self->replicants};
327 =head2 validate_replicants
329 This does a check to see if 1) each replicate is connected (or reconnectable),
330 2) that is ->is_replicating, and 3) that it is not exceeding the lag amount
331 defined by L</maximum_lag>. Replicants that fail any of these tests are set to
332 inactive, and thus removed from the replication pool.
334 This tests L<all_replicants>, since a replicant that has been previous marked
335 as inactive can be reactivated should it start to pass the validation tests again.
337 See L<DBIx::Class::Storage::DBI> for more about checking if a replicating
338 connection is not following a master or is lagging.
340 Calling this method will generate queries on the replicant databases so it is
341 not recommended that you run them very often.
343 This method requires that your underlying storage engine supports some sort of
344 native replication mechanism. Currently only MySQL native replication is
345 supported. Your patches to make other replication types work are welcomed.
349 sub validate_replicants {
351 foreach my $replicant($self->all_replicants) {
352 if($self->_safely_ensure_connected($replicant)) {
353 my $is_replicating = $replicant->is_replicating;
354 unless(defined $is_replicating) {
355 $replicant->debugobj->print("Storage Driver ".ref($self)." Does not support the 'is_replicating' method. Assuming you are manually managing.\n");
358 if($is_replicating) {
359 my $lag_behind_master = $replicant->lag_behind_master;
360 unless(defined $lag_behind_master) {
361 $replicant->debugobj->print("Storage Driver ".ref($self)." Does not support the 'lag_behind_master' method. Assuming you are manually managing.\n");
364 if($lag_behind_master <= $self->maximum_lag) {
365 $replicant->active(1);
367 $replicant->active(0);
371 $replicant->active(0);
375 $replicant->active(0);
378 ## Mark that we completed this validation.
379 $self->last_validated(time);
384 John Napiorkowski <jjnapiork@cpan.org>
388 You may distribute this code under the same terms as Perl itself.