From: Peter Rabbitson 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');