From: Peter Rabbitson <ribasushi@cpan.org>
Date: Sat, 12 Mar 2011 22:58:13 +0000 (+0100)
Subject: Add startup sanity check of the ::DBI::Replicated method dispatch tables
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=4bea1fe7a2b4827947b3d0d64b16a0f2c5e594bd;p=dbsrgits%2FDBIx-Class-Historic.git

Add startup sanity check of the ::DBI::Replicated method dispatch tables

In order to do this during testing only introduce the ::_ENV_::DBICTEST macro,
and also make sure DBICTest::RunMode is loaded before the macro is set
(therefore the multiple test changes)
---

diff --git a/lib/DBIx/Class.pm b/lib/DBIx/Class.pm
index c150c3d..0649793 100644
--- a/lib/DBIx/Class.pm
+++ b/lib/DBIx/Class.pm
@@ -12,6 +12,12 @@ BEGIN {
     require mro;
     *DBIx::Class::_ENV_::OLD_MRO = sub () { 0 };
   }
+
+  # ::Runmode would only be loaded by DBICTest, which in turn implies t/
+  *DBIx::Class::_ENV_::DBICTEST = eval { DBICTest::RunMode->is_author }
+    ? sub () { 1 }
+    : sub () { 0 }
+  ;
 }
 
 use mro 'c3';
diff --git a/lib/DBIx/Class/Storage/DBI/Replicated.pm b/lib/DBIx/Class/Storage/DBI/Replicated.pm
index 87f5416..3162d81 100644
--- a/lib/DBIx/Class/Storage/DBI/Replicated.pm
+++ b/lib/DBIx/Class/Storage/DBI/Replicated.pm
@@ -240,39 +240,10 @@ has 'master' => (
 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
-    _dbh_columns_info_for
-    _select
-  /],
-);
-
-=head2 write_handler
-
-Defines an object that implements the write side of L<BIx::Class::Storage::DBI>,
-as well as methods that don't write or read that can be called on only one
-storage, methods that return a C<$dbh>, and any methods that don't make sense to
-run on a replicant.
-
 =cut
 
-has 'write_handler' => (
-  is=>'ro',
-  isa=>Object,
-  lazy_build=>1,
-  handles=>[qw/
+my $method_dispatch = {
+  writer => [qw/
     on_connect_do
     on_disconnect_do
     on_connect_call
@@ -302,11 +273,7 @@ has 'write_handler' => (
     deploy
     with_deferred_fk_checks
     dbh_do
-    reload_row
-    with_deferred_fk_checks
     _prep_for_execute
-
-    backup
     is_datatype_numeric
     _count_select
     _subq_update_delete
@@ -320,7 +287,6 @@ has 'write_handler' => (
     _dbi_connect_info
     _dbic_connect_attributes
     auto_savepoint
-    _sqlt_version_ok
     _query_end
     bind_attribute_by_data_type
     transaction_depth
@@ -329,7 +295,6 @@ has 'write_handler' => (
     _dbh_execute_array
     _sql_maker
     _query_start
-    _sqlt_version_error
     _per_row_update_delete
     _dbh_begin_work
     _dbh_execute_inserts_with_no_binds
@@ -342,7 +307,6 @@ has 'write_handler' => (
     _dbh_commit
     _execute_array
     savepoints
-    _sqlt_minimum_version
     _sql_maker_opts
     _conn_pid
     _dbh_autocommit
@@ -362,47 +326,109 @@ has 'write_handler' => (
     _dbh_sth
     _dbh_execute
   /],
-);
+  reader => [qw/
+    select
+    select_single
+    columns_info_for
+    _dbh_columns_info_for
+    _select
+  /],
+  unimplemented => [qw/
+    _arm_global_destructor
+    _verify_pid
+
+    get_use_dbms_capability
+    set_use_dbms_capability
+    get_dbms_capability
+    set_dbms_capability
+    _dbh_details
+    _dbh_get_info
+
+    sql_limit_dialect
+    sql_quote_char
+    sql_name_sep
+
+    _inner_join_to_node
+    _group_over_selection
+    _extract_order_criteria
+
+    _prefetch_autovalues
+
+    _max_column_bytesize
+    _is_lob_type
+    _is_binary_lob_type
+    _is_text_lob_type
+  /,(
+    # the capability framework
+    # not sure if CMOP->initialize does evil things to DBIC::S::DBI, fix if a problem
+    grep
+      { $_ =~ /^ _ (?: use | supports | determine_supports ) _ /x }
+      ( Class::MOP::Class->initialize('DBIx::Class::Storage::DBI')->get_all_method_names )
+  )],
+};
+
+if (DBIx::Class::_ENV_::DBICTEST) {
+
+  my $seen;
+  for my $type (keys %$method_dispatch) {
+    for (@{$method_dispatch->{$type}}) {
+      push @{$seen->{$_}}, $type;
+    }
+  }
 
-my @unimplemented = qw(
-  _arm_global_destructor
-  _verify_pid
+  if (my @dupes = grep { @{$seen->{$_}} > 1 } keys %$seen) {
+    die(join "\n", '',
+      'The following methods show up multiple times in ::Storage::DBI::Replicated handlers:',
+      (map { "$_: " . (join ', ', @{$seen->{$_}}) } sort @dupes),
+      '',
+    );
+  }
+
+  if (my @cant = grep { ! DBIx::Class::Storage::DBI->can($_) } keys %$seen) {
+    die(join "\n", '',
+      '::Storage::DBI::Replicated specifies handling of the following *NON EXISTING* ::Storage::DBI methods:',
+      @cant,
+      '',
+    );
+  }
+}
 
-  get_use_dbms_capability
-  set_use_dbms_capability
-  get_dbms_capability
-  set_dbms_capability
-  _dbh_details
-  _dbh_get_info
+for my $method (@{$method_dispatch->{unimplemented}}) {
+  __PACKAGE__->meta->add_method($method, sub {
+    croak "$method must not be called on ".(blessed shift).' objects';
+  });
+}
 
-  sql_limit_dialect
-  sql_quote_char
-  sql_name_sep
+=head2 read_handler
 
-  _inner_join_to_node
-  _group_over_selection
-  _extract_order_criteria
+Defines an object that implements the read side of L<BIx::Class::Storage::DBI>.
 
-  _prefetch_autovalues
+=cut
 
-  _max_column_bytesize
-  _is_lob_type
-  _is_binary_lob_type
-  _is_text_lob_type
+has 'read_handler' => (
+  is=>'rw',
+  isa=>Object,
+  lazy_build=>1,
+  handles=>$method_dispatch->{reader},
 );
 
-# 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 )
+=head2 write_handler
+
+Defines an object that implements the write side of L<BIx::Class::Storage::DBI>,
+as well as methods that don't write or read that can be called on only one
+storage, methods that return a C<$dbh>, and any methods that don't make sense to
+run on a replicant.
+
+=cut
+
+has 'write_handler' => (
+  is=>'ro',
+  isa=>Object,
+  lazy_build=>1,
+  handles=>$method_dispatch->{writer},
 );
 
-for my $method (@unimplemented) {
-  __PACKAGE__->meta->add_method($method, sub {
-    croak "$method must not be called on ".(blessed shift).' objects';
-  });
-}
+
 
 has _master_connect_info_opts =>
   (is => 'rw', isa => HashRef, default => sub { {} });
diff --git a/t/73oracle.t b/t/73oracle.t
index 45f6152..d41538b 100644
--- a/t/73oracle.t
+++ b/t/73oracle.t
@@ -1,3 +1,29 @@
+use strict;
+use warnings;
+
+use Test::Exception;
+use Test::More;
+use Sub::Name;
+
+use lib qw(t/lib);
+use DBICTest;
+use DBIC::SqlMakerTest;
+
+plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_rdbms_oracle')
+  unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_rdbms_oracle');
+
+$ENV{NLS_SORT} = "BINARY";
+$ENV{NLS_COMP} = "BINARY";
+$ENV{NLS_LANG} = "AMERICAN";
+
+my ($dsn,  $user,  $pass)  = @ENV{map { "DBICTEST_ORA_${_}" }  qw/DSN USER PASS/};
+
+# optional:
+my ($dsn2, $user2, $pass2) = @ENV{map { "DBICTEST_ORA_EXTRAUSER_${_}" } qw/DSN USER PASS/};
+
+plan skip_all => 'Set $ENV{DBICTEST_ORA_DSN}, _USER and _PASS to run this test.'
+  unless ($dsn && $user && $pass);
+
 {
   package    # hide from PAUSE
     DBICTest::Schema::ArtistFQN;
@@ -29,32 +55,6 @@
   1;
 }
 
-use strict;
-use warnings;
-
-use Test::Exception;
-use Test::More;
-use Sub::Name;
-
-use lib qw(t/lib);
-use DBICTest;
-use DBIC::SqlMakerTest;
-
-plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_rdbms_oracle')
-  unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_rdbms_oracle');
-
-$ENV{NLS_SORT} = "BINARY";
-$ENV{NLS_COMP} = "BINARY";
-$ENV{NLS_LANG} = "AMERICAN";
-
-my ($dsn,  $user,  $pass)  = @ENV{map { "DBICTEST_ORA_${_}" }  qw/DSN USER PASS/};
-
-# optional:
-my ($dsn2, $user2, $pass2) = @ENV{map { "DBICTEST_ORA_EXTRAUSER_${_}" } qw/DSN USER PASS/};
-
-plan skip_all => 'Set $ENV{DBICTEST_ORA_DSN}, _USER and _PASS to run this test.'
-  unless ($dsn && $user && $pass);
-
 DBICTest::Schema->load_classes('ArtistFQN');
 
 # This is in Core now, but it's here just to test that it doesn't break
diff --git a/t/94versioning.t b/t/94versioning.t
index a21141a..8306af5 100644
--- a/t/94versioning.t
+++ b/t/94versioning.t
@@ -5,6 +5,13 @@ use Test::More;
 use Test::Warn;
 use Test::Exception;
 
+use Path::Class;
+use File::Copy;
+use Time::HiRes qw/time sleep/;
+
+use lib qw(t/lib);
+use DBICTest; # do not remove even though it is not used
+
 my ($dsn, $user, $pass);
 
 BEGIN {
@@ -19,13 +26,6 @@ BEGIN {
     unless DBIx::Class::Optional::Dependencies->req_ok_for ('deploy')
 }
 
-use Path::Class;
-use File::Copy;
-use Time::HiRes qw/time sleep/;
-
-use lib qw(t/lib);
-use DBICTest; # do not remove even though it is not used
-
 use_ok('DBICVersion_v1');
 
 my $version_table_name = 'dbix_class_schema_versions';
diff --git a/t/96_is_deteministic_value.t b/t/96_is_deteministic_value.t
index 840a1c5..7828ffb 100644
--- a/t/96_is_deteministic_value.t
+++ b/t/96_is_deteministic_value.t
@@ -4,15 +4,15 @@ use warnings;
 use Test::More;
 use Test::Exception;
 
+use lib qw(t/lib);
+use DBICTest;
+
 BEGIN {
   require DBIx::Class;
   plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_dt')
     unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_dt');
 }
 
-use lib qw(t/lib);
-use DBICTest;
-
 my $schema = DBICTest->init_schema();
 my $artist_rs = $schema->resultset('Artist');
 my $cd_rs = $schema->resultset('CD');
diff --git a/t/99dbic_sqlt_parser.t b/t/99dbic_sqlt_parser.t
index 5d59834..ce103d1 100644
--- a/t/99dbic_sqlt_parser.t
+++ b/t/99dbic_sqlt_parser.t
@@ -5,6 +5,9 @@ use Test::More;
 use Test::Exception;
 use Scalar::Util ();
 
+use lib qw(t/lib);
+use DBICTest;
+
 BEGIN {
   require DBIx::Class;
   plan skip_all =>
@@ -12,10 +15,6 @@ BEGIN {
     unless DBIx::Class::Optional::Dependencies->req_ok_for ('deploy')
 }
 
-use lib qw(t/lib);
-use DBICTest;
-use DBICTest::Schema;
-
 # Test for SQLT-related leaks
 {
   my $s = DBICTest::Schema->clone;
diff --git a/t/admin/02ddl.t b/t/admin/02ddl.t
index e3ac33a..f1214b7 100644
--- a/t/admin/02ddl.t
+++ b/t/admin/02ddl.t
@@ -5,6 +5,11 @@ use Test::More;
 use Test::Exception;
 use Test::Warn;
 
+use Path::Class;
+
+use lib qw(t/lib);
+use DBICTest;
+
 BEGIN {
     require DBIx::Class;
     plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for('admin')
@@ -14,14 +19,8 @@ BEGIN {
       unless DBIx::Class::Optional::Dependencies->req_ok_for('deploy');
 }
 
-use lib qw(t/lib);
-use DBICTest;
-
-use Path::Class;
-
 use_ok 'DBIx::Class::Admin';
 
-
 my $sql_dir = dir(qw/t var/);
 my @connect_info = DBICTest->_database(
   no_deploy=>1,
diff --git a/t/admin/03data.t b/t/admin/03data.t
index 872b1cf..8294c68 100644
--- a/t/admin/03data.t
+++ b/t/admin/03data.t
@@ -4,15 +4,15 @@ use warnings;
 use Test::More;
 use Test::Exception;
 
+use lib 't/lib';
+use DBICTest;
+
 BEGIN {
     require DBIx::Class;
     plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for('admin')
       unless DBIx::Class::Optional::Dependencies->req_ok_for('admin');
 }
 
-use lib 't/lib';
-use DBICTest;
-
 use_ok 'DBIx::Class::Admin';
 
 
diff --git a/t/cdbi/68-inflate_has_a.t b/t/cdbi/68-inflate_has_a.t
index fbb4233..3b3a03f 100644
--- a/t/cdbi/68-inflate_has_a.t
+++ b/t/cdbi/68-inflate_has_a.t
@@ -2,6 +2,9 @@ use strict;
 use warnings;
 use Test::More;
 
+use lib qw(t/lib);
+use DBICTest;
+
 BEGIN {
   eval "use DBIx::Class::CDBICompat; use DateTime 0.55; use Clone;";
   plan skip_all => "Clone, DateTime 0.55, Class::Trigger and DBIx::ContextualFetch required"
@@ -10,9 +13,6 @@ BEGIN {
 
 plan tests => 6;
 
-use lib qw(t/lib);
-use DBICTest;
-
 my $schema = DBICTest->init_schema();
 
 DBICTest::Schema::CD->load_components(qw/CDBICompat::Relationships/);
diff --git a/t/cdbi/sweet/08pager.t b/t/cdbi/sweet/08pager.t
index 015ea98..ad9de5a 100644
--- a/t/cdbi/sweet/08pager.t
+++ b/t/cdbi/sweet/08pager.t
@@ -3,19 +3,18 @@ use warnings;
 
 use Test::More;
 
+use lib 't/lib';
+use DBICTest;
+
 BEGIN {
   eval "use DBIx::Class::CDBICompat;";
   if ($@) {
     plan (skip_all => 'Class::Trigger and DBIx::ContextualFetch required');
     next;
   }
-  plan tests => 10;
+  plan tests => 9;
 }
 
-use lib 't/lib';
-
-use_ok('DBICTest');
-
 DBICTest::Schema::CD->load_components(qw/CDBICompat CDBICompat::Pager/);
 
 my $schema = DBICTest->init_schema(compose_connection => 1);
diff --git a/t/lib/DBICTest/RunMode.pm b/t/lib/DBICTest/RunMode.pm
index d96fdcd..207203d 100644
--- a/t/lib/DBICTest/RunMode.pm
+++ b/t/lib/DBICTest/RunMode.pm
@@ -1,9 +1,20 @@
-package # hide from PAUSE 
+package # hide from PAUSE
     DBICTest::RunMode;
 
 use strict;
 use warnings;
 
+BEGIN {
+  if ($INC{'DBIx/Class.pm'}) {
+    my ($fr, @frame) = 1;
+    while (@frame = caller($fr++)) {
+      last if $frame[1] !~ m|^t/lib/DBICTest|;
+    }
+
+    die __PACKAGE__ . " must be loaded before DBIx::Class (or modules using DBIx::Class) at $frame[1] line $frame[2]\n";
+  }
+}
+
 use Path::Class qw/file dir/;
 
 _check_author_makefile() unless $ENV{DBICTEST_NO_MAKEFILE_VERIFICATION};
diff --git a/t/relationship/info.t b/t/relationship/info.t
index 00e5cb4..4f349d4 100644
--- a/t/relationship/info.t
+++ b/t/relationship/info.t
@@ -1,6 +1,10 @@
 use strict;
 use warnings;
 
+use Test::More;
+use lib qw(t/lib);
+use DBICTest;
+
 #
 # The test must be performed on non-registered result classes
 #
@@ -29,11 +33,6 @@ use warnings;
   __PACKAGE__->belongs_to(thing2 => 'DBICTest::Thing', 'thing_id', { join_type => 'left' } );
 }
 
-
-use Test::More;
-use lib qw(t/lib);
-use DBICTest;
-
 my $schema = DBICTest->init_schema;
 
 for my $without_schema (1,0) {
diff --git a/t/row/inflate_result.t b/t/row/inflate_result.t
index ab35f86..ecdd68c 100644
--- a/t/row/inflate_result.t
+++ b/t/row/inflate_result.t
@@ -1,3 +1,11 @@
+use warnings;
+use strict;
+
+use Test::More;
+
+use lib qw(t/lib);
+use DBICTest;
+
 package My::Schema::Result::User;
 
 use strict;
@@ -58,12 +66,6 @@ My::Schema->register_class( User  => 'My::Schema::Result::User' );
 1;
 
 package main;
-
-use lib qw(t/lib);
-use DBICTest;
-
-use Test::More;
-
 my $user_data = {
     email    => 'someguy@place.com',
     password => 'pass1',
diff --git a/t/search/preserve_original_rs.t b/t/search/preserve_original_rs.t
index 8913121..525efd4 100644
--- a/t/search/preserve_original_rs.t
+++ b/t/search/preserve_original_rs.t
@@ -5,9 +5,9 @@ use Test::More;
 use Test::Exception;
 
 use lib qw(t/lib);
+use DBICTest;
 use DBIC::SqlMakerTest;
 use DBIC::DebugObj;
-use DBICTest;
 
 # use Data::Dumper comparisons to avoid mesing with coderefs
 use Data::Dumper;
diff --git a/t/storage/replicated.t b/t/storage/replicated.t
index dc77f0b..6919e5f 100644
--- a/t/storage/replicated.t
+++ b/t/storage/replicated.t
@@ -3,14 +3,15 @@ use warnings;
 
 use Test::More;
 
+use lib qw(t/lib);
+use DBICTest;
+
 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');
 }
 
-use lib qw(t/lib);
-use DBICTest;
 
 if (DBICTest::RunMode->is_smoker) {
   my $mver = Moose->VERSION;