names should now be consistent and collision-free.
- Improve handling of explicit key attr in ResultSet::find
- Add warnings for non-unique ResultSet::find queries
- - Changed Storage::DBI::Replication to Storage::DBI::Replicated, fixed
- some problems using this with versioned databases, added some docs
+ - Changed Storage::DBI::Replication to Storage::DBI::Replicated and
+ refactored support.
- By default now deploy/diff et al. will ignore constraint and index
names
- Add ResultSet::_is_deterministic_value, make new_result filter the
requires 'JSON::Any' => 1.00;
requires 'Scope::Guard' => 0.03;
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);
return (map { $self->{_column_data}{$_} } $self->primary_columns);
}
-=head2 discard_changes
+=head2 discard_changes ($attrs)
Re-selects the row from the database, losing any changes that had
been made.
This method can also be used to refresh from storage, retrieving any
changes made since the row was last read from storage.
+$attrs is expected to be a hashref of attributes suitable for passing as the
+second argument to $resultset->search($cond, $attrs);
+
=cut
sub discard_changes {
- my ($self) = @_;
+ my ($self, $attrs) = @_;
delete $self->{_dirty_columns};
return unless $self->in_storage; # Don't reload if we aren't real!
-
- my $reload = $self->result_source->resultset->find(
- map { $self->$_ } $self->primary_columns
- );
- unless ($reload) { # If we got deleted in the mean-time
+
+ if( my $current_storage = $self->get_from_storage($attrs)) {
+
+ # Set $self to the current.
+ %$self = %$current_storage;
+
+ # Avoid a possible infinite loop with
+ # sub DESTROY { $_[0]->discard_changes }
+ bless $current_storage, 'Do::Not::Exist';
+
+ return $self;
+ } else {
$self->in_storage(0);
- return $self;
+ return $self;
}
-
- %$self = %$reload;
-
- # Avoid a possible infinite loop with
- # sub DESTROY { $_[0]->discard_changes }
- bless $reload, 'Do::Not::Exist';
-
- return $self;
}
=head2 id
$class->mk_group_accessors('column' => $acc);
}
+=head2 get_from_storage ($attrs)
+
+Returns a new Row which is whatever the Storage has for the currently created
+Row object. You can use this to see if the storage has become inconsistent with
+whatever your Row object is.
+
+$attrs is expected to be a hashref of attributes suitable for passing as the
+second argument to $resultset->search($cond, $attrs);
+
+=cut
+
+sub get_from_storage {
+ my $self = shift @_;
+ my $attrs = shift @_;
+ my @primary_columns = map { $self->$_ } $self->primary_columns;
+ my $resultset = $self->result_source->resultset;
+
+ if(defined $attrs) {
+ $resultset = $resultset->search(undef, $attrs);
+ }
+
+ return $resultset->find(@primary_columns);
+}
=head2 throw_exception
=over 4
-=item Arguments: $storage_type
+=item Arguments: $storage_type|{$storage_type, \%args}
-=item Return Value: $storage_type
+=item Return Value: $storage_type|{$storage_type, \%args}
=back
dealing with MSSQL via L<DBD::Sybase>, in which case you'd set it to
C<::DBI::Sybase::MSSQL>.
+If your storage type requires instantiation arguments, those are defined as a
+second argument in the form of a hashref and the entire value needs to be
+wrapped into an arrayref or a hashref. We support both types of refs here in
+order to play nice with your Config::[class] or your choice.
+
+See L<DBIx::Class::Storage::DBI::Replicated> for an example of this.
+
=head2 connection
=over 4
sub connection {
my ($self, @info) = @_;
return $self if !@info && $self->storage;
- my $storage_class = $self->storage_type;
+
+ my ($storage_class, $args) = ref $self->storage_type ?
+ ($self->_normalize_storage_type($self->storage_type),{}) : ($self->storage_type, {});
+
$storage_class = 'DBIx::Class::Storage'.$storage_class
if $storage_class =~ m/^::/;
eval "require ${storage_class};";
$self->throw_exception(
"No arguments to load_classes and couldn't load ${storage_class} ($@)"
) if $@;
- my $storage = $storage_class->new($self);
+ my $storage = $storage_class->new($self=>$args);
$storage->connect_info(\@info);
$self->storage($storage);
return $self;
}
+sub _normalize_storage_type {
+ my ($self, $storage_type) = @_;
+ if(ref $storage_type eq 'ARRAY') {
+ return @$storage_type;
+ } elsif(ref $storage_type eq 'HASH') {
+ return %$storage_type;
+ } else {
+ $self->throw_exception('Unsupported REFTYPE given: '. ref $storage_type);
+ }
+}
+
=head2 connect
=over 4
if ( $self->debug ) {
@bind = $self->_fix_bind_params(@bind);
+
$self->debugobj->query_start( $sql, @bind );
}
}
}
}
+=head2 is_replicating
+
+A boolean that reports if a particular L<DBIx::Class::Storage::DBI> is set to
+replicate from a master database. Default is undef, which is the result
+returned by databases that don't support replication.
+
+=cut
+
+sub is_replicating {
+ return;
+
+}
+
+=head2 lag_behind_master
+
+Returns a number that represents a certain amount of lag behind a master db
+when a given storage is replicating. The number is database dependent, but
+starts at zero and increases with the amount of lag. Default in undef
+
+=cut
+
+sub lag_behind_master {
+ return;
+}
+
sub DESTROY {
my $self = shift;
return if !$self->_dbh;
package DBIx::Class::Storage::DBI::Replicated;
-use strict;
-use warnings;
+BEGIN {
+ use Carp::Clan qw/^DBIx::Class/;
+
+ ## Modules required for Replication support not required for general DBIC
+ ## use, so we explicitly test for these.
+
+ my %replication_required = (
+ Moose => '0.54',
+ MooseX::AttributeHelpers => '0.12',
+ Moose::Util::TypeConstraints => '0.54',
+ Class::MOP => '0.63',
+ );
+
+ my @didnt_load;
+
+ for my $module (keys %replication_required) {
+ eval "use $module $replication_required{$module}";
+ push @didnt_load, "$module $replication_required{$module}"
+ if $@;
+ }
+
+ croak("@{[ join ', ', @didnt_load ]} are missing and are required for Replication")
+ if @didnt_load;
+}
use DBIx::Class::Storage::DBI;
-use DBD::Multi;
-
-use base qw/Class::Accessor::Fast/;
-
-__PACKAGE__->mk_accessors( qw/read_source write_source/ );
+use DBIx::Class::Storage::DBI::Replicated::Pool;
+use DBIx::Class::Storage::DBI::Replicated::Balancer;
=head1 NAME
-DBIx::Class::Storage::DBI::Replicated - ALPHA Replicated database support
+DBIx::Class::Storage::DBI::Replicated - BETA Replicated database support
=head1 SYNOPSIS
The Following example shows how to change an existing $schema to a replicated
-storage type and update it's connection information to contain a master DSN and
-an array of slaves.
-
- ## Change storage_type in your schema class
- $schema->storage_type( '::DBI::Replicated' );
-
- ## Set your connection.
- $schema->connect(
- $dsn, $user, $password, {
- AutoCommit => 1,
- ## Other standard DBI connection or DBD custom attributes added as
- ## usual. Additionally, we have two custom attributes for defining
- ## slave information and controlling how the underlying DBD::Multi
- slaves_connect_info => [
- ## Define each slave like a 'normal' DBI connection, but you add
- ## in a DBD::Multi custom attribute to define how the slave is
- ## prioritized. Please see DBD::Multi for more.
- [$slave1dsn, $user, $password, {%slave1opts, priority=>10}],
- [$slave2dsn, $user, $password, {%slave2opts, priority=>10}],
- [$slave3dsn, $user, $password, {%slave3opts, priority=>20}],
- ## add in a preexisting database handle
- [$dbh, '','', {priority=>30}],
- ## DBD::Multi will call this coderef for connects
- [sub { DBI->connect(< DSN info >) }, '', '', {priority=>40}],
- ## If the last item is hashref, we use that for DBD::Multi's
- ## configuration information. Again, see DBD::Multi for more.
- {timeout=>25, failed_max=>2},
- ],
- },
- );
-
- ## Now, just use the schema as normal
- $schema->resultset('Table')->find(< unique >); ## Reads will use slaves
- $schema->resultset('Table')->create(\%info); ## Writes will use master
+storage type, add some replicated (readonly) databases, and perform reporting
+tasks.
+ ## Change storage_type in your schema class
+ $schema->storage_type( ['::DBI::Replicated', {balancer=>'::Random'}] );
+
+ ## Add some slaves. Basically this is an array of arrayrefs, where each
+ ## arrayref is database connect information
+
+ $schema->storage->connect_replicants(
+ [$dsn1, $user, $pass, \%opts],
+ [$dsn2, $user, $pass, \%opts],
+ [$dsn3, $user, $pass, \%opts],
+ );
+
+ ## Now, just use the $schema as normal
+ $schema->resultset('Source')->search({name=>'etc'});
+
+ ## You can force a given query to use a particular storage using the search
+ ### attribute 'force_pool'. For example:
+
+ my $RS = $schema->resultset('Source')->search(undef, {force_pool=>'master'});
+
+ ## Now $RS will force everything (both reads and writes) to use whatever was
+ ## setup as the master storage. 'master' is hardcoded to always point to the
+ ## Master, but you can also use any Replicant name. Please see:
+ ## L<DBIx::Class::Storage::Replicated::Pool> and the replicants attribute for
+ ## More. Also see transactions and L</execute_reliably> for alternative ways
+ ## to force read traffic to the master.
+
=head1 DESCRIPTION
-Warning: This class is marked ALPHA. We are using this in development and have
-some basic test coverage but the code hasn't yet been stressed by a variety
-of databases. Individual DB's may have quirks we are not aware of. Please
-use this in development and pass along your experiences/bug fixes.
+Warning: This class is marked BETA. This has been running a production
+website using MySQL native replication as its backend and we have some decent
+test coverage but the code hasn't yet been stressed by a variety of databases.
+Individual DB's may have quirks we are not aware of. Please use this in first
+development and pass along your experiences/bug fixes.
This class implements replicated data store for DBI. Currently you can define
one master and numerous slave database connections. All write-type queries
(INSERT, UPDATE, DELETE and even LAST_INSERT_ID) are routed to master
database, all read-type queries (SELECTs) go to the slave database.
-For every slave database you can define a priority value, which controls data
-source usage pattern. It uses L<DBD::Multi>, so first the lower priority data
-sources used (if they have the same priority, the are used randomized), than
-if all low priority data sources fail, higher ones tried in order.
+Basically, any method request that L<DBIx::Class::Storage::DBI> would normally
+handle gets delegated to one of the two attributes: L</read_handler> or to
+L</write_handler>. Additionally, some methods need to be distributed
+to all existing storages. This way our storage class is a drop in replacement
+for L<DBIx::Class::Storage::DBI>.
-=head1 CONFIGURATION
+Read traffic is spread across the replicants (slaves) occuring to a user
+selected algorithm. The default algorithm is random weighted.
-Please see L<DBD::Multi> for most configuration information.
+=head1 NOTES
+
+The consistancy betweeen master and replicants is database specific. The Pool
+gives you a method to validate it's replicants, removing and replacing them
+when they fail/pass predefined criteria. Please make careful use of the ways
+to force a query to run against Master when needed.
+
+=head1 REQUIREMENTS
+
+Replicated Storage has additional requirements not currently part of L<DBIx::Class>
+
+ Moose => 1.54
+ MooseX::AttributeHelpers => 0.12
+ Moose::Util::TypeConstraints => 0.54
+ Class::MOP => 0.63
+
+You will need to install these modules manually via CPAN or make them part of the
+Makefile for your distribution.
+
+=head1 ATTRIBUTES
+
+This class defines the following attributes.
+
+=head2 schema
+
+The underlying L<DBIx::Class::Schema> object this storage is attaching
=cut
-sub new {
- my $proto = shift;
- my $class = ref( $proto ) || $proto;
- my $self = {};
+has 'schema' => (
+ is=>'rw',
+ isa=>'DBIx::Class::Schema',
+ weak_ref=>1,
+ required=>1,
+);
- bless( $self, $class );
+=head2 pool_type
- $self->write_source( DBIx::Class::Storage::DBI->new );
- $self->read_source( DBIx::Class::Storage::DBI->new );
+Contains the classname which will instantiate the L</pool> object. Defaults
+to: L<DBIx::Class::Storage::DBI::Replicated::Pool>.
- return $self;
-}
+=cut
-sub all_sources {
- my $self = shift;
+has 'pool_type' => (
+ is=>'ro',
+ isa=>'ClassName',
+ required=>1,
+ default=>'DBIx::Class::Storage::DBI::Replicated::Pool',
+ handles=>{
+ 'create_pool' => 'new',
+ },
+);
- my @sources = ($self->read_source, $self->write_source);
+=head2 pool_args
- return wantarray ? @sources : \@sources;
-}
+Contains a hashref of initialized information to pass to the Balancer object.
+See L<DBIx::Class::Storage::Replicated::Pool> for available arguments.
-sub _connect_info {
- my $self = shift;
- my $master = $self->write_source->_connect_info;
- $master->[-1]->{slave_connect_info} = $self->read_source->_connect_info;
- return $master;
-}
+=cut
-sub connect_info {
- my ($self, $source_info) = @_;
+has 'pool_args' => (
+ is=>'ro',
+ isa=>'HashRef',
+ lazy=>1,
+ required=>1,
+ default=>sub { {} },
+);
- ## if there is no $source_info, treat this sub like an accessor
- return $self->_connect_info
- if !$source_info;
-
- ## Alright, let's conect the master
- $self->write_source->connect_info($source_info);
-
- ## Now, build and then connect the Slaves
- my @slaves_connect_info = @{$source_info->[-1]->{slaves_connect_info}};
- my $dbd_multi_config = ref $slaves_connect_info[-1] eq 'HASH'
- ? pop @slaves_connect_info : {};
-
- ## We need to do this since SQL::Abstract::Limit can't guess what DBD::Multi is
- $dbd_multi_config->{limit_dialect} = $self->write_source->sql_maker->limit_dialect
- unless defined $dbd_multi_config->{limit_dialect};
-
- @slaves_connect_info = map {
- ## if the first element in the arrayhash is a ref, make that the value
- my $db = ref $_->[0] ? $_->[0] : $_;
- my $priority = $_->[-1]->{priority} || 10; ## default priority is 10
- $priority => $db;
- } @slaves_connect_info;
+
+=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
+
+subtype 'DBIx::Class::Storage::DBI::Replicated::BalancerClassNamePart',
+ as 'ClassName';
- $self->read_source->connect_info([
- 'dbi:Multi:', undef, undef, {
- dsns => [@slaves_connect_info],
- %$dbd_multi_config,
- },
- ]);
+coerce 'DBIx::Class::Storage::DBI::Replicated::BalancerClassNamePart',
+ from 'Str',
+ via {
+ my $type = $_;
+ if($type=~m/^::/) {
+ $type = 'DBIx::Class::Storage::DBI::Replicated::Balancer'.$type;
+ }
+ Class::MOP::load_class($type);
+ $type;
+ };
+
+has 'balancer_type' => (
+ is=>'ro',
+ isa=>'DBIx::Class::Storage::DBI::Replicated::BalancerClassNamePart',
+ coerce=>1,
+ required=>1,
+ default=> 'DBIx::Class::Storage::DBI::Replicated::Balancer::First',
+ handles=>{
+ 'create_balancer' => 'new',
+ },
+);
+
+=head2 balancer_args
+
+Contains a hashref of initialized information to pass to the Balancer object.
+See L<DBIx::Class::Storage::Replicated::Balancer> for available arguments.
+
+=cut
+
+has 'balancer_args' => (
+ is=>'ro',
+ isa=>'HashRef',
+ lazy=>1,
+ required=>1,
+ default=>sub { {} },
+);
+
+=head2 pool
+
+Is a <DBIx::Class::Storage::DBI::Replicated::Pool> or derived class. This is a
+container class for one or more replicated databases.
+
+=cut
+
+has 'pool' => (
+ is=>'ro',
+ isa=>'DBIx::Class::Storage::DBI::Replicated::Pool',
+ lazy_build=>1,
+ handles=>[qw/
+ connect_replicants
+ replicants
+ has_replicants
+ /],
+);
+
+=head2 balancer
+
+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>)
+
+=cut
+
+has 'balancer' => (
+ is=>'ro',
+ isa=>'DBIx::Class::Storage::DBI::Replicated::Balancer',
+ lazy_build=>1,
+ handles=>[qw/auto_validate_every/],
+);
+
+=head2 master
+
+The master defines the canonical state for a pool of connected databases. All
+the replicants are expected to match this databases state. Thus, in a classic
+Master / Slaves distributed system, all the slaves are expected to replicate
+the Master's state as quick as possible. This is the only database in the
+pool of databases that is allowed to handle write traffic.
+
+=cut
+
+has 'master' => (
+ is=> 'ro',
+ isa=>'DBIx::Class::Storage::DBI',
+ lazy_build=>1,
+);
+
+=head1 ATTRIBUTES IMPLEMENTING THE DBIx::Storage::DBI INTERFACE
+
+The following methods are delegated all the methods required for the
+L<DBIx::Class::Storage::DBI> interface.
+
+=head2 read_handler
+
+Defines an object that implements the read side of L<BIx::Class::Storage::DBI>.
+
+=cut
+
+has 'read_handler' => (
+ is=>'rw',
+ isa=>'Object',
+ lazy_build=>1,
+ handles=>[qw/
+ select
+ select_single
+ columns_info_for
+ /],
+);
+
+=head2 write_handler
+
+Defines an object that implements the write side of L<BIx::Class::Storage::DBI>.
+
+=cut
+
+has 'write_handler' => (
+ is=>'ro',
+ isa=>'Object',
+ lazy_build=>1,
+ lazy_build=>1,
+ handles=>[qw/
+ on_connect_do
+ on_disconnect_do
+ connect_info
+ throw_exception
+ sql_maker
+ sqlt_type
+ create_ddl_dir
+ deployment_statements
+ datetime_parser
+ datetime_parser_type
+ last_insert_id
+ insert
+ insert_bulk
+ update
+ delete
+ dbh
+ txn_begin
+ txn_do
+ txn_commit
+ txn_rollback
+ txn_scope_guard
+ sth
+ deploy
+
+ reload_row
+ _prep_for_execute
+ configure_sqlt
- ## Return the formated connection information
- return $self->_connect_info;
-}
+ /],
+);
-sub select {
- shift->read_source->select( @_ );
-}
-sub select_single {
- shift->read_source->select_single( @_ );
-}
-sub throw_exception {
- shift->read_source->throw_exception( @_ );
-}
-sub sql_maker {
- shift->read_source->sql_maker( @_ );
-}
-sub columns_info_for {
- shift->read_source->columns_info_for( @_ );
-}
-sub sqlt_type {
- shift->read_source->sqlt_type( @_ );
-}
-sub create_ddl_dir {
- shift->read_source->create_ddl_dir( @_ );
-}
-sub deployment_statements {
- shift->read_source->deployment_statements( @_ );
-}
-sub datetime_parser {
- shift->read_source->datetime_parser( @_ );
-}
-sub datetime_parser_type {
- shift->read_source->datetime_parser_type( @_ );
-}
-sub build_datetime_parser {
- shift->read_source->build_datetime_parser( @_ );
-}
+=head1 METHODS
+
+This class defines the following methods.
-sub limit_dialect { $_->limit_dialect( @_ ) for( shift->all_sources ) }
-sub quote_char { $_->quote_char( @_ ) for( shift->all_sources ) }
-sub name_sep { $_->quote_char( @_ ) for( shift->all_sources ) }
-sub disconnect { $_->disconnect( @_ ) for( shift->all_sources ) }
-sub set_schema { $_->set_schema( @_ ) for( shift->all_sources ) }
+=head2 BUILDARGS
-sub DESTROY {
- my $self = shift;
+L<DBIx::Class::Schema> when instantiating it's storage passed itself as the
+first argument. So we need to massage the arguments a bit so that all the
+bits get put into the correct places.
- undef $self->{write_source};
- undef $self->{read_sources};
+=cut
+
+sub BUILDARGS {
+ my ($class, $schema, $storage_type_args, @args) = @_;
+
+ return {
+ schema=>$schema,
+ %$storage_type_args,
+ @args
+ }
}
-sub last_insert_id {
- shift->write_source->last_insert_id( @_ );
+=head2 _build_master
+
+Lazy builder for the L</master> attribute.
+
+=cut
+
+sub _build_master {
+ my $self = shift @_;
+ DBIx::Class::Storage::DBI->new($self->schema);
}
-sub insert {
- shift->write_source->insert( @_ );
+
+=head2 _build_pool
+
+Lazy builder for the L</pool> attribute.
+
+=cut
+
+sub _build_pool {
+ my $self = shift @_;
+ $self->create_pool(%{$self->pool_args});
}
-sub update {
- shift->write_source->update( @_ );
+
+=head2 _build_balancer
+
+Lazy builder for the L</balancer> attribute. This takes a Pool object so that
+the balancer knows which pool it's balancing.
+
+=cut
+
+sub _build_balancer {
+ my $self = shift @_;
+ $self->create_balancer(
+ pool=>$self->pool,
+ master=>$self->master,
+ %{$self->balancer_args},
+ );
}
-sub update_all {
- shift->write_source->update_all( @_ );
+
+=head2 _build_write_handler
+
+Lazy builder for the L</write_handler> attribute. The default is to set this to
+the L</master>.
+
+=cut
+
+sub _build_write_handler {
+ return shift->master;
}
-sub delete {
- shift->write_source->delete( @_ );
+
+=head2 _build_read_handler
+
+Lazy builder for the L</read_handler> attribute. The default is to set this to
+the L</balancer>.
+
+=cut
+
+sub _build_read_handler {
+ return shift->balancer;
}
-sub delete_all {
- shift->write_source->delete_all( @_ );
+
+=head2 around: connect_replicants
+
+All calls to connect_replicants needs to have an existing $schema tacked onto
+top of the args, since L<DBIx::Storage::DBI> needs it.
+
+=cut
+
+around 'connect_replicants' => sub {
+ my ($method, $self, @args) = @_;
+ $self->$method($self->schema, @args);
+};
+
+=head2 all_storages
+
+Returns an array of of all the connected storage backends. The first element
+in the returned array is the master, and the remainings are each of the
+replicants.
+
+=cut
+
+sub all_storages {
+ my $self = shift @_;
+ return grep {defined $_ && blessed $_} (
+ $self->master,
+ $self->replicants,
+ );
}
-sub create {
- shift->write_source->create( @_ );
+
+=head2 execute_reliably ($coderef, ?@args)
+
+Given a coderef, saves the current state of the L</read_handler>, forces it to
+use reliable storage (ie sets it to the master), executes a coderef and then
+restores the original state.
+
+Example:
+
+ my $reliably = sub {
+ my $name = shift @_;
+ $schema->resultset('User')->create({name=>$name});
+ my $user_rs = $schema->resultset('User')->find({name=>$name});
+ return $user_rs;
+ };
+
+ my $user_rs = $schema->storage->execute_reliably($reliably, 'John');
+
+Use this when you must be certain of your database state, such as when you just
+inserted something and need to get a resultset including it, etc.
+
+=cut
+
+sub execute_reliably {
+ my ($self, $coderef, @args) = @_;
+
+ unless( ref $coderef eq 'CODE') {
+ $self->throw_exception('Second argument must be a coderef');
+ }
+
+ ##Get copy of master storage
+ my $master = $self->master;
+
+ ##Get whatever the current read hander is
+ my $current = $self->read_handler;
+
+ ##Set the read handler to master
+ $self->read_handler($master);
+
+ ## do whatever the caller needs
+ my @result;
+ my $want_array = wantarray;
+
+ eval {
+ if($want_array) {
+ @result = $coderef->(@args);
+ } elsif(defined $want_array) {
+ ($result[0]) = ($coderef->(@args));
+ } else {
+ $coderef->(@args);
+ }
+ };
+
+ ##Reset to the original state
+ $self->read_handler($current);
+
+ ##Exception testing has to come last, otherwise you might leave the
+ ##read_handler set to master.
+
+ if($@) {
+ $self->throw_exception("coderef returned an error: $@");
+ } else {
+ return $want_array ? @result : $result[0];
+ }
}
-sub find_or_create {
- shift->write_source->find_or_create( @_ );
+
+=head2 set_reliable_storage
+
+Sets the current $schema to be 'reliable', that is all queries, both read and
+write are sent to the master
+
+=cut
+
+sub set_reliable_storage {
+ my $self = shift @_;
+ my $schema = $self->schema;
+ my $write_handler = $self->schema->storage->write_handler;
+
+ $schema->storage->read_handler($write_handler);
}
-sub update_or_create {
- shift->write_source->update_or_create( @_ );
+
+=head2 set_balanced_storage
+
+Sets the current $schema to be use the </balancer> for all reads, while all
+writea are sent to the master only
+
+=cut
+
+sub set_balanced_storage {
+ my $self = shift @_;
+ my $schema = $self->schema;
+ my $write_handler = $self->schema->storage->balancer;
+
+ $schema->storage->read_handler($write_handler);
}
+
+=head2 around: txn_do ($coderef)
+
+Overload to the txn_do method, which is delegated to whatever the
+L<write_handler> is set to. We overload this in order to wrap in inside a
+L</execute_reliably> method.
+
+=cut
+
+around 'txn_do' => sub {
+ my($txn_do, $self, $coderef, @args) = @_;
+ $self->execute_reliably(sub {$self->$txn_do($coderef, @args)});
+};
+
+=head2 connected
+
+Check that the master and at least one of the replicants is connected.
+
+=cut
+
sub connected {
- shift->write_source->connected( @_ );
+ my $self = shift @_;
+ return
+ $self->master->connected &&
+ $self->pool->connected_replicants;
}
+
+=head2 ensure_connected
+
+Make sure all the storages are connected.
+
+=cut
+
sub ensure_connected {
- shift->write_source->ensure_connected( @_ );
-}
-sub dbh {
- shift->write_source->dbh( @_ );
-}
-sub txn_do {
- shift->write_source->txn_do( @_ );
+ my $self = shift @_;
+ foreach my $source ($self->all_storages) {
+ $source->ensure_connected(@_);
+ }
}
-sub txn_commit {
- shift->write_source->txn_commit( @_ );
+
+=head2 limit_dialect
+
+Set the limit_dialect for all existing storages
+
+=cut
+
+sub limit_dialect {
+ my $self = shift @_;
+ foreach my $source ($self->all_storages) {
+ $source->limit_dialect(@_);
+ }
+ return $self->master->quote_char;
}
-sub txn_rollback {
- shift->write_source->txn_rollback( @_ );
+
+=head2 quote_char
+
+Set the quote_char for all existing storages
+
+=cut
+
+sub quote_char {
+ my $self = shift @_;
+ foreach my $source ($self->all_storages) {
+ $source->quote_char(@_);
+ }
+ return $self->master->quote_char;
}
-sub sth {
- shift->write_source->sth( @_ );
+
+=head2 name_sep
+
+Set the name_sep for all existing storages
+
+=cut
+
+sub name_sep {
+ my $self = shift @_;
+ foreach my $source ($self->all_storages) {
+ $source->name_sep(@_);
+ }
+ return $self->master->name_sep;
}
-sub deploy {
- shift->write_source->deploy( @_ );
+
+=head2 set_schema
+
+Set the schema object for all existing storages
+
+=cut
+
+sub set_schema {
+ my $self = shift @_;
+ foreach my $source ($self->all_storages) {
+ $source->set_schema(@_);
+ }
}
-sub _prep_for_execute {
- shift->write_source->_prep_for_execute(@_);
+
+=head2 debug
+
+set a debug flag across all storages
+
+=cut
+
+sub debug {
+ my $self = shift @_;
+ if(@_) {
+ foreach my $source ($self->all_storages) {
+ $source->debug(@_);
+ }
+ }
+ return $self->master->debug;
}
+=head2 debugobj
+
+set a debug object across all storages
+
+=cut
+
sub debugobj {
- shift->write_source->debugobj(@_);
+ my $self = shift @_;
+ if(@_) {
+ foreach my $source ($self->all_storages) {
+ $source->debugobj(@_);
+ }
+ }
+ return $self->master->debugobj;
}
-sub debug {
- shift->write_source->debug(@_);
+
+=head2 debugfh
+
+set a debugfh object across all storages
+
+=cut
+
+sub debugfh {
+ my $self = shift @_;
+ if(@_) {
+ foreach my $source ($self->all_storages) {
+ $source->debugfh(@_);
+ }
+ }
+ return $self->master->debugfh;
+}
+
+=head2 debugcb
+
+set a debug callback across all storages
+
+=cut
+
+sub debugcb {
+ my $self = shift @_;
+ if(@_) {
+ foreach my $source ($self->all_storages) {
+ $source->debugcb(@_);
+ }
+ }
+ return $self->master->debugcb;
}
-sub debugfh { shift->_not_supported( 'debugfh' ) };
-sub debugcb { shift->_not_supported( 'debugcb' ) };
+=head2 disconnect
-sub _not_supported {
- my( $self, $method ) = @_;
+disconnect everything
+
+=cut
- die "This Storage does not support $method method.";
+sub disconnect {
+ my $self = shift @_;
+ foreach my $source ($self->all_storages) {
+ $source->disconnect(@_);
+ }
}
-=head1 SEE ALSO
+=head1 GOTCHAS
+
+Due to the fact that replicants can lag behind a master, you must take care to
+make sure you use one of the methods to force read queries to a master should
+you need realtime data integrity. For example, if you insert a row, and then
+immediately re-read it from the database (say, by doing $row->discard_changes)
+or you insert a row and then immediately build a query that expects that row
+to be an item, you should force the master to handle reads. Otherwise, due to
+the lag, there is no certainty your data will be in the expected state.
+
+For data integrity, all transactions automatically use the master storage for
+all read and write queries. Using a transaction is the preferred and recommended
+method to force the master to handle all read queries.
+
+Otherwise, you can force a single query to use the master with the 'force_pool'
+attribute:
-L<DBI::Class::Storage::DBI>, L<DBD::Multi>, L<DBI>
+ my $row = $resultset->search(undef, {force_pool=>'master'})->find($pk);
+
+This attribute will safely be ignore by non replicated storages, so you can use
+the same code for both types of systems.
+
+Lastly, you can use the L</execute_reliably> method, which works very much like
+a transaction.
+
+For debugging, you can turn replication on/off with the methods L</set_reliable_storage>
+and L</set_balanced_storage>, however this operates at a global level and is not
+suitable if you have a shared Schema object being used by multiple processes,
+such as on a web application server. You can get around this limitation by
+using the Schema clone method.
+
+ my $new_schema = $schema->clone;
+ $new_schema->set_reliable_storage;
+
+ ## $new_schema will use only the Master storage for all reads/writes while
+ ## the $schema object will use replicated storage.
=head1 AUTHOR
-Norbert Csongrádi <bert@cpan.org>
+ John Napiorkowski <john.napiorkowski@takkle.com>
-Peter Siklósi <einon@einon.hu>
+Based on code originated by:
-John Napiorkowski <john.napiorkowski@takkle.com>
+ Norbert Csongrádi <bert@cpan.org>
+ Peter Siklósi <einon@einon.hu>
=head1 LICENSE
=cut
+__PACKAGE__->meta->make_immutable;
+
1;
--- /dev/null
+package DBIx::Class::Storage::DBI::Replicated::Balancer;
+
+use Moose::Role;
+requires 'next_storage';
+
+=head1 NAME
+
+DBIx::Class::Storage::DBI::Replicated::Balancer; A Software Load Balancer
+
+=head1 SYNOPSIS
+
+This role is used internally by L<DBIx::Class::Storage::DBI::Replicated>.
+
+=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.
+
+=head2 auto_validate_every ($seconds)
+
+If auto_validate has some sort of value, run the L<validate_replicants> every
+$seconds. Be careful with this, because if you set it to 0 you will end up
+validating every query.
+
+=cut
+
+has 'auto_validate_every' => (
+ is=>'rw',
+ isa=>'Int',
+ predicate=>'has_auto_validate_every',
+);
+
+=head2 master
+
+The L<DBIx::Class::Storage::DBI> object that is the master database all the
+replicants are trying to follow. The balancer needs to know it since it's the
+ultimate fallback.
+
+=cut
+
+has 'master' => (
+ is=>'ro',
+ isa=>'DBIx::Class::Storage::DBI',
+ required=>1,
+);
+
+=head2 pool
+
+The L<DBIx::Class::Storage::DBI::Replicated::Pool> object that we are trying to
+balance.
+
+=cut
+
+has 'pool' => (
+ is=>'ro',
+ isa=>'DBIx::Class::Storage::DBI::Replicated::Pool',
+ required=>1,
+);
+
+=head2 current_replicant
+
+Replicant storages (slaves) handle all read only traffic. The assumption is
+that your database will become readbound well before it becomes write bound
+and that being able to spread your read only traffic around to multiple
+databases is going to help you to scale traffic.
+
+This attribute returns the next slave to handle a read request. Your L</pool>
+attribute has methods to help you shuffle through all the available replicants
+via it's balancer object.
+
+=cut
+
+has 'current_replicant' => (
+ is=> 'rw',
+ isa=>'DBIx::Class::Storage::DBI',
+ lazy_build=>1,
+ handles=>[qw/
+ select
+ select_single
+ columns_info_for
+ /],
+);
+
+=head1 METHODS
+
+This class defines the following methods.
+
+=head2 _build_current_replicant
+
+Lazy builder for the L</current_replicant_storage> attribute.
+
+=cut
+
+sub _build_current_replicant {
+ my $self = shift @_;
+ $self->next_storage;
+}
+
+=head2 next_storage
+
+This method should be defined in the class which consumes this role.
+
+Given a pool object, return the next replicant that will serve queries. The
+default behavior is to grap the first replicant it finds but you can write
+your own subclasses of L<DBIx::Class::Storage::DBI::Replicated::Balancer> to
+support other balance systems.
+
+This returns from the pool of active replicants. If there are no active
+replicants, then you should have it return the master as an ultimate fallback.
+
+=head2 around: next_storage
+
+Advice on next storage to add the autovalidation. We have this broken out so
+that it's easier to break out the auto validation into a role.
+
+This also returns the master in the case that none of the replicants are active
+or just just forgot to create them :)
+
+=cut
+
+around 'next_storage' => sub {
+ my ($next_storage, $self, @args) = @_;
+ my $now = time;
+
+ ## Do we need to validate the replicants?
+ if(
+ $self->has_auto_validate_every &&
+ ($self->auto_validate_every + $self->pool->last_validated) <= $now
+ ) {
+ $self->pool->validate_replicants;
+ }
+
+ ## Get a replicant, or the master if none
+ if(my $next = $self->$next_storage(@args)) {
+ return $next;
+ } else {
+ return $self->master;
+ }
+};
+
+=head2 increment_storage
+
+Rolls the Storage to whatever is next in the queue, as defined by the Balancer.
+
+=cut
+
+sub increment_storage {
+ my $self = shift @_;
+ my $next_replicant = $self->next_storage;
+ $self->current_replicant($next_replicant);
+}
+
+=head2 around: select
+
+Advice on the select attribute. Each time we use a replicant
+we need to change it via the storage pool algorithm. That way we are spreading
+the load evenly (hopefully) across existing capacity.
+
+=cut
+
+around 'select' => sub {
+ my ($select, $self, @args) = @_;
+
+ if (my $forced_pool = $args[-1]->{force_pool}) {
+ delete $args[-1]->{force_pool};
+ return $self->_get_forced_pool($forced_pool)->select(@args);
+ } else {
+ $self->increment_storage;
+ return $self->$select(@args);
+ }
+};
+
+=head2 around: select_single
+
+Advice on the select_single attribute. Each time we use a replicant
+we need to change it via the storage pool algorithm. That way we are spreading
+the load evenly (hopefully) across existing capacity.
+
+=cut
+
+around 'select_single' => sub {
+ my ($select_single, $self, @args) = @_;
+
+ if (my $forced_pool = $args[-1]->{force_pool}) {
+ delete $args[-1]->{force_pool};
+ return $self->_get_forced_pool($forced_pool)->select_single(@args);
+ } else {
+ $self->increment_storage;
+ return $self->$select_single(@args);
+ }
+};
+
+=head2 before: columns_info_for
+
+Advice on the current_replicant_storage attribute. Each time we use a replicant
+we need to change it via the storage pool algorithm. That way we are spreading
+the load evenly (hopefully) across existing capacity.
+
+=cut
+
+before 'columns_info_for' => sub {
+ my $self = shift @_;
+ $self->increment_storage;
+};
+
+=head2 _get_forced_pool ($name)
+
+Given an identifier, find the most correct storage object to handle the query.
+
+=cut
+
+sub _get_forced_pool {
+ my ($self, $forced_pool) = @_;
+ if(blessed $forced_pool) {
+ return $forced_pool;
+ } elsif($forced_pool eq 'master') {
+ return $self->master;
+ } elsif(my $replicant = $self->pool->replicants($forced_pool)) {
+ return $replicant;
+ } else {
+ $self->master->throw_exception("$forced_pool is not a named replicant.");
+ }
+}
+
+=head1 AUTHOR
+
+John Napiorkowski <john.napiorkowski@takkle.com>
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
+
+=cut
+
+1;
--- /dev/null
+package DBIx::Class::Storage::DBI::Replicated::Balancer::First;
+
+use Moose;
+with 'DBIx::Class::Storage::DBI::Replicated::Balancer';
+
+=head1 NAME
+
+DBIx::Class::Storage::DBI::Replicated::Balancer::First; Just get the First 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.
+
+This Balancer just get's whatever is the first replicant in the pool
+
+=head1 ATTRIBUTES
+
+This class defines the following attributes.
+
+=head1 METHODS
+
+This class defines the following methods.
+
+=head2 next_storage
+
+Just get the first storage. Probably only good when you have one replicant.
+
+=cut
+
+sub next_storage {
+ return (shift->pool->active_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
+
+__PACKAGE__->meta->make_immutable;
+
+1;
\ No newline at end of file
--- /dev/null
+package DBIx::Class::Storage::DBI::Replicated::Balancer::Random;
+
+use Moose;
+with 'DBIx::Class::Storage::DBI::Replicated::Balancer';
+
+=head1 NAME
+
+DBIx::Class::Storage::DBI::Replicated::Balancer::Random; A 'random' 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.
+
+This Balancer uses L<List::Util> keyword 'shuffle' to randomly pick an active
+replicant from the associated pool. This may or may not be random enough for
+you, patches welcome.
+
+=head1 ATTRIBUTES
+
+This class defines the following attributes.
+
+=head1 METHODS
+
+This class defines the following methods.
+
+=head2 next_storage
+
+Returns an active replicant at random. Please note that due to the nature of
+the word 'random' this means it's possible for a particular active replicant to
+be requested several times in a row.
+
+=cut
+
+sub next_storage {
+ my $self = shift @_;
+ my @active_replicants = $self->pool->active_replicants;
+ my $count_active_replicants = $#active_replicants +1;
+ my $random_replicant = int(rand($count_active_replicants));
+
+ return $active_replicants[$random_replicant];
+}
+
+=head1 AUTHOR
+
+John Napiorkowski <john.napiorkowski@takkle.com>
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
+
+=cut
+
+__PACKAGE__->meta->make_immutable;
+
+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 maximum_lag ($num)
+
+This is a number which defines the maximum allowed lag returned by the
+L<DBIx::Class::Storage::DBI/lag_behind_master> method. The default is 0. In
+general, this should return a larger number when the replicant is lagging
+behind it's master, however the implementation of this is database specific, so
+don't count on this number having a fixed meaning. For example, MySQL will
+return a number of seconds that the replicating database is lagging.
+
+=cut
+
+has 'maximum_lag' => (
+ 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)
+
+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',
+ 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]',
+ 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 connect_replicants ($schema, 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 connect_replicants {
+ my $self = shift @_;
+ my $schema = shift @_;
+
+ my @newly_created = ();
+ foreach my $connect_info (@_) {
+ my $replicant = $self->connect_replicant($schema, $connect_info);
+ my ($key) = ($connect_info->[0]=~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);
+ $replicant->ensure_connected;
+ DBIx::Class::Storage::DBI::Replicated::Replicant->meta->apply($replicant);
+
+ return $replicant;
+}
+
+=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 active_replicants
+
+This is an array of replicants that are considered to be active in the pool.
+This does not check to see if they are connected, but if they are not, DBIC
+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 );
+}
+
+=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};
+}
+
+=head2 validate_replicants
+
+This does a check to see if 1) each replicate is connected (or reconnectable),
+2) that is ->is_replicating, and 3) that it is not exceeding the lag amount
+defined by L</maximum_lag>. Replicants that fail any of these tests are set to
+inactive, and thus removed from the replication pool.
+
+This tests L<all_replicants>, since a replicant that has been previous marked
+as inactive can be reactived should it start to pass the validation tests again.
+
+See L<DBIx::Class::Storage::DBI> for more about checking if a replicating
+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.
+
+=cut
+
+sub validate_replicants {
+ my $self = shift @_;
+ foreach my $replicant($self->all_replicants) {
+ if(
+ $replicant->is_replicating &&
+ $replicant->lag_behind_master <= $self->maximum_lag &&
+ $replicant->ensure_connected
+ ) {
+ $replicant->active(1)
+ } else {
+ $replicant->active(0);
+ }
+ }
+ ## Mark that we completed this validation.
+ $self->_last_validated(time);
+}
+
+=head1 AUTHOR
+
+John Napiorkowski <john.napiorkowski@takkle.com>
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
+
+=cut
+
+__PACKAGE__->meta->make_immutable;
+
+1;
--- /dev/null
+package DBIx::Class::Storage::DBI::Replicated::Replicant;
+
+use Moose::Role;
+requires qw/_query_start/;
+
+=head1 NAME
+
+DBIx::Class::Storage::DBI::Replicated::Replicant; A replicated DBI Storage Role
+
+=head1 SYNOPSIS
+
+This class is used internally by L<DBIx::Class::Storage::DBI::Replicated>.
+
+=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.
+
+=head2 active
+
+This is a boolean which allows you to programmatically activate or deactivate a
+replicant from the pool. This way to you do stuff like disallow a replicant
+when it get's too far behind the master, if it stops replicating, etc.
+
+This attribute DOES NOT reflect a replicant's internal status, i.e. if it is
+properly replicating from a master and has not fallen too many seconds behind a
+reliability threshold. For that, use L</is_replicating> and L</lag_behind_master>.
+Since the implementation of those functions database specific (and not all DBIC
+supported DB's support replication) you should refer your database specific
+storage driver for more information.
+
+=cut
+
+has 'active' => (
+ is=>'rw',
+ isa=>'Bool',
+ lazy=>1,
+ required=>1,
+ default=>1,
+);
+
+=head1 METHODS
+
+This class defines the following methods.
+
+=head2 after: _query_start
+
+advice iof the _query_start method to add more debuggin
+
+=cut
+
+around '_query_start' => sub {
+ my ($method, $self, $sql, @bind) = @_;
+ my $dsn = $self->connect_info->[0];
+ $self->$method("DSN: $dsn SQL: $sql", @bind);
+};
+
+=head2 debugobj
+
+Override the debugobj method to redirect this method call back to the master.
+
+=cut
+
+sub debugobj {
+ return shift->schema->storage->debugobj;
+}
+
+=head1 ALSO SEE
+
+L<<a href="http://en.wikipedia.org/wiki/Replicant">http://en.wikipedia.org/wiki/Replicant</a>>
+
+=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
$self->dbh->do("ROLLBACK TO SAVEPOINT $name")
}
+
+sub is_replicating {
+ my $status = shift->dbh->selectrow_hashref('show slave status');
+ return ($status->{Slave_IO_Running} eq 'Yes') && ($status->{Slave_SQL_Running} eq 'Yes');
+}
+
+sub lag_behind_master {
+ return shift->dbh->selectrow_hashref('show slave status')->{Seconds_Behind_Master};
+}
1;
my $othertable = $source->related_source($rel);
my $rel_table = $othertable->name;
+ # Force the order of @cond to match the order of ->add_columns
+ my $idx;
+ my %other_columns_idx = map {'foreign.'.$_ => ++$idx } $othertable->columns;
+ my @cond = sort { $other_columns_idx{$a} cmp $other_columns_idx{$b} } keys(%{$rel_info->{cond}});
+
# Get the key information, mapping off the foreign/self markers
- my @cond = keys(%{$rel_info->{cond}});
my @refkeys = map {/^\w+\.(\w+)$/} @cond;
my @keys = map {$rel_info->{cond}->{$_} =~ /^\w+\.(\w+)$/} @cond;
'DBIx::Class::Schema::Versioned' => { ignore => [ qw(connection) ] },
-# must kill authors.
-
- 'DBIx::Class::Storage::DBI::Replicated' => { skip => 1 },
+# don't bother since it's heavily deprecated
+ 'DBIx::Class::ResultSetManager' => { skip => 1 },
};
foreach my $module (@modules) {
# clean up our mess
END {
- $dbh->do("DROP TABLE artist") if $dbh;
-}
+ #$dbh->do("DROP TABLE artist") if $dbh;
+}
\ No newline at end of file
$schema->storage->debug(1);
my $tree_like =
- $schema->resultset('TreeLike')->find(4,
+ $schema->resultset('TreeLike')->find(5,
{ join => { parent => { parent => 'parent' } },
prefetch => { parent => { parent => 'parent' } } });
cmp_ok($queries, '==', 1, 'Only one query run');
-$tree_like = $schema->resultset('TreeLike')->search({'me.id' => 1});
+$tree_like = $schema->resultset('TreeLike')->search({'me.id' => 2});
$tree_like = $tree_like->search_related('children')->search_related('children')->search_related('children')->first;
is($tree_like->name, 'quux', 'Tree search_related ok');
$tree_like = $schema->resultset('TreeLike')->search_related('children',
- { 'children.id' => 2, 'children_2.id' => 3 },
+ { 'children.id' => 3, 'children_2.id' => 4 },
{ prefetch => { children => 'children' } }
)->first;
is(eval { $tree_like->children->first->children->first->name }, 'quux',
'Tree search_related with prefetch ok');
$tree_like = eval { $schema->resultset('TreeLike')->search(
- { 'children.id' => 2, 'children_2.id' => 5 },
+ { 'children.id' => 3, 'children_2.id' => 6 },
{ join => [qw/children children/] }
- )->search_related('children', { 'children_4.id' => 6 }, { prefetch => 'children' }
+ )->search_related('children', { 'children_4.id' => 7 }, { prefetch => 'children' }
)->first->children->first; };
is(eval { $tree_like->name }, 'fong', 'Tree with multiple has_many joins ok');
fourkeys_to_twokeys => [
{
'display' => 'fourkeys_to_twokeys->twokeys',
- 'name' => 'fourkeys_to_twokeys_fk_t_cd_t_artist', 'index_name' => 'fourkeys_to_twokeys_idx_t_cd_t_artist',
+ 'name' => 'fourkeys_to_twokeys_fk_t_artist_t_cd', 'index_name' => 'fourkeys_to_twokeys_idx_t_artist_t_cd',
'selftable' => 'fourkeys_to_twokeys', 'foreigntable' => 'twokeys',
'selfcols' => ['t_artist', 't_cd'], 'foreigncols' => ['artist', 'cd'],
on_delete => 'CASCADE', on_update => 'CASCADE', deferrable => 1,
},
{
- 'display' => 'fourkeys_to_twokeys->fourkeys', 'index_name' => 'fourkeys_to_twokeys_idx_f_foo_f_goodbye_f_hello_f_bar',
- 'name' => 'fourkeys_to_twokeys_fk_f_foo_f_goodbye_f_hello_f_bar',
+ 'display' => 'fourkeys_to_twokeys->fourkeys', 'index_name' => 'fourkeys_to_twokeys_idx_f_foo_f_bar_f_hello_f_goodbye',
+ 'name' => 'fourkeys_to_twokeys_fk_f_foo_f_bar_f_hello_f_goodbye',
'selftable' => 'fourkeys_to_twokeys', 'foreigntable' => 'fourkeys',
'selfcols' => [qw(f_foo f_bar f_hello f_goodbye)],
'foreigncols' => [qw(foo bar hello goodbye)],
'display' => 'forceforeign->artist',
'name' => 'forceforeign_fk_artist', 'index_name' => 'forceforeign_idx_artist',
'selftable' => 'forceforeign', 'foreigntable' => 'artist',
- 'selfcols' => ['artist'], 'foreigncols' => ['artist_id'],
+ 'selfcols' => ['artist'], 'foreigncols' => ['artistid'],
on_delete => '', on_update => '', deferrable => 1,
},
],
use warnings;
use lib qw(t/lib);
use Test::More;
+use Test::Exception;
+use DBICTest;
BEGIN {
- eval "use DBD::Multi";
+ eval "use Moose; use Test::Moose";
plan $@
- ? ( skip_all => 'needs DBD::Multi for testing' )
- : ( tests => 20 );
-}
+ ? ( skip_all => 'needs Moose for testing' )
+ : ( tests => 79 );
+}
+
+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';
+
+=head1 HOW TO USE
+
+ This is a test of the replicated storage system. This will work in one of
+ two ways, either it was try to fake replication with a couple of SQLite DBs
+ and creative use of copy, or if you define a couple of %ENV vars correctly
+ will try to test those. If you do that, it will assume the setup is properly
+ replicating. Your results may vary, but I have demonstrated this to work with
+ mysql native replication.
+
+=cut
+
## ----------------------------------------------------------------------------
## Build a class to hold all our required testing data and methods.
## ----------------------------------------------------------------------------
-TESTSCHEMACLASS: {
-
- package DBIx::Class::DBI::Replicated::TestReplication;
-
- use DBI;
- use DBICTest;
- use File::Copy;
-
- ## Create a constructor
-
+TESTSCHEMACLASSES: {
+
+ ## --------------------------------------------------------------------- ##
+ ## Create an object to contain your replicated stuff.
+ ## --------------------------------------------------------------------- ##
+
+ package DBIx::Class::DBI::Replicated::TestReplication;
+
+ use DBICTest;
+ use base qw/Class::Accessor::Fast/;
+
+ __PACKAGE__->mk_accessors( qw/schema/ );
+
+ ## Initialize the object
+
sub new {
- my $class = shift @_;
- my %params = @_;
-
- my $self = bless {
- db_paths => $params{db_paths},
- dsns => $class->init_dsns(%params),
- schema=>$class->init_schema,
- }, $class;
-
- $self->connect;
- return $self;
- }
-
- ## get the DSNs. We build this up from the list of file paths
-
- sub init_dsns {
- my $class = shift @_;
- my %params = @_;
- my $db_paths = $params{db_paths};
-
- my @dsn = map {
- "dbi:SQLite:${_}";
- } @$db_paths;
-
- return \@dsn;
- }
-
- ## get the Schema and set the replication storage type
-
- sub init_schema {
- my $class = shift @_;
- my $schema = DBICTest->init_schema();
- $schema->storage_type( '::DBI::Replicated' );
-
- return $schema;
- }
-
- ## connect the Schema
-
- sub connect {
- my $self = shift @_;
- my ($master, @slaves) = @{$self->{dsns}};
- my $master_connect_info = [$master, '','', {AutoCommit=>1, PrintError=>0}];
-
- my @slavesob;
- foreach my $slave (@slaves)
- {
- my $dbh = shift @{$self->{slaves}}
- || DBI->connect($slave,"","",{PrintError=>0, PrintWarn=>0});
-
- push @{$master_connect_info->[-1]->{slaves_connect_info}},
- [$dbh, '','',{priority=>10}];
-
- push @slavesob,
- $dbh;
- }
-
- ## Keep track of the created slave databases
- $self->{slaves} = \@slavesob;
-
- $self
- ->{schema}
- ->connect(@$master_connect_info);
- }
-
- ## replication
+ my $class = shift @_;
+ my $self = $class->SUPER::new(@_);
- sub replicate {
- my $self = shift @_;
- my ($master, @slaves) = @{$self->{db_paths}};
-
- foreach my $slave (@slaves) {
- copy($master, $slave);
- }
- }
-
- ## Cleanup afer ourselves.
-
- sub cleanup {
- my $self = shift @_;
- my ($master, @slaves) = @{$self->{db_paths}};
-
- foreach my $slave (@slaves) {
- unlink $slave;
- }
+ $self->schema( $self->init_schema );
+ return $self;
}
+
+ ## Get the Schema and set the replication storage type
+
+ sub init_schema {
+ my $class = shift @_;
+
+ my $schema = DBICTest->init_schema(
+ storage_type=>{
+ '::DBI::Replicated' => {
+ balancer_type=>'::Random',
+ balancer_args=>{
+ auto_validate_every=>100,
+ },
+ }
+ },
+ deploy_args=>{
+ add_drop_table => 1,
+ },
+ );
+
+ return $schema;
+ }
+
+ sub generate_replicant_connect_info {}
+ sub replicate {}
+ sub cleanup {}
+
+
+ ## --------------------------------------------------------------------- ##
+ ## Subclass for when you are using SQLite for testing, this provides a fake
+ ## replication support.
+ ## --------------------------------------------------------------------- ##
+
+ package DBIx::Class::DBI::Replicated::TestReplication::SQLite;
+
+ use DBICTest;
+ use File::Copy;
+ use base 'DBIx::Class::DBI::Replicated::TestReplication';
+
+ __PACKAGE__->mk_accessors( qw/master_path slave_paths/ );
+
+ ## Set the mastep path from DBICTest
+
+ sub new {
+ my $class = shift @_;
+ my $self = $class->SUPER::new(@_);
- ## Force a reconnection
+ $self->master_path( DBICTest->_sqlite_dbfilename );
+ $self->slave_paths([
+ "t/var/DBIxClass_slave1.db",
+ "t/var/DBIxClass_slave2.db",
+ ]);
+
+ return $self;
+ }
- sub reconnect {
- my $self = shift @_;
- my $schema = $self->connect;
- $self->{schema} = $schema;
- 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 { [$_,'','',{AutoCommit=>1}] } @dsn;
+ }
+
+ ## Do a 'good enough' replication by copying the master dbfile over each of
+ ## the slave dbfiles. If the master is SQLite we do this, otherwise we
+ ## just do a one second pause to let the slaves catch up.
+
+ 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;
+ }
+ }
+
+ ## --------------------------------------------------------------------- ##
+ ## Subclass for when you are setting the databases via custom export vars
+ ## This is for when you have a replicating database setup that you are
+ ## going to test against. You'll need to define the correct $ENV and have
+ ## two slave databases to test against, as well as a replication system
+ ## that will replicate in less than 1 second.
+ ## --------------------------------------------------------------------- ##
+
+ package DBIx::Class::DBI::Replicated::TestReplication::Custom;
+ use base 'DBIx::Class::DBI::Replicated::TestReplication';
+
+ ## 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 {
+ return (
+ [$ENV{"DBICTEST_SLAVE0_DSN"}, $ENV{"DBICTEST_SLAVE0_DBUSER"}, $ENV{"DBICTEST_SLAVE0_DBPASS"}, {AutoCommit => 1}],
+ [$ENV{"DBICTEST_SLAVE1_DSN"}, $ENV{"DBICTEST_SLAVE1_DBUSER"}, $ENV{"DBICTEST_SLAVE1_DBPASS"}, {AutoCommit => 1}],
+ );
+ }
+
+ ## pause a bit to let the replication catch up
+
+ sub replicate {
+ sleep 1;
+ }
}
## ----------------------------------------------------------------------------
## 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",
- ],
-);
-
-ok my $replicate = DBIx::Class::DBI::Replicated::TestReplication->new(%params)
- => 'Created a replication object';
-
-isa_ok $replicate->{schema}
- => 'DBIx::Class::Schema';
+## Thi first bunch of tests are basic, just make sure all the bits are behaving
+
+my $replicated_class = DBICTest->has_custom_dsn ?
+ 'DBIx::Class::DBI::Replicated::TestReplication::Custom' :
+ 'DBIx::Class::DBI::Replicated::TestReplication::SQLite';
+
+ok my $replicated = $replicated_class->new
+ => 'Created a replication object';
+
+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';
+
+does_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->connect_replicants(@replicant_connects)
+ => 'Created some storages suitable for replicants';
+
+isa_ok $replicated->schema->storage->balancer->current_replicant
+ => 'DBIx::Class::Storage::DBI';
+
+ok $replicated->schema->storage->pool->has_replicants
+ => 'does have replicants';
+
+is $replicated->schema->storage->pool->num_replicants => 2
+ => 'has two replicants';
+
+does_ok $replicated_storages[0]
+ => 'DBIx::Class::Storage::DBI::Replicated::Replicant';
+
+does_ok $replicated_storages[1]
+ => 'DBIx::Class::Storage::DBI::Replicated::Replicant';
+
+my @replicant_names = keys %{$replicated->schema->storage->replicants};
+
+does_ok $replicated->schema->storage->replicants->{$replicant_names[0]}
+ => 'DBIx::Class::Storage::DBI::Replicated::Replicant';
+
+does_ok $replicated->schema->storage->replicants->{$replicant_names[1]}
+ => 'DBIx::Class::Storage::DBI::Replicated::Replicant';
## Add some info to the database
-$replicate
- ->{schema}
- ->populate('Artist', [
- [ qw/artistid name/ ],
- [ 4, "Ozric Tentacles"],
- ]);
-
+$replicated
+ ->schema
+ ->populate('Artist', [
+ [ qw/artistid name/ ],
+ [ 4, "Ozric Tentacles"],
+ ]);
+
## Make sure all the slaves have the table definitions
-$replicate->replicate;
+$replicated->replicate;
+$replicated->schema->storage->replicants->{$replicant_names[0]}->active(1);
+$replicated->schema->storage->replicants->{$replicant_names[1]}->active(1);
## Make sure we can read the data.
-ok my $artist1 = $replicate->{schema}->resultset('Artist')->find(4)
- => 'Created Result';
+ok my $artist1 = $replicated->schema->resultset('Artist')->find(4)
+ => 'Created Result';
isa_ok $artist1
- => 'DBICTest::Artist';
-
+ => 'DBICTest::Artist';
+
is $artist1->name, 'Ozric Tentacles'
- => 'Found expected name for first result';
+ => '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.
-$replicate
- ->{schema}
- ->populate('Artist', [
- [ qw/artistid name/ ],
- [ 5, "Doom's Children"],
- [ 6, "Dead On Arrival"],
- [ 7, "Watergate"],
- ]);
-
-## Reconnect the database
-$replicate->reconnect;
-
-## Alright, the database 'cluster' is not in a consistent state. When we do
-## a read now we expect bad news
-
-is $replicate->{schema}->resultset('Artist')->find(5), undef
- => 'read after disconnect fails because it uses slave 1 which we have neglected to "replicate" yet';
+$replicated
+ ->schema
+ ->populate('Artist', [
+ [ qw/artistid name/ ],
+ [ 5, "Doom's Children"],
+ [ 6, "Dead On Arrival"],
+ [ 7, "Watergate"],
+ ]);
## Make sure all the slaves have the table definitions
-$replicate->replicate;
+$replicated->replicate;
## Should find some data now
-ok my $artist2 = $replicate->{schema}->resultset('Artist')->find(5)
- => 'Sync succeed';
-
+ok my $artist2 = $replicated->schema->resultset('Artist')->find(5)
+ => 'Sync succeed';
+
isa_ok $artist2
- => 'DBICTest::Artist';
-
+ => 'DBICTest::Artist';
+
is $artist2->name, "Doom's Children"
- => 'Found expected name for first result';
-
-## What happens when we delete one of the slaves?
+ => 'Found expected name for first result';
-ok my $slave1 = @{$replicate->{slaves}}[0]
- => 'Got Slave1';
+## What happens when we disconnect all the replicants?
-ok $slave1->disconnect
- => 'disconnected slave1';
+is $replicated->schema->storage->pool->connected_replicants => 2
+ => "both replicants are connected";
+
+$replicated->schema->storage->replicants->{$replicant_names[0]}->disconnect;
+$replicated->schema->storage->replicants->{$replicant_names[1]}->disconnect;
-$replicate->reconnect;
+is $replicated->schema->storage->pool->connected_replicants => 0
+ => "both replicants are now disconnected";
-ok my $artist3 = $replicate->{schema}->resultset('Artist')->find(6)
- => 'Still finding stuff.';
-
+## All these should pass, since the database should automatically reconnect
+
+ok my $artist3 = $replicated->schema->resultset('Artist')->find(6)
+ => 'Still finding stuff.';
+
isa_ok $artist3
- => 'DBICTest::Artist';
-
+ => 'DBICTest::Artist';
+
is $artist3->name, "Dead On Arrival"
- => 'Found expected name for first result';
+ => 'Found expected name for first result';
+
+is $replicated->schema->storage->pool->connected_replicants => 1
+ => "One replicant reconnected to handle the job";
+
+## What happens when we try to select something that doesn't exist?
+
+ok ! $replicated->schema->resultset('Artist')->find(666)
+ => 'Correctly failed to find something.';
+
+## test the reliable option
+
+TESTRELIABLE: {
+
+ $replicated->schema->storage->set_reliable_storage;
+
+ ok $replicated->schema->resultset('Artist')->find(2)
+ => 'Read from master 1';
-## Let's delete all the slaves
+ ok $replicated->schema->resultset('Artist')->find(5)
+ => 'Read from master 2';
+
+ $replicated->schema->storage->set_balanced_storage;
+
+ ok $replicated->schema->resultset('Artist')->find(3)
+ => 'Read from replicant';
+}
-ok my $slave2 = @{$replicate->{slaves}}[1]
- => 'Got Slave2';
+## Make sure when reliable goes out of scope, we are using replicants again
+
+ok $replicated->schema->resultset('Artist')->find(1)
+ => 'back to replicant 1.';
+
+ok $replicated->schema->resultset('Artist')->find(2)
+ => 'back to replicant 2.';
+
+## set all the replicants to inactive, and make sure the balancer falls back to
+## the master.
+
+$replicated->schema->storage->replicants->{$replicant_names[0]}->active(0);
+$replicated->schema->storage->replicants->{$replicant_names[1]}->active(0);
+
+ok $replicated->schema->resultset('Artist')->find(2)
+ => 'Fallback to master';
+
+$replicated->schema->storage->replicants->{$replicant_names[0]}->active(1);
+$replicated->schema->storage->replicants->{$replicant_names[1]}->active(1);
+
+ok $replicated->schema->resultset('Artist')->find(2)
+ => 'Returned to replicates';
+
+## Getting slave status tests
+
+SKIP: {
+ ## We skip this tests unless you have a custom replicants, since the default
+ ## sqlite based replication tests don't support these functions.
+
+ skip 'Cannot Test Replicant Status on Non Replicating Database', 9
+ unless DBICTest->has_custom_dsn && $ENV{"DBICTEST_SLAVE0_DSN"};
+
+ $replicated->replicate; ## Give the slaves a chance to catchup.
+
+ ok $replicated->schema->storage->replicants->{$replicant_names[0]}->is_replicating
+ => 'Replicants are replicating';
+
+ is $replicated->schema->storage->replicants->{$replicant_names[0]}->lag_behind_master, 0
+ => 'Replicant is zero seconds behind master';
+
+ ## Test the validate replicants
+
+ $replicated->schema->storage->pool->validate_replicants;
+
+ is $replicated->schema->storage->pool->active_replicants, 2
+ => 'Still have 2 replicants after validation';
+
+ ## Force the replicants to fail the validate test by required their lag to
+ ## be negative (ie ahead of the master!)
+
+ $replicated->schema->storage->pool->maximum_lag(-10);
+ $replicated->schema->storage->pool->validate_replicants;
+
+ is $replicated->schema->storage->pool->active_replicants, 0
+ => 'No way a replicant be be ahead of the master';
+
+ ## Let's be fair to the replicants again. Let them lag up to 5
+
+ $replicated->schema->storage->pool->maximum_lag(5);
+ $replicated->schema->storage->pool->validate_replicants;
+
+ is $replicated->schema->storage->pool->active_replicants, 2
+ => 'Both replicants in good standing again';
+
+ ## Check auto validate
+
+ is $replicated->schema->storage->balancer->auto_validate_every, 100
+ => "Got the expected value for auto validate";
+
+ ## This will make sure we auto validatge everytime
+ $replicated->schema->storage->balancer->auto_validate_every(0);
+
+ ## set all the replicants to inactive, and make sure the balancer falls back to
+ ## the master.
+
+ $replicated->schema->storage->replicants->{$replicant_names[0]}->active(0);
+ $replicated->schema->storage->replicants->{$replicant_names[1]}->active(0);
+
+ ## Ok, now when we go to run a query, autovalidate SHOULD reconnect
+
+ is $replicated->schema->storage->pool->active_replicants => 0
+ => "both replicants turned off";
+
+ ok $replicated->schema->resultset('Artist')->find(5)
+ => 'replicant reactivated';
+
+ is $replicated->schema->storage->pool->active_replicants => 2
+ => "both replicants reactivated";
+}
+
+## Test the reliably callback
+
+ok my $reliably = sub {
+
+ ok $replicated->schema->resultset('Artist')->find(5)
+ => 'replicant reactivated';
+
+} => 'created coderef properly';
-ok $slave2->disconnect
- => 'Disconnected slave2';
+$replicated->schema->storage->execute_reliably($reliably);
-$replicate->reconnect;
+## Try something with an error
-## We expect an error now, since all the slaves are dead
+ok my $unreliably = sub {
+
+ ok $replicated->schema->resultset('ArtistXX')->find(5)
+ => 'replicant reactivated';
+
+} => 'created coderef properly';
-eval {
- $replicate->{schema}->resultset('Artist')->find(4)->name;
-};
+throws_ok {$replicated->schema->storage->execute_reliably($unreliably)}
+ qr/Can't find source for ArtistXX/
+ => 'Bad coderef throws proper error';
+
+## Make sure replication came back
-ok $@ => 'Got error when trying to find artistid 4';
+ok $replicated->schema->resultset('Artist')->find(3)
+ => 'replicant reactivated';
+
+## make sure transactions are set to execute_reliably
-## This should also be an error
+ok my $transaction = sub {
+
+ my $id = shift @_;
+
+ $replicated
+ ->schema
+ ->populate('Artist', [
+ [ qw/artistid name/ ],
+ [ $id, "Children of the Grave"],
+ ]);
+
+ ok my $result = $replicated->schema->resultset('Artist')->find($id)
+ => 'Found expected artist';
+
+ ok my $more = $replicated->schema->resultset('Artist')->find(1)
+ => 'Found expected artist again';
+
+ return ($result, $more);
+
+} => 'Created a coderef properly';
+
+## Test the transaction with multi return
+{
+ ok my @return = $replicated->schema->txn_do($transaction, 666)
+ => 'did transaction';
+
+ is $return[0]->id, 666
+ => 'first returned value is correct';
+
+ is $return[1]->id, 1
+ => 'second returned value is correct';
+}
-eval {
- my $artist4 = $replicate->{schema}->resultset('Artist')->find(7);
-};
+## Test that asking for single return works
+{
+ ok my $return = $replicated->schema->txn_do($transaction, 777)
+ => 'did transaction';
+
+ is $return->id, 777
+ => 'first returned value is correct';
+}
-ok $@ => 'Got read errors after everything failed';
+## Test transaction returning a single value
-## make sure ->connect_info returns something sane
+{
+ ok my $result = $replicated->schema->txn_do(sub {
+ ok my $more = $replicated->schema->resultset('Artist')->find(1)
+ => 'found inside a transaction';
+ return $more;
+ }) => 'successfully processed transaction';
+
+ is $result->id, 1
+ => 'Got expected single result from transaction';
+}
-ok $replicate->{schema}->storage->connect_info
- => 'got something out of ->connect_info';
+## Make sure replication came back
-## Force a connection to the write source for testing.
+ok $replicated->schema->resultset('Artist')->find(1)
+ => 'replicant reactivated';
+
+## Test Discard changes
-$replicate->{schema}->storage($replicate->{schema}->storage->write_source);
+{
+ ok my $artist = $replicated->schema->resultset('Artist')->find(2)
+ => 'got an artist to test discard changes';
+
+ ok $artist->discard_changes
+ => 'properly discard changes';
+}
-## What happens when we do a find for something that doesn't exist?
+## Test some edge cases, like trying to do a transaction inside a transaction, etc
+
+{
+ ok my $result = $replicated->schema->txn_do(sub {
+ return $replicated->schema->txn_do(sub {
+ ok my $more = $replicated->schema->resultset('Artist')->find(1)
+ => 'found inside a transaction inside a transaction';
+ return $more;
+ });
+ }) => 'successfully processed transaction';
+
+ is $result->id, 1
+ => 'Got expected single result from transaction';
+}
-ok ! $replicate->{schema}->resultset('Artist')->find(666)
- => 'Correctly did not find a bad artist id';
+{
+ ok my $result = $replicated->schema->txn_do(sub {
+ return $replicated->schema->storage->execute_reliably(sub {
+ return $replicated->schema->txn_do(sub {
+ return $replicated->schema->storage->execute_reliably(sub {
+ ok my $more = $replicated->schema->resultset('Artist')->find(1)
+ => 'found inside crazy deep transactions and execute_reliably';
+ return $more;
+ });
+ });
+ });
+ }) => 'successfully processed transaction';
+
+ is $result->id, 1
+ => 'Got expected single result from transaction';
+}
+
+## Test the force_pool resultset attribute.
+
+{
+ ok my $artist_rs = $replicated->schema->resultset('Artist')
+ => 'got artist resultset';
+
+ ## Turn on Forced Pool Storage
+ ok my $reliable_artist_rs = $artist_rs->search(undef, {force_pool=>'master'})
+ => 'Created a resultset using force_pool storage';
+
+ ok my $artist = $reliable_artist_rs->find(2)
+ => 'got an artist result via force_pool storage';
+}
## Delete the old database files
-$replicate->cleanup;
+$replicated->cleanup;
my $schema = DBICTest->init_schema(
no_deploy=>1,
no_populate=>1,
+ storage_type=>'::DBI::Replicated',
+ storage_type_args=>{
+ balancer_type=>'DBIx::Class::Storage::DBI::Replicated::Balancer::Random'
+ },
);
This method removes the test SQLite database in t/var/DBIxClass.db
=cut
+sub has_custom_dsn {
+ return $ENV{"DBICTEST_DSN"} ? 1:0;
+}
+
+sub _sqlite_dbfilename {
+ return "t/var/DBIxClass.db";
+}
+
sub _database {
my $self = shift;
- my $db_file = "t/var/DBIxClass.db";
+ my $db_file = $self->_sqlite_dbfilename;
unlink($db_file) if -e $db_file;
unlink($db_file . "-journal") if -e $db_file . "-journal";
} else {
$schema = DBICTest::Schema->compose_namespace('DBICTest');
}
+ if( $args{storage_type}) {
+ $schema->storage_type($args{storage_type});
+ }
if ( !$args{no_connect} ) {
$schema = $schema->connect($self->_database);
- $schema->storage->on_connect_do(['PRAGMA synchronous = OFF']);
+ $schema->storage->on_connect_do(['PRAGMA synchronous = OFF'])
+ unless $self->has_custom_dsn;
}
if ( !$args{no_deploy} ) {
- __PACKAGE__->deploy_schema( $schema );
- __PACKAGE__->populate_schema( $schema ) if( !$args{no_populate} );
+ __PACKAGE__->deploy_schema( $schema, $args{deploy_args} );
+ __PACKAGE__->populate_schema( $schema )
+ if( !$args{no_populate} );
}
return $schema;
}
sub deploy_schema {
my $self = shift;
my $schema = shift;
+ my $args = shift || {};
- if ($ENV{"DBICTEST_SQLT_DEPLOY"}) {
- return $schema->deploy();
+ if ($ENV{"DBICTEST_SQLT_DEPLOY"}) {
+ $schema->deploy($args);
} else {
open IN, "t/lib/sqlite.sql";
my $sql;
close IN;
($schema->storage->dbh->do($_) || print "Error on SQL: $_\n") for split(/;\n/, $sql);
}
+ return;
}
=head2 populate_schema
[ 1, 2 ],
[ 1, 3 ],
]);
-
+
$schema->populate('TreeLike', [
[ qw/id parent name/ ],
- [ 1, 0, 'foo' ],
- [ 2, 1, 'bar' ],
- [ 5, 1, 'blop' ],
- [ 3, 2, 'baz' ],
- [ 4, 3, 'quux' ],
- [ 6, 2, 'fong' ],
+ [ 1, undef, 'root' ],
+ [ 2, 1, 'foo' ],
+ [ 3, 2, 'bar' ],
+ [ 6, 2, 'blop' ],
+ [ 4, 3, 'baz' ],
+ [ 5, 4, 'quux' ],
+ [ 7, 3, 'fong' ],
]);
$schema->populate('Track', [
[ 1, "Tools" ],
[ 2, "Body Parts" ],
]);
-
- $schema->populate('CollectionObject', [
- [ qw/collection object/ ],
- [ 1, 1 ],
- [ 1, 2 ],
- [ 1, 3 ],
- [ 2, 4 ],
- [ 2, 5 ],
- ]);
-
+
$schema->populate('TypedObject', [
[ qw/objectid type value/ ],
[ 1, "pointy", "Awl" ],
[ 4, "pointy", "Tooth" ],
[ 5, "round", "Head" ],
]);
+ $schema->populate('CollectionObject', [
+ [ qw/collection object/ ],
+ [ 1, 1 ],
+ [ 1, 2 ],
+ [ 1, 3 ],
+ [ 2, 4 ],
+ [ 2, 5 ],
+ ]);
$schema->populate('Owners', [
[ qw/ownerid name/ ],
# since it uses the PK
__PACKAGE__->might_have(
'artist_1', 'DBICTest::Schema::Artist', {
- 'foreign.artist_id' => 'self.artist',
+ 'foreign.artistid' => 'self.artist',
}, {
is_foreign_key_constraint => 1,
},
__PACKAGE__->table('treelike');
__PACKAGE__->add_columns(
'id' => { data_type => 'integer', is_auto_increment => 1 },
- 'parent' => { data_type => 'integer' },
+ 'parent' => { data_type => 'integer' , is_nullable=>1},
'name' => { data_type => 'varchar',
size => 100,
},
{ 'foreign.id' => 'self.parent' });
__PACKAGE__->has_many('children', 'TreeLike', { 'foreign.parent' => 'self.id' });
+## since this is a self referential table we need to do a post deploy hook and get
+## some data in while constraints are off
+
+ sub sqlt_deploy_hook {
+ my ($self, $sqlt_table) = @_;
+
+ ## We don't seem to need this anymore, but keeping it for the moment
+ ## $sqlt_table->add_index(name => 'idx_name', fields => ['name']);
+ }
1;
);
__PACKAGE__->set_primary_key(qw/artist cd/);
-__PACKAGE__->belongs_to( artist => 'DBICTest::Schema::Artist' );
+__PACKAGE__->belongs_to(
+ artist => 'DBICTest::Schema::Artist',
+ {'foreign.artistid'=>'self.artist'},
+);
+
__PACKAGE__->belongs_to( cd => 'DBICTest::Schema::CD', undef, { is_deferrable => 0, add_fk_index => 0 } );
__PACKAGE__->has_many(
--
CREATE TABLE treelike (
id INTEGER PRIMARY KEY NOT NULL,
- parent integer NOT NULL,
+ parent integer NULL,
name varchar(100) NOT NULL
);