package
DBIx::Class::Componentised;
sub
inject_base {
my
$class
=
shift
;
my
(
$target
,
@complist
) =
@_
;
my
$keep_checking
= ! (
$target
->isa (
'DBIx::Class::UTF8Columns'
)
||
$target
->isa (
'DBIx::Class::ForceUTF8'
)
);
my
@target_isa
;
while
(
$keep_checking
&&
@complist
) {
@target_isa
=
do
{
no
strict
'refs'
; @{
"$target\::ISA"
} }
unless
@target_isa
;
my
$comp
=
pop
@complist
;
for
(
qw/DBIx::Class::UTF8Columns DBIx::Class::ForceUTF8/
) {
if
(
$comp
->isa (
$_
) ) {
$keep_checking
= 0;
carp_once
"Use of $_ is strongly discouraged. See documentation of DBIx::Class::UTF8Columns for more info\n"
unless
$ENV
{DBIC_UTF8COLUMNS_OK};
last
;
}
}
if
(!
$keep_checking
) {
my
$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
) {
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' ("
.
join
(
', '
,
@broken
)
.
'). Refer to the documentation of DBIx::Class::UTF8Columns for more info'
if
@broken
;
}
unshift
@target_isa
,
$comp
;
}
$class
->
next
::method(
@_
);
}
1;