requires 'Scope::Guard' => 0.03;
requires 'Digest::SHA1' => 2.00;
requires 'Path::Class' => 0;
+requires 'List::Util' => 1.19;
# Perl 5.8.0 doesn't have utf8::is_utf8()
requires 'Encode' => 0 if ($] <= 5.008000);
package DBIx::Class::Storage::DBI::Replicated;
use Moose;
+use DBIx::Class::Storage::DBI;
use DBIx::Class::Storage::DBI::Replicated::Pool;
+use DBIx::Class::Storage::DBI::Replicated::Balancer;
+use Scalar::Util qw(blessed);
-#extends 'DBIx::Class::Storage::DBI', 'Moose::Object';
+extends 'DBIx::Class::Storage::DBI', 'Moose::Object';
=head1 NAME
handles=>[qw/
on_connect_do
on_disconnect_do
- columns_info_for
connect_info
throw_exception
sql_maker
);
-=head2 replicant_storage_pool_type
+=head2 pool_type
-Contains the classname which will instantiate the L</replicant_storage_pool>
-object. Defaults to: L<DBIx::Class::Storage::DBI::Replicated::Pool>.
+Contains the classname which will instantiate the L</pool> object. Defaults
+to: L<DBIx::Class::Storage::DBI::Replicated::Pool>.
=cut
-has 'replicant_storage_pool_type' => (
+has 'pool_type' => (
is=>'ro',
isa=>'ClassName',
required=>1,
+ lazy=>1,
default=>'DBIx::Class::Storage::DBI::Replicated::Pool',
- handles=> {
- 'create_replicant_storage_pool' => 'new',
+ handles=>{
+ 'create_pool' => 'new',
},
);
-=head2 pool_balancer_type
+=head2 balancer_type
The replication pool requires a balance class to provider the methods for
choose how to spread the query load across each replicant in the pool.
=cut
-has 'pool_balancer_type' => (
+has 'balancer_type' => (
is=>'ro',
isa=>'ClassName',
required=>1,
- default=>'DBIx::Class::Storage::DBI::Replicated::Pool::Balancer',
- handles=> {
- 'create_replicant_storage_pool' => 'new',
+ lazy=>1,
+ default=>'DBIx::Class::Storage::DBI::Replicated::Balancer',
+ handles=>{
+ 'create_balancer' => 'new',
},
);
-=head2 replicant_storage_pool
+=head2 pool
-Holds the list of connected replicants, their status and other housekeeping or
-reporting methods.
+Is a <DBIx::Class::Storage::DBI::Replicated::Pool> or derived class. This is a
+container class for one or more replicated databases.
=cut
-has 'replicant_storage_pool' => (
+has 'pool' => (
is=>'ro',
isa=>'DBIx::Class::Storage::DBI::Replicated::Pool',
lazy_build=>1,
- handles=>[qw/replicant_storages/],
+ handles=>[qw/
+ replicants
+ has_replicants
+ create_replicants
+ num_replicants
+ delete_replicant
+ /],
);
+=head2 balancer
-=head1 METHODS
-
-This class defines the following methods.
+Is a <DBIx::Class::Storage::DBI::Replicated::Balancer> or derived class. This
+is a class that takes a pool (<DBIx::Class::Storage::DBI::Replicated::Pool>)
-=head2 new
+=cut
-Make sure we properly inherit from L<Moose>.
+has 'balancer' => (
+ is=>'ro',
+ isa=>'DBIx::Class::Storage::DBI::Replicated::Balancer',
+ lazy_build=>1,
+ handles=>[qw/next_storage/],
+);
-=cut
+=head1 METHODS
-sub new {
- my $class = shift @_;
- my $obj = $class->SUPER::new(@_);
-
- return $class->meta->new_object(
- __INSTANCE__ => $obj, @_
- );
-}
+This class defines the following methods.
-=head2 _build_master_storage
+=head2 _build_master
-Lazy builder for the L</master_storage> attribute.
+Lazy builder for the L</master> attribute.
=cut
-sub _build_next_replicant_storage {
+sub _build_master {
DBIx::Class::Storage::DBI->new;
}
-=head2 _build_current_replicant_storage
+=head2 _build_current_replicant
Lazy builder for the L</current_replicant_storage> attribute.
=cut
-sub _build_current_replicant_storage {
- shift->replicant_storage_pool->first;
+sub _build_current_replicant {
+ my $self = shift @_;
+ $self->next_storage($self->pool);
}
-=head2 _build_replicant_storage_pool
+=head2 _build_pool
-Lazy builder for the L</replicant_storage_pool> attribute.
+Lazy builder for the L</pool> attribute.
=cut
-sub _build_replicant_storage_pool {
+sub _build_pool {
my $self = shift @_;
- $self->create_replicant_storage_pool;
+ $self->create_pool;
}
-=head2 around: create_replicant_storage_pool
+=head2 _build_balancer
-Make sure all calles to the method set a default balancer type to our current
-balancer type.
+Lazy builder for the L</balancer> attribute.
=cut
-around 'create_replicant_storage_pool' => sub {
- my ($method, $self, @args) = @_;
- return $self->$method(balancer_type=>$self->pool_balancer_type, @args);
+sub _build_balancer {
+ my $self = shift @_;
+ $self->create_balancer;
}
=cut
-after 'get_current_replicant_storage' => sub {
+after 'get_current_replicant' => sub {
my $self = shift @_;
- my $next_replicant = $self->replicant_storage_pool->next;
- $self->next_replicant_storage($next_replicant);
+ my $next_replicant = $self->next_storage($self->pool);
+
+ $self->set_current_replicant($next_replicant);
};
-=head2 find_or_create
-
-First do a find on the replicant. If no rows are found, pass it on to the
-L</master_storage>
-
-=cut
-
-sub find_or_create {
- my $self = shift @_;
-}
-
=head2 all_storages
Returns an array of of all the connected storage backends. The first element
sub all_storages {
my $self = shift @_;
- return (
- $self->master_storage,
- $self->replicant_storages,
+ return grep {defined $_ && blessed $_} (
+ $self->master,
+ $self->replicants,
);
}
my $self = shift @_;
return
- $self->master_storage->connected &&
- $self->replicant_storage_pool->has_connected_slaves;
+ $self->master->connected &&
+ $self->pool->connected_replicants;
}
sub ensure_connected {
my $self = shift @_;
- foreach $source (shift->all_sources) {
+ foreach my $source ($self->all_storages) {
$source->ensure_connected(@_);
}
}
sub limit_dialect {
my $self = shift @_;
- foreach $source (shift->all_sources) {
- $source->name_sep(@_);
+ foreach my $source ($self->all_storages) {
+ $source->limit_dialect(@_);
}
}
sub quote_char {
my $self = shift @_;
- foreach $source (shift->all_sources) {
- $source->name_sep(@_);
+ foreach my $source ($self->all_storages) {
+ $source->quote_char(@_);
}
}
sub name_sep {
my $self = shift @_;
- foreach $source (shift->all_sources) {
+ foreach my $source ($self->all_storages) {
$source->name_sep(@_);
}
}
sub set_schema {
my $self = shift @_;
- foreach $source (shift->all_sources) {
+ foreach my $source ($self->all_storages) {
$source->set_schema(@_);
}
}
sub debug {
my $self = shift @_;
- foreach $source (shift->all_sources) {
+ foreach my $source ($self->all_storages) {
$source->debug(@_);
}
}
sub debugobj {
my $self = shift @_;
- foreach $source (shift->all_sources) {
+ foreach my $source ($self->all_storages) {
$source->debugobj(@_);
}
}
sub debugfh {
my $self = shift @_;
- foreach $source (shift->all_sources) {
+ foreach my $source ($self->all_storages) {
$source->debugfh(@_);
}
}
sub debugcb {
my $self = shift @_;
- foreach $source (shift->all_sources) {
+ foreach my $source ($self->all_storages) {
$source->debugcb(@_);
}
}
sub disconnect {
my $self = shift @_;
- foreach $source (shift->all_sources) {
+ foreach my $source ($self->all_storages) {
$source->disconnect(@_);
}
}
--- /dev/null
+package DBIx::Class::Storage::DBI::Replicated::Balancer;
+
+use Moose;
+use List::Util qw(shuffle);
+
+=head1 NAME
+
+DBIx::Class::Storage::DBI::Replicated::Balancer; A Software Load Balancer
+
+=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
+
+Given a pool (L<DBIx::Class::Storage::DBI::Replicated::Pool>) of replicated
+database's (L<DBIx::Class::Storage::DBI::Replicated::Replicant>), defines a
+method by which query load can be spread out across each replicant in the pool.
+
+=head1 ATTRIBUTES
+
+This class defines the following attributes.
+
+=head1 METHODS
+
+This class defines the following methods.
+
+=head2 next_storage ($pool)
+
+Given a pool object, return the next replicant that will serve queries. The
+default behavior is to randomize but you can write your own subclasses of
+L<DBIx::Class::Storage::DBI::Replicated::Balancer> to support other balance
+systems.
+
+=cut
+
+sub next_storage {
+ my $self = shift @_;
+ my $pool = shift @_;
+
+ return (shuffle($pool->all_replicants))[0];
+}
+
+
+=head1 AUTHOR
+
+John Napiorkowski <john.napiorkowski@takkle.com>
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
+
+=cut
+
+1;
\ No newline at end of file
--- /dev/null
+package DBIx::Class::Storage::DBI::Replicated::Pool;
+
+use Moose;
+use MooseX::AttributeHelpers;
+use DBIx::Class::Storage::DBI::Replicated::Replicant;
+use List::Util qw(sum);
+
+=head1 NAME
+
+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
+read only traffic. The Pool class manages this replicant, or list of
+replicants, and gives some methods for querying information about their status.
+
+=head1 ATTRIBUTES
+
+This class defines the following attributes.
+
+=head2 replicant_type
+
+Base class used to instantiate replicants that are in the pool. Unless you
+need to subclass L<DBIx::Class::Storage::DBI::Replicated::Replicant> you should
+just leave this alone.
+
+=cut
+
+has 'replicant_type' => (
+ is=>'ro',
+ isa=>'ClassName',
+ required=>1,
+ default=>'DBIx::Class::Storage::DBI::Replicated::Replicant',
+ handles=>{
+ 'create_replicant' => 'new',
+ },
+);
+
+
+=head2 replicants
+
+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"
+
+You could access the specific replicant via:
+
+ $schema->storage->replicants->{'dbname=dbfile'}
+
+This attributes also supports the following helper methods
+
+=over 4
+
+=item set_replicant($key=>$storage)
+
+Pushes a replicant onto the HashRef under $key
+
+=item get_replicant($key)
+
+Retrieves the named replicant
+
+=item has_replicants
+
+Returns true if the Pool defines replicants.
+
+=item num_replicants
+
+The number of replicants in the pool
+
+=item delete_replicant ($key)
+
+removes the replicant under $key from the pool
+
+=back
+
+=cut
+
+has 'replicants' => (
+ is=>'rw',
+ metaclass => 'Collection::Hash',
+ isa=>'HashRef[DBIx::Class::Storage::DBI::Replicated::Replicant]',
+ default=>sub {{}},
+ provides => {
+ 'set' => 'set_replicant',
+ 'get' => 'get_replicant',
+ 'empty' => 'has_replicants',
+ 'count' => 'num_replicants',
+ 'delete' => 'delete_replicant',
+ },
+);
+
+
+=head1 METHODS
+
+This class defines the following methods.
+
+=head2 create_replicants (Array[$connect_info])
+
+Given an array of $dsn suitable for connected to a database, create an
+L<DBIx::Class::Storage::DBI::Replicated::Replicant> object and store it in the
+L</replicants> attribute.
+
+=cut
+
+sub create_replicants {
+ my $self = shift @_;
+
+ my @newly_created = ();
+ foreach my $connect_info (@_) {
+ my $replicant = $self->create_replicant;
+ $replicant->connect_info($connect_info);
+ $replicant->ensure_connected;
+ my ($key) = ($connect_info->[0]=~m/^dbi\:.+\:(.+)$/);
+ $self->set_replicant( $key => $replicant);
+ push @newly_created, $replicant;
+ }
+
+ return @newly_created;
+}
+
+
+=head2 connected_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.";
+ }
+
+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.
+
+=cut
+
+sub connected_replicants {
+ my $self = shift @_;
+ return sum( map {
+ $_->connected ? 1:0
+ } $self->all_replicants );
+}
+
+=head2 all_replicants
+
+Just a simple array of all the replicant storages. No particular order to the
+array is given, nor should any meaning be derived.
+
+=cut
+
+sub all_replicants {
+ my $self = shift @_;
+ return values %{$self->replicants};
+}
+
+
+=head1 AUTHOR
+
+John Napiorkowski <john.napiorkowski@takkle.com>
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
+
+=cut
+
+
+1;
\ No newline at end of file
--- /dev/null
+package DBIx::Class::Storage::DBI::Replicated::Replicant;
+
+use Moose;
+extends 'DBIx::Class::Storage::DBI', 'Moose::Object';
+
+=head1 NAME
+
+DBIx::Class::Storage::DBI::Replicated::Replicant; A replicated DBI Storage
+
+=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
+
+Replicants are DBI Storages that follow a master DBI Storage. Typically this
+is accomplished via an external replication system. Please see the documents
+for L<DBIx::Class::Storage::DBI::Replicated> for more details.
+
+This class exists to define methods of a DBI Storage that only make sense when
+it's a classic 'slave' in a pool of slave databases which replicate from a
+given master database.
+
+=head1 ATTRIBUTES
+
+This class defines the following attributes.
+
+=head1 METHODS
+
+This class defines the following methods.
+
+=head1 AUTHOR
+
+John Napiorkowski <john.napiorkowski@takkle.com>
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
+
+=cut
\ No newline at end of file
eval "use Moose";
plan $@
? ( skip_all => 'needs Moose for testing' )
- : ( tests => 2 );
-}
+ : ( tests => 30 );
+}
+
+use_ok 'DBIx::Class::Storage::DBI::Replicated::Pool';
+use_ok 'DBIx::Class::Storage::DBI::Replicated::Balancer';
+use_ok 'DBIx::Class::Storage::DBI::Replicated::Replicant';
+use_ok 'DBIx::Class::Storage::DBI::Replicated';
## ----------------------------------------------------------------------------
## Build a class to hold all our required testing data and methods.
package DBIx::Class::DBI::Replicated::TestReplication;
use DBICTest;
+ use File::Copy;
+
use base qw/Class::Accessor::Fast/;
- __PACKAGE__->mk_accessors( qw/schema/ );
+ __PACKAGE__->mk_accessors( qw/schema master_path slave_paths/ );
## Initialize the object
sub new {
- my $proto = shift;
- my $class = ref( $proto ) || $proto;
- my $self = {};
-
- bless( $self, $class );
+ my $class = shift @_;
+ my $self = $class->SUPER::new(@_);
$self->schema( $self->init_schema );
+ $self->master_path("t/var/DBIxClass.db");
return $self;
}
- ## get the Schema and set the replication storage type
+ ## Get the Schema and set the replication storage type
sub init_schema {
my $class = shift @_;
my $schema = DBICTest->init_schema(storage_type=>'::DBI::Replicated');
return $schema;
}
+
+ ## Return an Array of ArrayRefs where each ArrayRef is suitable to use for
+ ## $storage->connect_info to be used for connecting replicants.
+
+ sub generate_replicant_connect_info {
+ my $self = shift @_;
+ my @dsn = map {
+ "dbi:SQLite:${_}";
+ } @{$self->slave_paths};
+
+ return map { [$_,'','',{}] } @dsn;
+ }
+
+ ## Do a 'good enough' replication by copying the master dbfile over each of
+ ## the slave dbfiles.
+
+ sub replicate {
+ my $self = shift @_;
+ foreach my $slave (@{$self->slave_paths}) {
+ copy($self->master_path, $slave);
+ }
+ }
+
+ ## Cleanup after ourselves. Unlink all gthe slave paths.
+
+ sub cleanup {
+ my $self = shift @_;
+ foreach my $slave (@{$self->slave_paths}) {
+ unlink $slave;
+ }
+ }
}
## ----------------------------------------------------------------------------
## Create an object and run some tests
## ----------------------------------------------------------------------------
-my %params = (
- db_paths => [
- "t/var/DBIxClass.db",
- "t/var/DBIxClass_slave1.db",
- "t/var/DBIxClass_slave2.db",
- ],
-);
+## Thi first bunch of tests are basic, just make sure all the bits are behaving
-ok my $replicate = DBIx::Class::DBI::Replicated::TestReplication->new()
- => 'Created a replication object';
+ok my $replicated = DBIx::Class::DBI::Replicated::TestReplication
+ ->new({
+ slave_paths=>[
+ "t/var/DBIxClass_slave1.db",
+ "t/var/DBIxClass_slave2.db",
+ ],
+ }) => 'Created a replication object';
-isa_ok $replicate->schema
+isa_ok $replicated->schema
=> 'DBIx::Class::Schema';
+isa_ok $replicated->schema->storage
+ => 'DBIx::Class::Storage::DBI::Replicated';
+
+ok $replicated->schema->storage->meta
+ => 'has a meta object';
+
+isa_ok $replicated->schema->storage->master
+ => 'DBIx::Class::Storage::DBI';
+
+isa_ok $replicated->schema->storage->pool
+ => 'DBIx::Class::Storage::DBI::Replicated::Pool';
+
+isa_ok $replicated->schema->storage->balancer
+ => 'DBIx::Class::Storage::DBI::Replicated::Balancer';
+
+ok my @replicant_connects = $replicated->generate_replicant_connect_info
+ => 'got replication connect information';
+
+ok my @replicated_storages = $replicated->schema->storage->create_replicants(@replicant_connects)
+ => 'Created some storages suitable for replicants';
+
+isa_ok $replicated->schema->storage->current_replicant
+ => 'DBIx::Class::Storage::DBI';
+
+ok $replicated->schema->storage->pool->has_replicants
+ => 'does have replicants';
+
+is $replicated->schema->storage->num_replicants => 2
+ => 'has two replicants';
+
+isa_ok $replicated_storages[0]
+ => 'DBIx::Class::Storage::DBI::Replicated::Replicant';
+
+isa_ok $replicated_storages[1]
+ => 'DBIx::Class::Storage::DBI::Replicated::Replicant';
+
+isa_ok $replicated->schema->storage->replicants->{"t/var/DBIxClass_slave1.db"}
+ => 'DBIx::Class::Storage::DBI::Replicated::Replicant';
+
+isa_ok $replicated->schema->storage->replicants->{"t/var/DBIxClass_slave2.db"}
+ => 'DBIx::Class::Storage::DBI::Replicated::Replicant';
+
+## Add some info to the database
+
+$replicated
+ ->schema
+ ->populate('Artist', [
+ [ qw/artistid name/ ],
+ [ 4, "Ozric Tentacles"],
+ ]);
+
+## Make sure all the slaves have the table definitions
+
+$replicated->replicate;
+
+## Make sure we can read the data.
+
+ok my $artist1 = $replicated->schema->resultset('Artist')->find(4)
+ => 'Created Result';
+
+isa_ok $artist1
+ => 'DBICTest::Artist';
+
+is $artist1->name, 'Ozric Tentacles'
+ => 'Found expected name for first result';
+
+## Add some new rows that only the master will have This is because
+## we overload any type of write operation so that is must hit the master
+## database.
+
+$replicated
+ ->schema
+ ->populate('Artist', [
+ [ qw/artistid name/ ],
+ [ 5, "Doom's Children"],
+ [ 6, "Dead On Arrival"],
+ [ 7, "Watergate"],
+ ]);
+
+## Alright, the database 'cluster' is not in a consistent state. When we do
+## a read now we expect bad news
+
+is $replicated->schema->resultset('Artist')->find(5), undef
+ => 'read after disconnect fails because it uses a replicant which we have neglected to "replicate" yet';
+
+## Make sure all the slaves have the table definitions
+$replicated->replicate;
+
+## Should find some data now
+
+ok my $artist2 = $replicated->schema->resultset('Artist')->find(5)
+ => 'Sync succeed';
- warn dump $replicate->schema->storage->meta;
+isa_ok $artist2
+ => 'DBICTest::Artist';
- warn dump $replicate->schema->storage->master;
+is $artist2->name, "Doom's Children"
+ => 'Found expected name for first result';
+
+## What happens when we disconnect all the replicants?
+
+$replicated->schema->storage->replicants->{"t/var/DBIxClass_slave1.db"}->disconnect;
+$replicated->schema->storage->replicants->{"t/var/DBIxClass_slave2.db"}->disconnect;
+
+ok my $artist3 = $replicated->schema->resultset('Artist')->find(6)
+ => 'Still finding stuff.';
+
+isa_ok $artist3
+ => 'DBICTest::Artist';
+
+is $artist3->name, "Dead On Arrival"
+ => 'Found expected name for first result';
__END__
projects / dbsrgits/DBIx-Class.git / commitdiff