};
my $replicated = {
- %$moose_basic,
};
my $admin_basic = {
},
test_replicated => {
- req => {
- %$replicated,
- 'Test::Moose' => '0',
- },
+ req => $replicated,
},
-
admin => {
req => {
%$admin_basic,
package DBIx::Class::Storage::DBI::Replicated;
-
+
BEGIN {
use Carp::Clan qw/^DBIx::Class/;
use DBIx::Class;
unless DBIx::Class::Optional::Dependencies->req_ok_for ('replicated');
}
-use Moose;
+use Moo;
+use Role::Tiny ();
use DBIx::Class::Storage::DBI;
-use DBIx::Class::Storage::DBI::Replicated::Pool;
-use DBIx::Class::Storage::DBI::Replicated::Balancer;
-use DBIx::Class::Storage::DBI::Replicated::Types qw/BalancerClassNamePart DBICSchema DBICStorageDBI/;
-use MooseX::Types::Moose qw/ClassName HashRef Object/;
-use Scalar::Util 'reftype';
-use Hash::Merge;
-use List::Util qw/min max reduce/;
+use Scalar::Util qw(reftype blessed);
+use List::Util qw(min max reduce);
use Try::Tiny;
-use namespace::clean;
-
-use namespace::clean -except => 'meta';
+use Sub::Name 'subname';
+use Class::Inspector;
+use DBIx::Class::Storage::DBI::Replicated::Types
+ qw(DBICSchema DBICStorageDBI ClassName HashRef Object
+ DoesDBICStorageReplicatedBalancer DBICStorageDBIReplicatedPool Defined);
=head1 NAME
=cut
has 'schema' => (
- is=>'rw',
- isa=>DBICSchema,
- weak_ref=>1,
- required=>1,
+ is=>'rw',
+ isa=>DBICSchema,
+ weak_ref=>1,
+ required=>1,
);
=head2 pool_type
has 'pool_type' => (
is=>'rw',
isa=>ClassName,
- default=>'DBIx::Class::Storage::DBI::Replicated::Pool',
+ default=> sub { 'DBIx::Class::Storage::DBI::Replicated::Pool'},
handles=>{
'create_pool' => 'new',
},
has 'pool_args' => (
is=>'rw',
- isa=>HashRef,
+ isa =>HashRef,
lazy=>1,
default=>sub { {} },
);
has 'balancer_type' => (
is=>'rw',
- isa=>BalancerClassNamePart,
- coerce=>1,
- required=>1,
- default=> 'DBIx::Class::Storage::DBI::Replicated::Balancer::First',
- handles=>{
- 'create_balancer' => 'new',
- },
+ isa=>Defined,
+ default=>sub { 'DBIx::Class::Storage::DBI::Replicated::Balancer::First' },
);
+sub create_balancer {
+ my ($self, @args) = @_;
+ my $type = $self->balancer_type;
+ $type = 'DBIx::Class::Storage::DBI::Replicated::Balancer'.$type
+ if ($type=~m/^::/);
+ $self->schema->ensure_class_loaded($type);
+ return $type->new(@args);
+}
+
=head2 balancer_args
Contains a hashref of initialized information to pass to the Balancer object.
has 'balancer_args' => (
is=>'rw',
- isa=>HashRef,
+ isa =>HashRef,
lazy=>1,
- required=>1,
- default=>sub { {} },
+ default=>sub { +{} },
);
=head2 pool
has 'pool' => (
is=>'ro',
- isa=>'DBIx::Class::Storage::DBI::Replicated::Pool',
- lazy_build=>1,
+ isa =>DBICStorageDBIReplicatedPool,
+ lazy=>1,
+ builder=>'_build_pool',
+ clearer=>'clear_pool',
handles=>[qw/
connect_replicants
replicants
- has_replicants
/],
);
has 'balancer' => (
is=>'rw',
- isa=>'DBIx::Class::Storage::DBI::Replicated::Balancer',
- lazy_build=>1,
+ isa => DoesDBICStorageReplicatedBalancer,
+ lazy=>1,
+ builder=>'_build_balancer',
handles=>[qw/auto_validate_every/],
);
has 'master' => (
is=> 'ro',
- isa=>DBICStorageDBI,
- lazy_build=>1,
+ isa => DBICStorageDBI,
+ lazy=>1,
+ builder=>'_build_master',
);
=head1 ATTRIBUTES IMPLEMENTING THE DBIx::Storage::DBI INTERFACE
has 'read_handler' => (
is=>'rw',
isa=>Object,
- lazy_build=>1,
+ lazy=>1,
+ builder=>'_build_read_handler',
handles=>[qw/
select
select_single
has 'write_handler' => (
is=>'ro',
isa=>Object,
- lazy_build=>1,
+ lazy=>1,
+ builder=>'_build_write_handler',
handles=>[qw/
on_connect_do
on_disconnect_do
with_deferred_fk_checks
dbh_do
reload_row
- with_deferred_fk_checks
_prep_for_execute
backup
my @unimplemented = qw(
_arm_global_destructor
+ _preserve_foreign_dbh
_verify_pid
+ _verify_tid
get_use_dbms_capability
set_use_dbms_capability
_inner_join_to_node
_group_over_selection
- _prefetch_autovalues
_extract_order_criteria
- _max_column_bytesize
_is_lob_type
+ _max_column_bytesize
+ _prefetch_autovalues
);
# the capability framework
-# not sure if CMOP->initialize does evil things to DBIC::S::DBI, fix if a problem
push @unimplemented, ( grep
{ $_ =~ /^ _ (?: use | supports | determine_supports ) _ /x }
- ( Class::MOP::Class->initialize('DBIx::Class::Storage::DBI')->get_all_method_names )
+ @{Class::Inspector->methods('DBIx::Class::Storage::DBI')||[]}
);
for my $method (@unimplemented) {
- __PACKAGE__->meta->add_method($method, sub {
- croak "$method must not be called on ".(blessed shift).' objects';
- });
+ {
+ no strict qw/refs/;
+ *{__PACKAGE__ ."::$method"} = subname $method => sub {
+ croak "$method must not be called on ".(blessed shift).' objects';
+ };
+ }
}
-has _master_connect_info_opts =>
- (is => 'rw', isa => HashRef, default => sub { {} });
+has _master_connect_info_opts => (
+ is => 'rw',
+ isa =>HashRef ,
+ default => sub { +{} },
+);
=head2 around: connect_info
# Make sure master is blessed into the correct class and apply role to it.
my $master = $self->master;
$master->_determine_driver;
- Moose::Meta::Class->initialize(ref $master);
- DBIx::Class::Storage::DBI::Replicated::WithDSN->meta->apply($master);
+ ## Moose::Meta::Class->initialize(ref $master);
+ Role::Tiny->apply_roles_to_object($master, 'DBIx::Class::Storage::DBI::Replicated::WithDSN');
+ ## DBIx::Class::Storage::DBI::Replicated::WithDSN->meta->apply($master);
# link pool back to master
$self->pool->master($master);
This class defines the following methods.
-=head2 BUILDARGS
+=head2 new
L<DBIx::Class::Schema> when instantiating its storage passed itself as the
first argument. So we need to massage the arguments a bit so that all the
=cut
-sub BUILDARGS {
- my ($class, $schema, $storage_type_args, @args) = @_;
-
- return {
- schema=>$schema,
+around 'new', sub {
+ my ($orig, $class, $schema, $storage_type_args, @args) = @_;
+ return $orig->(
+ $class,
+ schema => $schema,
%$storage_type_args,
- @args
- }
-}
+ @args,
+ );
+};
=head2 _build_master
sub _build_master {
my $self = shift @_;
my $master = DBIx::Class::Storage::DBI->new($self->schema);
- $master
+ return $master;
}
=head2 _build_pool
=head1 AUTHOR
- John Napiorkowski <john.napiorkowski@takkle.com>
+ John Napiorkowski <jjnapiork@cpan.org>
Based on code originated by:
=cut
-__PACKAGE__->meta->make_immutable;
-
1;
package DBIx::Class::Storage::DBI::Replicated::Balancer;
-use Moose::Role;
+use Moo::Role;
+use Scalar::Util ();
+use DBIx::Class::Storage::DBI::Replicated::Types
+ qw(PositiveInteger DBICStorageDBI DBICStorageDBIReplicatedPool);
+
requires 'next_storage';
-use MooseX::Types::Moose qw/Int/;
-use DBIx::Class::Storage::DBI::Replicated::Pool;
-use DBIx::Class::Storage::DBI::Replicated::Types qw/DBICStorageDBI/;
-use namespace::clean -except => 'meta';
=head1 NAME
has 'auto_validate_every' => (
is=>'rw',
- isa=>Int,
+ isa=>PositiveInteger,
predicate=>'has_auto_validate_every',
+
);
=head2 master
has 'pool' => (
is=>'ro',
- isa=>'DBIx::Class::Storage::DBI::Replicated::Pool',
+ isa=>DBICStorageDBIReplicatedPool,
required=>1,
);
has 'current_replicant' => (
is=> 'rw',
isa=>DBICStorageDBI,
- lazy_build=>1,
+ lazy=>1,
+ builder=>'_build_current_replicant',
handles=>[qw/
select
select_single
=cut
sub _build_current_replicant {
- my $self = shift @_;
+ my $self = shift;
$self->next_storage;
}
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 :)
+or just just for?blgot to create them :)
=cut
=cut
sub increment_storage {
- my $self = shift @_;
+ my $self = shift;
my $next_replicant = $self->next_storage;
$self->current_replicant($next_replicant);
}
=cut
before 'columns_info_for' => sub {
- my $self = shift @_;
+ my $self = shift;
$self->increment_storage;
};
sub _get_forced_pool {
my ($self, $forced_pool) = @_;
- if(blessed $forced_pool) {
+ if(Scalar::Util::blessed($forced_pool)) {
return $forced_pool;
} elsif($forced_pool eq 'master') {
return $self->master;
package DBIx::Class::Storage::DBI::Replicated::Balancer::First;
-use Moose;
+use Moo;
with 'DBIx::Class::Storage::DBI::Replicated::Balancer';
-use namespace::clean -except => 'meta';
=head1 NAME
=head1 AUTHOR
-John Napiorkowski <john.napiorkowski@takkle.com>
+John Napiorkowski <jjnapiork@cpan.org>
=head1 LICENSE
=cut
-__PACKAGE__->meta->make_immutable;
-
1;
package DBIx::Class::Storage::DBI::Replicated::Balancer::Random;
-use Moose;
+use Moo;
+use DBIx::Class::Storage::DBI::Replicated::Types qw(PositiveNumber);
with 'DBIx::Class::Storage::DBI::Replicated::Balancer';
-use DBIx::Class::Storage::DBI::Replicated::Types 'Weight';
-use namespace::clean -except => 'meta';
=head1 NAME
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.
=cut
-has master_read_weight => (is => 'rw', isa => Weight, default => sub { 0 });
+has master_read_weight => (
+ is => 'rw',
+ isa => PositiveNumber(err => sub {"weight must be a positive number, not $_[0]"}),
+ default => sub { 0 },
+);
=head1 METHODS
=cut
sub next_storage {
- my $self = shift @_;
-
+ my $self = shift;
my @replicants = $self->pool->active_replicants;
if (not @replicants) {
return;
}
- my $master = $self->master;
-
+ my $master = $self->master;
my $rnd = $self->_random_number(@replicants + $self->master_read_weight);
return $rnd >= @replicants ? $master : $replicants[int $rnd];
}
sub _random_number {
- rand($_[1])
+ rand($_[1]);
}
=head1 AUTHOR
-John Napiorkowski <john.napiorkowski@takkle.com>
+John Napiorkowski <jjnapiork@cpan.org>
=head1 LICENSE
=cut
-__PACKAGE__->meta->make_immutable;
-
1;
package DBIx::Class::Storage::DBI::Replicated::Pool;
-use Moose;
-use DBIx::Class::Storage::DBI::Replicated::Replicant;
-use List::Util 'sum';
-use Scalar::Util 'reftype';
+use Moo;
+use Role::Tiny ();
+use List::Util ();
+use Scalar::Util qw(reftype);
use DBI ();
use Carp::Clan qw/^DBIx::Class/;
-use MooseX::Types::Moose qw/Num Int ClassName HashRef/;
-use DBIx::Class::Storage::DBI::Replicated::Types 'DBICStorageDBI';
use Try::Tiny;
-
-use namespace::clean -except => 'meta';
+use DBIx::Class::Storage::DBI::Replicated::Types
+ qw(PositiveInteger Number DBICStorageDBI ClassName HashRef);
=head1 NAME
has 'maximum_lag' => (
is=>'rw',
- isa=>Num,
- required=>1,
+ isa=>Number,
lazy=>1,
- default=>0,
+ default=>sub {0},
);
=head2 last_validated
has 'last_validated' => (
is=>'rw',
- isa=>Int,
- reader=>'last_validated',
- writer=>'_last_validated',
+ isa=>PositiveInteger,
lazy=>1,
- default=>0,
+ default=>sub {0},
);
=head2 replicant_type ($classname)
has 'replicant_type' => (
is=>'ro',
isa=>ClassName,
- required=>1,
- default=>'DBIx::Class::Storage::DBI',
+ default=> sub{'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
+A hashref of replicants, 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"
$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',
- traits => ['Hash'],
- isa=>HashRef['Object'],
- default=>sub {{}},
- handles => {
- 'set_replicant' => 'set',
- 'get_replicant' => 'get',
- 'has_replicants' => 'is_empty',
- 'num_replicants' => 'count',
- 'delete_replicant' => 'delete',
- 'all_replicant_storages' => 'values',
- },
+ is => 'rw',
+ isa => HashRef,
+ default => sub { +{} },
);
-around has_replicants => sub {
- my ($orig, $self) = @_;
- return !$self->$orig;
-};
-
has next_unknown_replicant_id => (
is => 'rw',
- traits => ['Counter'],
- isa => Int,
- default => 1,
- handles => {
- 'inc_unknown_replicant_id' => 'inc',
- },
+ isa=>PositiveInteger
+ default => sub { 1 },
);
+sub inc_unknown_replicant_id {
+ my $self = shift;
+ my $next = $self->next_unknown_replicant_id + 1;
+ $self->next_unknown_replicant_id($next);
+ return $next;
+}
+
=head2 master
Reference to the master Storage.
=cut
-has master => (is => 'rw', isa => DBICStorageDBI, weak_ref => 1);
+has master => (
+ is => 'rw',
+ isa =>DBICStorageDBI,
+ weak_ref => 1,
+);
=head1 METHODS
my $dsn;
my $replicant = do {
-# yes this is evil, but it only usually happens once (for coderefs)
-# this will fail if the coderef does not actually DBI::connect
+ ## yes this is evil, but it only usually happens once (for coderefs)
+ ## this will fail if the coderef does not actually DBI::connect
no warnings 'redefine';
my $connect = \&DBI::connect;
local *DBI::connect = sub {
($key) = ($dsn =~ m/^dbi\:.+\:(.+)$/i);
}
- $replicant->id($key);
- $self->set_replicant($key => $replicant);
+ if($key) {
+ $replicant->id($key);
+ } else {
+ $replicant->debugobj->print("Could not create an ID for the replicant!");
+ }
+
+ ## Add the new replicant to the list
+ $self->replicants({
+ $key => $replicant,
+ %{$self->replicants},
+ });
push @newly_created, $replicant;
}
my $replicant = $self->create_replicant($schema);
$replicant->connect_info($connect_info);
-## It is undesirable for catalyst to connect at ->conect_replicants time, as
+## It is undesirable for catalyst to connect at ->connect_replicants time, as
## connections should only happen on the first request that uses the database.
## So we try to set the driver without connecting, however this doesn't always
## work, as a driver may need to connect to determine the DB version, and this
$replicant->_determine_driver
});
- Moose::Meta::Class->initialize(ref $replicant);
-
- DBIx::Class::Storage::DBI::Replicated::Replicant->meta->apply($replicant);
+ Role::Tiny->apply_roles_to_object($replicant, 'DBIx::Class::Storage::DBI::Replicated::Replicant');
# link back to master
$replicant->master($self->master);
sub connected_replicants {
my $self = shift @_;
- return sum( map {
+ return List::Util::sum( map {
$_->connected ? 1:0
} $self->all_replicants );
}
}
}
## Mark that we completed this validation.
- $self->_last_validated(time);
+ $self->last_validated(time);
}
=head1 AUTHOR
-John Napiorkowski <john.napiorkowski@takkle.com>
+John Napiorkowski <jjnapiork@cpan.org>
=head1 LICENSE
=cut
-__PACKAGE__->meta->make_immutable;
-
1;
package DBIx::Class::Storage::DBI::Replicated::Replicant;
-use Moose::Role;
+use Moo::Role;
+use DBIx::Class::Storage::DBI::Replicated::Types
+ qw(Boolean DBICStorageDBI Defined);
+
requires qw/_query_start/;
with 'DBIx::Class::Storage::DBI::Replicated::WithDSN';
-use MooseX::Types::Moose qw/Bool Str/;
-use DBIx::Class::Storage::DBI::Replicated::Types 'DBICStorageDBI';
-
-use namespace::clean -except => 'meta';
=head1 NAME
has 'active' => (
is=>'rw',
- isa=>Bool,
+ isa=>Boolean,
lazy=>1,
required=>1,
- default=>1,
+ default=> sub {1},
);
-has dsn => (is => 'rw', isa => Str);
-has id => (is => 'rw', isa => Str);
+has dsn => (is => 'rw', isa => Defined(err=>sub{"'dsn' must be defined"}));
+has id => (is => 'rw', isa => Defined(err=>sub{"'id' must be defined"}));
=head2 master
=cut
-has master => (is => 'rw', isa => DBICStorageDBI, weak_ref => 1);
+has master => (
+ is => 'rw',
+ isa =>DBICStorageDBI,
+ weak_ref => 1,
+);
=head1 METHODS
=cut
sub debugobj {
- my $self = shift;
-
- return $self->master->debugobj;
+ (shift)->master->debugobj;
}
=head1 ALSO SEE
=head1 AUTHOR
-John Napiorkowski <john.napiorkowski@takkle.com>
+John Napiorkowski <jjnapiork@cpan.org>
=head1 LICENSE
package # hide from PAUSE
DBIx::Class::Storage::DBI::Replicated::Types;
-# DBIx::Class::Storage::DBI::Replicated::Types - Types used internally by
-# L<DBIx::Class::Storage::DBI::Replicated>
+use strict;
+use warnings;
+use Carp qw(confess);
-use MooseX::Types
- -declare => [qw/BalancerClassNamePart Weight DBICSchema DBICStorageDBI/];
-use MooseX::Types::Moose qw/ClassName Str Num/;
+use Scalar::Util qw(blessed looks_like_number reftype);
-class_type 'DBIx::Class::Storage::DBI';
-class_type 'DBIx::Class::Schema';
+sub import {
+ my ($package, @methods) = @_;
+ my $caller = caller;
+ for my $method (@methods) {
+ { no strict;
+ *{"${caller}::${method}"} = sub {
+ my %args = @_;
+ sub { my $value = shift; &{$method}($value, %args) }
+ };
+ }
+ }
+}
-subtype DBICSchema, as 'DBIx::Class::Schema';
-subtype DBICStorageDBI, as 'DBIx::Class::Storage::DBI';
+sub error {
+ my ($default, $value, %args) = @_;
+ if(my $err = $args{err}) {
+ confess $err->($value);
+ } else {
+ confess $default;
+ }
+}
-subtype BalancerClassNamePart,
- as ClassName;
+sub Defined {
+ error("Value $_[0] must be Defined", @_)
+ unless defined($_[0]);
+}
-coerce BalancerClassNamePart,
- from Str,
- via {
- my $type = $_;
- if($type=~m/^::/) {
- $type = 'DBIx::Class::Storage::DBI::Replicated::Balancer'.$type;
- }
- Class::MOP::load_class($type);
- $type;
- };
-
-subtype Weight,
- as Num,
- where { $_ >= 0 },
- message { 'weight must be a decimal greater than 0' };
-
-# AUTHOR
-#
-# John Napiorkowski <john.napiorkowski@takkle.com>
-#
-# LICENSE
-#
-# You may distribute this code under the same terms as Perl itself.
+sub UnDefined {
+ error("Value $_[0] must be UnDefined", @_)
+ unless !defined($_[0]);
+}
+
+sub Boolean {
+ error("$_[0] is not a valid Boolean", @_)
+ unless(!defined($_[0]) || $_[0] eq "" || "$_[0]" eq '1' || "$_[0]" eq '0');
+}
+
+sub Number {
+ error("weight must be a Number greater than or equal to 0, not $_[0]", @_)
+ unless(Defined(@_) && looks_like_number($_[0]));
+}
+
+sub Integer {
+ error("$_[0] must be an Integer", @_)
+ unless(Number(@_) && (int($_[0]) == $_[0]));
+}
+
+sub HashRef {
+ error("$_[0] must be a HashRef", @_)
+ unless(Defined(@_) && (reftype($_[0]) eq 'HASH'));
+}
+
+sub PositiveNumber {
+ error("value must be a Number greater than or equal to 0, not $_[0]", @_)
+ unless(Number(@_) && ($_[0] >= 0));
+}
+
+sub PositiveInteger {
+ error("Value must be a Number greater than or equal to 0, not $_[0]", @_)
+ unless(Integer(@_) && ($_[0] >= 0));
+}
+
+sub ClassName {
+ error("$_[0] is not a loaded Class", @_)
+ unless(Defined(@_) && ($_[0]->can('can')));
+}
+
+sub Object {
+ error("Value is not an Object", @_)
+ unless(Defined(@_) && blessed($_[0]));
+}
+
+sub DBICStorageDBI {
+ error("Need an Object of type DBIx::Class::Storage::DBI, not ".ref($_[0]), @_)
+ unless(Object(@_) && ($_[0]->isa('DBIx::Class::Storage::DBI')));
+}
+
+sub DBICStorageDBIReplicatedPool {
+ error("Need an Object of type DBIx::Class::Storage::DBI::Replicated::Pool, not ".ref($_[0]), @_)
+ unless(Object(@_) && ($_[0]->isa('DBIx::Class::Storage::DBI::Replicated::Pool')));
+}
+
+sub DBICSchema {
+ error("Need an Object of type DBIx::Class::Schema, not ".ref($_[0]), @_)
+ unless(Object(@_) && ($_[0]->isa('DBIx::Class::Schema')));
+}
+
+sub DoesDBICStorageReplicatedBalancer {
+ error("$_[0] does not do DBIx::Class::Storage::DBI::Replicated::Balancer", @_)
+ unless(Object(@_) && $_[0]->does('DBIx::Class::Storage::DBI::Replicated::Balancer') );
+}
1;
+
package DBIx::Class::Storage::DBI::Replicated::WithDSN;
-use Moose::Role;
-use Scalar::Util 'reftype';
+use Try::Tiny qw(try);
+use Scalar::Util ();
+use Role::Tiny;
requires qw/_query_start/;
-use Try::Tiny;
-use namespace::clean -except => 'meta';
-
=head1 NAME
DBIx::Class::Storage::DBI::Replicated::WithDSN - A DBI Storage Role with DSN
my $storage_type = $self->can('active') ? 'REPLICANT' : 'MASTER';
my $query = do {
- if ((reftype($dsn)||'') ne 'CODE') {
+ if ((Scalar::Util::reftype($dsn)||'') ne 'CODE') {
"$op [DSN_$storage_type=$dsn]$rest";
}
elsif (my $id = try { $self->id }) {
=head1 AUTHOR
-John Napiorkowski <john.napiorkowski@takkle.com>
+John Napiorkowski <jjnapiork@cpan.org>
=head1 LICENSE
use Test::More;
BEGIN {
- require DBIx::Class;
- plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_replicated')
- unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_replicated');
+ require DBIx::Class;
+ plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_replicated')
+ unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_replicated');
}
-use Test::Moose;
use Test::Exception;
use List::Util 'first';
use Scalar::Util 'reftype';
use File::Spec;
use IO::Handle;
-use Moose();
-use MooseX::Types();
-note "Using Moose version $Moose::VERSION and MooseX::Types version $MooseX::Types::VERSION";
+use Class::Inspector;
use lib qw(t/lib);
use DBICTest;
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.
+ replicating.
=cut
my $self = $class->SUPER::new(@_);
$self->schema( $self->init_schema($schema_method) );
+
return $self;
}
storage_type=> '::DBI::Replicated',
balancer_type=>'::Random',
balancer_args=> {
- auto_validate_every=>100,
- master_read_weight => 1
+ auto_validate_every=>100,
+ master_read_weight => 1
},
pool_args=>{
maximum_lag=>1,
## --------------------------------------------------------------------- ##
## Add a connect_info option to test option merging.
## --------------------------------------------------------------------- ##
+
{
package DBIx::Class::Storage::DBI::Replicated;
- use Moose;
-
- __PACKAGE__->meta->make_mutable;
-
+ use Moo;
around connect_info => sub {
my ($next, $self, $info) = @_;
$info->[3]{master_option} = 1;
$self->$next($info);
};
- __PACKAGE__->meta->make_immutable;
-
- no Moose;
+ no Moo;
}
## --------------------------------------------------------------------- ##
for my $method (qw/by_connect_info by_storage_type/) {
undef $replicated;
+
ok $replicated = $replicated_class->new($method)
=> "Created a replication object $method";
=> 'configured balancer_type';
}
-### check that all Storage::DBI methods are handled by ::Replicated
+## Check that all Storage::DBI methods are handled by ::Replicated
{
- my @storage_dbi_methods = Class::MOP::Class
- ->initialize('DBIx::Class::Storage::DBI')->get_all_method_names;
-
- my @replicated_methods = DBIx::Class::Storage::DBI::Replicated->meta
- ->get_all_method_names;
+ ## Get a bunch of methods to check
+ my @storage_dbi_methods = @{Class::Inspector->methods('DBIx::Class::Storage::DBI')||[]};
-# remove constants and OTHER_CRAP
+ ## remove constants and OTHER_CRAP
@storage_dbi_methods = grep !/^[A-Z_]+\z/, @storage_dbi_methods;
-# remove CAG accessors
+ ## remove CAG accessors
@storage_dbi_methods = grep !/_accessor\z/, @storage_dbi_methods;
-# remove DBIx::Class (the root parent, with CAG and stuff) methods
- my @root_methods = Class::MOP::Class->initialize('DBIx::Class')
- ->get_all_method_names;
- my %count;
- $count{$_}++ for (@storage_dbi_methods, @root_methods);
+ ## we need to exclude this stuff as well
+ my %root_methods = map { $_ => 1 } @{Class::Inspector->methods('DBIx::Class')};
- @storage_dbi_methods = grep $count{$_} != 2, @storage_dbi_methods;
+ @storage_dbi_methods = grep { !$root_methods{$_} } @storage_dbi_methods;
-# make hashes
- my %storage_dbi_methods;
- @storage_dbi_methods{@storage_dbi_methods} = ();
- my %replicated_methods;
- @replicated_methods{@replicated_methods} = ();
-
-# remove ::Replicated-specific methods
- for my $method (@replicated_methods) {
- delete $replicated_methods{$method}
- unless exists $storage_dbi_methods{$method};
+ ## anything missing?
+ my @missing_methods;
+ for my $method (@storage_dbi_methods) {
+ push @missing_methods, $method
+ unless $replicated->schema->storage->can($method);
}
- @replicated_methods = keys %replicated_methods;
-
-# check that what's left is implemented
- %count = ();
- $count{$_}++ for (@storage_dbi_methods, @replicated_methods);
- if ((grep $count{$_} == 2, @storage_dbi_methods) == @storage_dbi_methods) {
+ if(scalar(@missing_methods)) {
+ my $missing = join (',', @missing_methods);
+ fail "the following DBIx::Class::Storage::DBI methods are unimplemented: $missing";
+ } else {
pass 'all DBIx::Class::Storage::DBI methods implemented';
- }
- else {
- my @unimplemented = grep $count{$_} == 1, @storage_dbi_methods;
-
- fail 'the following DBIx::Class::Storage::DBI methods are unimplemented: '
- . "@unimplemented";
- }
+ }
}
-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 $replicated->schema->storage->balancer->does('DBIx::Class::Storage::DBI::Replicated::Balancer'),
+ 'does Balancer';
ok my @replicant_connects = $replicated->generate_replicant_connect_info
=> 'got replication connect information';
grep { (reftype($_)||'') eq 'HASH' }
map @{ $_->_connect_info }, @all_storages;
-is ((grep $_->{master_option}, @all_storage_opts),
- 3
- => 'connect_info was merged from master to replicants');
+ is ((grep $_->{master_option}, @all_storage_opts), 3,
+ 'connect_info was merged from master to replicants');
my @replicant_names = keys %{ $replicated->schema->storage->replicants };
$replicated->schema->storage->debugobj->silence(0);
-ok $replicated->schema->storage->pool->has_replicants
+ok scalar(keys(%{$replicated->schema->storage->pool->replicants}))
=> 'does have replicants';
-is $replicated->schema->storage->pool->num_replicants => 2
+is scalar(keys(%{$replicated->schema->storage->pool->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';
+ok $replicated_storages[0]->does('DBIx::Class::Storage::DBI::Replicated::Replicant'),
+ 'does Replicant';
+
+ok $replicated_storages[1]->does('DBIx::Class::Storage::DBI::Replicated::Replicant'),
+ 'does Replicant';
-does_ok $replicated->schema->storage->replicants->{$replicant_names[0]}
- => 'DBIx::Class::Storage::DBI::Replicated::Replicant';
+ok $replicated->schema->storage->replicants->{$replicant_names[0]}
+ ->does('DBIx::Class::Storage::DBI::Replicated::Replicant'),
+ 'Does Replicant';
-does_ok $replicated->schema->storage->replicants->{$replicant_names[1]}
- => 'DBIx::Class::Storage::DBI::Replicated::Replicant';
+ok $replicated->schema->storage->replicants->{$replicant_names[1]}
+ ->does('DBIx::Class::Storage::DBI::Replicated::Replicant'),
+ 'Does Replicant';
## Add some info to the database
projects / dbsrgits/DBIx-Class.git / commitdiff