From: Peter Rabbitson <ribasushi@cpan.org>
Date: Thu, 8 Apr 2010 09:36:34 +0000 (+0000)
Subject: Fix utf8columns loading-order test/code (really just as POC at this point)
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=1415f198da91a23911972ad06b6dafaf6f4c0e8f;p=dbsrgits%2FDBIx-Class-Historic.git

Fix utf8columns loading-order test/code (really just as POC at this point)
---

diff --git a/lib/DBIx/Class/Componentised.pm b/lib/DBIx/Class/Componentised.pm
index fb0bd28..a82a247 100644
--- a/lib/DBIx/Class/Componentised.pm
+++ b/lib/DBIx/Class/Componentised.pm
@@ -9,40 +9,53 @@ use Carp::Clan qw/^DBIx::Class|^Class::C3::Componentised/;
 use mro 'c3';
 
 # this warns of subtle bugs introduced by UTF8Columns hacky handling of store_column
+# if and only if it is placed before something overriding store_column
 sub inject_base {
   my $class = shift;
-  my $target = shift;
+  my ($target, @complist) = @_;
 
-  my @present_components = (@{mro::get_linear_isa ($target)||[]});
-  shift @present_components;    # don't need to interrogate myself
+  # we already did load the component
+  my $keep_checking = ! $target->isa ('DBIx::Class::UTF8Columns');
 
-  no strict 'refs';
-  for my $comp (reverse @_) {
+  my @target_isa = do { no strict 'refs'; @{"$target\::ISA"} };
+  my $base_store_column;
 
-    # if we are trying add a UTF8Columns component *for the first time*
-    if ($comp->isa ('DBIx::Class::UTF8Columns') && ! $target->isa ('DBIx::Class::UTF8Columns') ) {
-      require B;
-      my @broken;
+  while ($keep_checking && @complist) {
+
+    my $comp = pop @complist;
 
-      for (@present_components) {
-        last if $_ eq 'DBIx::Class::Row'; # don't care about anything further down the chain
+    if ($comp->isa ('DBIx::Class::UTF8Columns')) {
 
-        my $cref = $_->can ('store_column')
-         or next;
+      $keep_checking = 0;
 
-        push @broken, $_ if B::svref_2object($cref)->STASH->NAME eq $_;
+      $base_store_column ||=
+        do { require DBIx::Class::Row; DBIx::Class::Row->can ('store_column') };
+
+      my @broken;
+      for my $existing_comp (@target_isa) {
+        my $sc = $existing_comp->can ('store_column')
+          or next;
+
+        if ($sc ne $base_store_column) {
+          require B;
+          my $definer = B::svref_2object($sc)->STASH->NAME;
+          push @broken, ($definer eq $existing_comp)
+            ? $existing_comp
+            : "$existing_comp (via $definer)"
+          ;
+        }
       }
 
-      carp "Incorrect loading order of $comp by ${target} will affect other components overriding store_column ("
+      carp "Incorrect loading order of $comp by $target will affect other components overriding 'store_column' ("
           . join (', ', @broken)
           .'). Refer to the documentation of DBIx::Class::UTF8Columns for more info'
-       if @broken;
+        if @broken;
     }
 
-    unshift @present_components, $comp;
+    unshift @target_isa, $comp;
   }
 
-  $class->next::method($target, @_);
+  $class->next::method(@_);
 }
 
 1;
diff --git a/t/85utf8.t b/t/85utf8.t
index 5ea1a60..de63f27 100644
--- a/t/85utf8.t
+++ b/t/85utf8.t
@@ -16,41 +16,58 @@ use DBICTest;
 {
   package A::SubComp;
   use base 'A::Comp';
+
   1;
 }
 
-warnings_like (
-  sub {
-    package A::Test;
-    use base 'DBIx::Class::Core';
-    __PACKAGE__->load_components(qw(UTF8Columns +A::SubComp +A::Comp));
-    1;
-  },
-  [qr/Incorrect loading order of DBIx::Class::UTF8Columns.+affect other components overriding store_column \(A::Comp\)/],
-  'incorrect order warning issued',
-);
-
 warnings_are (
   sub {
-    package A::Test2;
+    package A::Test1;
     use base 'DBIx::Class::Core';
     __PACKAGE__->load_components(qw(Core +A::Comp Ordered UTF8Columns));
-    __PACKAGE__->load_components(qw(Ordered +A::Comp Row UTF8Columns Core));
+    __PACKAGE__->load_components(qw(Ordered +A::SubComp Row UTF8Columns Core));
+    sub store_column { shift->next::method (@_) };
     1;
   },
   [],
   'no spurious warnings issued',
 );
 
-my $test2_mro;
+my $test1_mro;
 my $idx = 0;
-for (@{mro::get_linear_isa ('A::Test2')} ) {
-  $test2_mro->{$_} = $idx++;
+for (@{mro::get_linear_isa ('A::Test1')} ) {
+  $test1_mro->{$_} = $idx++;
 }
 
-cmp_ok ($test2_mro->{'A::Comp'}, '<', $test2_mro->{'DBIx::Class::UTF8Columns'}, 'mro of Test2 correct (A::Comp before UTF8Col)' );
-cmp_ok ($test2_mro->{'DBIx::Class::UTF8Columns'}, '<', $test2_mro->{'DBIx::Class::Core'}, 'mro of Test2 correct (UTF8Col before Core)' );
-cmp_ok ($test2_mro->{'DBIx::Class::Core'}, '<', $test2_mro->{'DBIx::Class::Row'}, 'mro of Test2 correct (Core before Row)' );
+cmp_ok ($test1_mro->{'A::SubComp'}, '<', $test1_mro->{'A::Comp'}, 'mro of Test1 correct (A::SubComp before A::Comp)' );
+cmp_ok ($test1_mro->{'A::Comp'}, '<', $test1_mro->{'DBIx::Class::UTF8Columns'}, 'mro of Test1 correct (A::Comp before UTF8Col)' );
+cmp_ok ($test1_mro->{'DBIx::Class::UTF8Columns'}, '<', $test1_mro->{'DBIx::Class::Core'}, 'mro of Test1 correct (UTF8Col before Core)' );
+cmp_ok ($test1_mro->{'DBIx::Class::Core'}, '<', $test1_mro->{'DBIx::Class::Row'}, 'mro of Test1 correct (Core before Row)' );
+
+
+warnings_like (
+  sub {
+    package A::Test2;
+    use base 'DBIx::Class::Core';
+    __PACKAGE__->load_components(qw(UTF8Columns +A::Comp));
+    sub store_column { shift->next::method (@_) };
+    1;
+  },
+  [qr/Incorrect loading order of DBIx::Class::UTF8Columns.+affect other components overriding 'store_column' \(A::Comp\)/],
+  'incorrect order warning issued (violator defines)',
+);
+
+warnings_like (
+  sub {
+    package A::Test3;
+    use base 'DBIx::Class::Core';
+    __PACKAGE__->load_components(qw(UTF8Columns +A::SubComp));
+    sub store_column { shift->next::method (@_) };
+    1;
+  },
+  [qr/Incorrect loading order of DBIx::Class::UTF8Columns.+affect other components overriding 'store_column' \(A::SubComp \(via A::Comp\)\)/],
+  'incorrect order warning issued (violator inherits)',
+);
 
 my $schema = DBICTest->init_schema();
 DBICTest::Schema::CD->load_components('UTF8Columns');