From: Peter Rabbitson <ribasushi@cpan.org>
Date: Tue, 19 Apr 2016 12:13:03 +0000 (+0200)
Subject: Start setting the 'c3' mro unambiguously everywhere
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=d009cb7d;p=dbsrgits%2FDBIx-Class-Historic.git

Start setting the 'c3' mro unambiguously everywhere

This is a necessary part of the rsrc refactor, which there is no way around.
And yes - it is extremely invasive and dangerous, with very high chance of
fallout. Given the situation there is no other way :/

The implementation itself is rather simple: all we need to do is hook
inject_base (which is called by load_components via several levels of
indirection), and also (as a precaution) we set the mro on anything loaded
via a component-group accessor. This seems to nicely cover pretty much all
of the hierarchy (except ::Storage, but that is another matter/rewrite)

Also move the CAG compat pieces where they belong
---

diff --git a/Changes b/Changes
index f71dec5..318a4b2 100644
--- a/Changes
+++ b/Changes
@@ -1,6 +1,11 @@
 Revision history for DBIx::Class
 
     * Notable Changes and Deprecations
+        - The entire class hierarchy now explicitly sets the 'c3' mro, even
+          in cases where load_components was not used. Extensive testing led
+          the maintainer believe this is safe, but this is a very complex
+          area and reality may turn out to be different. If **ANYHTING** at
+          all seems out of place, please file a report at once
         - Neither exception_action() nor $SIG{__DIE__} handlers are invoked
           on recoverable errors. This ensures that the retry logic is fully
           insulated from changes in control flow, as the handlers are only
diff --git a/lib/DBIx/Class.pm b/lib/DBIx/Class.pm
index cec52f7..79d7630 100644
--- a/lib/DBIx/Class.pm
+++ b/lib/DBIx/Class.pm
@@ -37,17 +37,19 @@ BEGIN {
   sub DESTROY { &DBIx::Class::_Util::detected_reinvoked_destructor };
 }
 
-sub mk_classdata {
-  shift->mk_classaccessor(@_);
-}
+sub component_base_class { 'DBIx::Class' }
 
-sub mk_classaccessor {
-  my $self = shift;
-  $self->mk_group_accessors('inherited', $_[0]);
-  $self->set_inherited(@_) if @_ > 1;
-}
+my $mro_already_set;
+sub inject_base {
 
-sub component_base_class { 'DBIx::Class' }
+  # only examine from $_[2] onwards
+  # C::C3::C already sets c3 on $_[1] and $_[0] is irrelevant
+  mro::set_mro( $_ => 'c3' ) for grep {
+    $mro_already_set->{$_} ? 0 : ( $mro_already_set->{$_} = 1 )
+  } @_[2 .. $#_];
+
+  shift->next::method(@_);
+}
 
 sub MODIFY_CODE_ATTRIBUTES {
   my ($class,$code,@attrs) = @_;
diff --git a/lib/DBIx/Class/AccessorGroup.pm b/lib/DBIx/Class/AccessorGroup.pm
index ea25e4f..12a8744 100644
--- a/lib/DBIx/Class/AccessorGroup.pm
+++ b/lib/DBIx/Class/AccessorGroup.pm
@@ -7,6 +7,16 @@ use base qw/Class::Accessor::Grouped/;
 use Scalar::Util qw/weaken blessed/;
 use namespace::clean;
 
+sub mk_classdata {
+  shift->mk_classaccessor(@_);
+}
+
+sub mk_classaccessor {
+  my $self = shift;
+  $self->mk_group_accessors('inherited', $_[0]);
+  $self->set_inherited(@_) if @_ > 1;
+}
+
 my $successfully_loaded_components;
 
 sub get_component_class {
@@ -18,6 +28,8 @@ sub get_component_class {
   if (defined $class and ! $successfully_loaded_components->{$class} ) {
     $_[0]->ensure_class_loaded($class);
 
+    mro::set_mro( $class, 'c3' );
+
     no strict 'refs';
     $successfully_loaded_components->{$class}
       = ${"${class}::__LOADED__BY__DBIC__CAG__COMPONENT_CLASS__"}
diff --git a/lib/DBIx/Class/ResultSet.pm b/lib/DBIx/Class/ResultSet.pm
index 9030712..1231a07 100644
--- a/lib/DBIx/Class/ResultSet.pm
+++ b/lib/DBIx/Class/ResultSet.pm
@@ -2,7 +2,10 @@ package DBIx::Class::ResultSet;
 
 use strict;
 use warnings;
-use base qw/DBIx::Class/;
+
+use base 'DBIx::Class';
+use mro 'c3';
+
 use DBIx::Class::Carp;
 use DBIx::Class::ResultSetColumn;
 use DBIx::Class::ResultClass::HashRefInflator;
diff --git a/lib/DBIx/Class/ResultSource.pm b/lib/DBIx/Class/ResultSource.pm
index b6fb310..d2cc10f 100644
--- a/lib/DBIx/Class/ResultSource.pm
+++ b/lib/DBIx/Class/ResultSource.pm
@@ -3,7 +3,10 @@ package DBIx::Class::ResultSource;
 use strict;
 use warnings;
 
-use base qw/DBIx::Class::ResultSource::RowParser DBIx::Class/;
+use base 'DBIx::Class';
+__PACKAGE__->load_components(qw(
+  ResultSource::RowParser
+));
 
 use DBIx::Class::Carp;
 use DBIx::Class::_Util qw( UNRESOLVABLE_CONDITION dbic_internal_try );
diff --git a/lib/DBIx/Class/ResultSourceProxy.pm b/lib/DBIx/Class/ResultSourceProxy.pm
index 1e1f307..62c0564 100644
--- a/lib/DBIx/Class/ResultSourceProxy.pm
+++ b/lib/DBIx/Class/ResultSourceProxy.pm
@@ -5,6 +5,7 @@ use strict;
 use warnings;
 
 use base 'DBIx::Class';
+use mro 'c3';
 
 use Scalar::Util 'blessed';
 use DBIx::Class::_Util 'quote_sub';
diff --git a/lib/DBIx/Class/Schema.pm b/lib/DBIx/Class/Schema.pm
index fc9c499..04f92cc 100644
--- a/lib/DBIx/Class/Schema.pm
+++ b/lib/DBIx/Class/Schema.pm
@@ -4,6 +4,7 @@ use strict;
 use warnings;
 
 use base 'DBIx::Class';
+use mro 'c3';
 
 use DBIx::Class::Carp;
 use Try::Tiny;
diff --git a/xt/dist/pod_coverage.t b/xt/dist/pod_coverage.t
index a86c4d8..4505af4 100644
--- a/xt/dist/pod_coverage.t
+++ b/xt/dist/pod_coverage.t
@@ -31,6 +31,7 @@ my $exceptions = {
         ignore => [qw/
             MODIFY_CODE_ATTRIBUTES
             component_base_class
+            inject_base
             mk_classdata
             mk_classaccessor
         /]
diff --git a/xt/extra/c3_mro.t b/xt/extra/c3_mro.t
index ae40404..1c5001a 100644
--- a/xt/extra/c3_mro.t
+++ b/xt/extra/c3_mro.t
@@ -4,9 +4,21 @@ use warnings;
 use strict;
 
 use Test::More;
+use DBICTest;
+
+my @global_ISA_tail = qw(
+  DBIx::Class
+  DBIx::Class::Componentised
+  Class::C3::Componentised
+  DBIx::Class::AccessorGroup
+  Class::Accessor::Grouped
+);
 
-
-use DBICTest; # do not remove even though it is not used (pulls in MRO::Compat if needed)
+is(
+  mro::get_mro('DBIx::Class'),
+  'c3',
+  'Correct mro on base class DBIx::Class',
+);
 
 {
   package AAA;
@@ -38,6 +50,17 @@ ok (! $@, "Correctly skipped injecting a direct parent of class BBB");
 eval { mro::get_linear_isa('CCC'); };
 ok (! $@, "Correctly skipped injecting an indirect parent of class BBB");
 
+
+my $art = DBICTest->init_schema->resultset("Artist")->next;
+
+check_ancestry($_) for (
+  ref( $art ),
+  ref( $art->result_source ),
+  ref( $art->result_source->resultset ),
+  ref( $art->result_source->schema ),
+  qw( AAA BBB CCC ),
+);
+
 use DBIx::Class::Storage::DBI::Sybase::Microsoft_SQL_Server;
 
 is_deeply (
@@ -51,12 +74,7 @@ is_deeply (
     DBIx::Class::Storage::DBI
     DBIx::Class::Storage::DBIHacks
     DBIx::Class::Storage
-    DBIx::Class
-    DBIx::Class::Componentised
-    Class::C3::Componentised
-    DBIx::Class::AccessorGroup
-    Class::Accessor::Grouped
-  /],
+  /, @global_ISA_tail],
   'Correctly ordered ISA of DBIx::Class::Storage::DBI::Sybase::Microsoft_SQL_Server'
 );
 
@@ -77,4 +95,37 @@ if ( "$]" >= 5.010 ) {
   #ok (! $INC{'MRO/Compat.pm'}, 'No MRO::Compat loaded on perl 5.10+');
 }
 
+sub check_ancestry {
+  my $class = shift;
+
+  die "Expecting classname" if length ref $class;
+
+  my @linear_ISA = @{ mro::get_linear_isa($class) };
+
+  # something is *VERY* wrong, the splice below won't make it
+  unless (@linear_ISA > @global_ISA_tail) {
+    fail(
+      "Unexpectedly shallow \@ISA for class '$class': "
+    . join ', ', map { "'$_'" } @linear_ISA
+    );
+    return;
+  }
+
+  is_deeply (
+    [ splice @linear_ISA, ($#linear_ISA - $#global_ISA_tail) ],
+    \@global_ISA_tail,
+    "Correct end of \@ISA for '$class'"
+  );
+
+  # check the remainder
+  for my $c (@linear_ISA) {
+    # nothing to see there
+    next if $c =~ /^DBICTest::/;
+
+    next if mro::get_mro($c) eq 'c3';
+
+    fail( "Incorrect mro '@{[ mro::get_mro($c) ]}' on '$c' (parent of '$class')" );
+  }
+}
+
 done_testing;