BEGIN {
if
($] < 5.010) {
unshift
@INC
,
't/lib'
;
DBICTest::Util::OverrideRequire::override_global_require(
sub
{
my
$res
=
eval
{
$_
[0]->() };
if
($@ ne
''
) {
delete
$INC
{
$_
[1]};
die
$@;
}
return
$res
;
} );
}
}
my
@modules
=
grep
{
my
(
$mod
) =
$_
=~ /(.+)/;
do
{
local
$SIG
{__WARN__} =
sub
{};
eval
"require $mod"
;
} ?
$mod
:
do
{
SKIP: { skip
"Failed require of $mod: "
. ($@ =~ /^(.+?)$/m)[0], 1 };
();
};
} find_modules();
my
$skip_idx
= {
map
{
$_
=> 1 } (
(
grep
{ /^DBIx::Class::CDBICompat/ }
@modules
),
'SQL::Translator::Producer::DBIx::Class::File'
,
'DBIx::Class::Storage::DBI::Replicated::Types'
,
'DBIx::Class::Admin::Types'
,
'DBIx::Class::Admin::Descriptive'
,
'DBIx::Class::Admin::Usage'
,
'DBIx::Class::ResultSet::Pager'
,
'DBIx::Class::ResultSource::RowParser::Util'
,
'DBIx::Class::_Util'
,
) };
my
$seen
;
for
my
$mod
(
@modules
) {
SKIP: {
skip
"$mod exempt from namespace checks"
,1
if
$skip_idx
->{
$mod
};
my
%all_method_like
= (
map
{ %{Package::Stash->new(
$_
)->get_all_symbols(
'CODE'
)} }
(
reverse
@{mro::get_linear_isa(
$mod
)})
);
my
%parents
=
map
{
$_
=> 1 } @{mro::get_linear_isa(
$mod
)};
my
%roles
;
if
(
$has_cmop
and
my
$mc
= Class::MOP::class_of(
$mod
)) {
if
(
$mc
->can(
'calculate_all_roles_with_inheritance'
)) {
$roles
{
$_
->name} = 1
for
(
$mc
->calculate_all_roles_with_inheritance);
}
}
for
my
$name
(
keys
%all_method_like
) {
next
if
( DBIx::Class::_ENV_::BROKEN_NAMESPACE_CLEAN and
$name
=~ /^carp(?:_unique|_once)?$/ );
next
if
$name
=~ /^\(/;
my
$gv
= svref_2object(
$all_method_like
{
$name
})->GV;
my
$origin
=
$gv
->STASH->NAME;
is (
$gv
->NAME,
$name
,
"Properly named $name method at $origin"
. (
$origin
eq
$mod
?
''
:
" (inherited by $mod)"
));
next
if
$seen
->{
"${origin}:${name}"
}++;
if
(
$origin
eq
$mod
) {
pass (
"$name is a native $mod method"
);
}
elsif
(
$roles
{
$origin
}) {
pass (
"${mod}::${name} came from consumption of role $origin"
);
}
elsif
(
$parents
{
$origin
}) {
pass (
"${mod}::${name} came from proper parent-class $origin"
);
}
else
{
my
$via
;
for
(
reverse
@{mro::get_linear_isa(
$mod
)} ) {
if
( (
$_
->can(
$name
)||
''
) eq
$all_method_like
{
$name
} ) {
$via
=
$_
;
last
;
}
}
fail (
"${mod}::${name} appears to have entered inheritance chain by import into "
. (
$via
||
'UNKNOWN'
)
);
}
}
next
if
DBIx::Class::_ENV_::BROKEN_NAMESPACE_CLEAN;
for
my
$f
(
qw/carp carp_once carp_unique croak confess cluck try catch finally/
) {
if
(
$mod
->can(
$f
)) {
my
$via
;
for
(
reverse
@{mro::get_linear_isa(
$mod
)} ) {
if
( (
$_
->can(
$f
)||
''
) eq
$all_method_like
{
$f
} ) {
$via
=
$_
;
last
;
}
}
fail (
"Import $f leaked into method list of ${mod}, appears to have entered inheritance chain at "
. (
$via
||
'UNKNOWN'
)
);
}
else
{
pass (
"Import $f not leaked into method list of $mod"
);
}
}
}
}
sub
find_modules {
my
@modules
;
find({
wanted
=>
sub
{
-f
$_
or
return
;
s/\.pm$// or
return
;
s/^ (?: lib | blib . (?:lib|arch) ) . //x;
push
@modules
,
join
(
'::'
, File::Spec->splitdir(
$_
));
},
no_chdir
=> 1,
}, (-e
'blib'
?
'blib'
:
'lib'
) );
return
sort
@modules
;
}
done_testing;