[Bast-commits] r9102 - in DBIx-Class/0.08/trunk: lib/DBIx/Class t
ribasushi at dev.catalyst.perl.org
ribasushi at dev.catalyst.perl.org
Thu Apr 8 09:36:34 GMT 2010
Author: ribasushi
Date: 2010-04-08 10:36:34 +0100 (Thu, 08 Apr 2010)
New Revision: 9102
Modified:
DBIx-Class/0.08/trunk/lib/DBIx/Class/Componentised.pm
DBIx-Class/0.08/trunk/t/85utf8.t
Log:
Fix utf8columns loading-order test/code (really just as POC at this point)
Modified: DBIx-Class/0.08/trunk/lib/DBIx/Class/Componentised.pm
===================================================================
--- DBIx-Class/0.08/trunk/lib/DBIx/Class/Componentised.pm 2010-04-07 17:23:53 UTC (rev 9101)
+++ DBIx-Class/0.08/trunk/lib/DBIx/Class/Componentised.pm 2010-04-08 09:36:34 UTC (rev 9102)
@@ -9,40 +9,53 @@
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) {
- for (@present_components) {
- last if $_ eq 'DBIx::Class::Row'; # don't care about anything further down the chain
+ my $comp = pop @complist;
- my $cref = $_->can ('store_column')
- or next;
+ if ($comp->isa ('DBIx::Class::UTF8Columns')) {
- push @broken, $_ if B::svref_2object($cref)->STASH->NAME eq $_;
+ $keep_checking = 0;
+
+ $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;
Modified: DBIx-Class/0.08/trunk/t/85utf8.t
===================================================================
--- DBIx-Class/0.08/trunk/t/85utf8.t 2010-04-07 17:23:53 UTC (rev 9101)
+++ DBIx-Class/0.08/trunk/t/85utf8.t 2010-04-08 09:36:34 UTC (rev 9102)
@@ -16,42 +16,59 @@
{
package A::SubComp;
use base 'A::Comp';
+
1;
}
-warnings_like (
+warnings_are (
sub {
- package A::Test;
+ package A::Test1;
use base 'DBIx::Class::Core';
- __PACKAGE__->load_components(qw(UTF8Columns +A::SubComp +A::Comp));
+ __PACKAGE__->load_components(qw(Core +A::Comp Ordered UTF8Columns));
+ __PACKAGE__->load_components(qw(Ordered +A::SubComp Row UTF8Columns Core));
+ 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',
+ [],
+ 'no spurious warnings issued',
);
-warnings_are (
+my $test1_mro;
+my $idx = 0;
+for (@{mro::get_linear_isa ('A::Test1')} ) {
+ $test1_mro->{$_} = $idx++;
+}
+
+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(Core +A::Comp Ordered UTF8Columns));
- __PACKAGE__->load_components(qw(Ordered +A::Comp Row UTF8Columns Core));
+ __PACKAGE__->load_components(qw(UTF8Columns +A::Comp));
+ sub store_column { shift->next::method (@_) };
1;
},
- [],
- 'no spurious warnings issued',
+ [qr/Incorrect loading order of DBIx::Class::UTF8Columns.+affect other components overriding 'store_column' \(A::Comp\)/],
+ 'incorrect order warning issued (violator defines)',
);
-my $test2_mro;
-my $idx = 0;
-for (@{mro::get_linear_isa ('A::Test2')} ) {
- $test2_mro->{$_} = $idx++;
-}
+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)',
+);
-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)' );
-
my $schema = DBICTest->init_schema();
DBICTest::Schema::CD->load_components('UTF8Columns');
DBICTest::Schema::CD->utf8_columns('title');
More information about the Bast-commits
mailing list