X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=t%2Flib%2FDBICTest%2FBaseSchema.pm;h=3ccd016e8054c2600142697491077ae9c00512ac;hb=91028369783da0db94a61e879860b8da97417fbb;hp=726ce10f26f6627695fadbed625f969a5a6e0f8f;hpb=44c1a75dd318ee6d943c91939c1b595ecc1d625b;p=dbsrgits%2FDBIx-Class.git diff --git a/t/lib/DBICTest/BaseSchema.pm b/t/lib/DBICTest/BaseSchema.pm index 726ce10..3ccd016 100644 --- a/t/lib/DBICTest/BaseSchema.pm +++ b/t/lib/DBICTest/BaseSchema.pm @@ -7,11 +7,59 @@ use base qw(DBICTest::Base DBIx::Class::Schema); use Fcntl qw(:DEFAULT :seek :flock); use IO::Handle (); -use DBIx::Class::_Util 'scope_guard'; +use DBIx::Class::_Util qw( emit_loud_diag scope_guard set_subname get_subname ); use DBICTest::Util::LeakTracer qw(populate_weakregistry assert_empty_weakregistry); use DBICTest::Util qw( local_umask tmpdir await_flock dbg DEBUG_TEST_CONCURRENCY_LOCKS ); +use Scalar::Util qw( refaddr weaken ); +use Devel::GlobalDestruction (); use namespace::clean; +# Unless we are running assertions there is no value in checking ourselves +# during regular tests - the CI will do it for us +# +if ( + DBIx::Class::_ENV_::ASSERT_NO_FAILING_SANITY_CHECKS + and + # full-blown 5.8 sanity-checking is waaaaaay too slow, even for CI + ( + ! DBIx::Class::_ENV_::OLD_MRO + or + # still run a couple test with this, even on 5.8 + $ENV{DBICTEST_OLD_MRO_SANITY_CHECK_ASSERTIONS} + ) +) { + + __PACKAGE__->schema_sanity_checker('DBIx::Class::Schema::SanityChecker'); + + # Repeat the check on going out of scope (will catch weird runtime tinkering) + # Add only in case we will be using it, as it slows tests down + eval <<'EOD' or die $@; + + sub DESTROY { + if ( + ! Devel::GlobalDestruction::in_global_destruction() + and + my $checker = $_[0]->schema_sanity_checker + ) { + $checker->perform_schema_sanity_checks($_[0]); + } + + # *NOT* using next::method here - it (currently) will confuse Class::C3 + # in some obscure cases ( 5.8 naturally ) + shift->SUPER::DESTROY(); + } + + 1; + +EOD + +} +else { + # otherwise just unset the default + __PACKAGE__->schema_sanity_checker(''); +} + + if( $ENV{DBICTEST_ASSERT_NO_SPURIOUS_EXCEPTION_ACTION} ) { my $ea = __PACKAGE__->exception_action( sub { @@ -96,7 +144,7 @@ if( $ENV{DBICTEST_ASSERT_NO_SPURIOUS_EXCEPTION_ACTION} ) { ( caller(0) eq 'main' and - (caller(1))[0] !~ $interesting_ns_rx + ( (caller(1))[0] || '' ) !~ $interesting_ns_rx ) ); @@ -216,7 +264,19 @@ END { } } -my $weak_registry = {}; +my ( $weak_registry, $assertion_arounds ) = ( {}, {} ); + +sub DBICTest::__RsrcRedefiner_iThreads_handler__::CLONE { + if( DBIx::Class::_ENV_::ASSERT_NO_ERRONEOUS_METAINSTANCE_USE ) { + %$assertion_arounds = map { + (defined $_) + ? ( refaddr($_) => $_ ) + : () + } values %$assertion_arounds; + + weaken($_) for values %$assertion_arounds; + } +} sub connection { my $self = shift->next::method(@_); @@ -262,7 +322,7 @@ sub connection { # we need to work with a forced fresh clone so that we do not upset any state # of the main $schema (some tests examine it quite closely) local $SIG{__WARN__} = sub {}; - local $SIG{__DIE__}; + local $SIG{__DIE__} if $SIG{__DIE__}; local $@; # this will either give us an undef $locktype or will determine things @@ -363,6 +423,169 @@ sub connection { ]); } + # + # Check an explicit level of indirection: makes sure that folks doing + # use `base "DBIx::Class::Core"; __PACKAGE__->add_column("foo")` + # will see the correct error message + # + # In the future this all is likely to be folded into a single method in + # some way, but that's a fight for another maint + # + if( DBIx::Class::_ENV_::ASSERT_NO_ERRONEOUS_METAINSTANCE_USE ) { + + for my $class_of_interest ( + 'DBIx::Class::Row', + map { $self->class($_) } ($self->sources) + ) { + + my $orig_rsrc = $class_of_interest->can('result_source') + or die "How did we get here?!"; + + unless ( $assertion_arounds->{refaddr $orig_rsrc} ) { + + my ($origin) = get_subname($orig_rsrc); + + no warnings 'redefine'; + no strict 'refs'; + + *{"${origin}::result_source"} = my $replacement = set_subname "${origin}::result_source" => sub { + + + @_ > 1 + and + (CORE::caller(0))[1] !~ / (?: ^ | [\/\\] ) x?t [\/\\] .+? \.t $ /x + and + emit_loud_diag( + msg => 'Incorrect indirect call of result_source() as setter must be changed to result_source_instance()', + confess => 1, + ); + + + grep { + ! (CORE::caller($_))[7] + and + ( (CORE::caller($_))[3] || '' ) eq '(eval)' + and + ( (CORE::caller($_))[1] || '' ) !~ / (?: ^ | [\/\\] ) x?t [\/\\] .+? \.t $ /x + } (0..2) + and + # these evals are legit + ( (CORE::caller(4))[3] || '' ) !~ /^ (?: + DBIx::Class::Schema::_ns_get_rsrc_instance + | + DBIx::Class::Relationship::BelongsTo::belongs_to + | + DBIx::Class::Relationship::HasOne::_has_one + | + Class::C3::Componentised::.+ + ) $/x + and + emit_loud_diag( + # not much else we can do (aside from exit(1) which is too obnoxious) + msg => 'Incorrect call of result_source() in an eval', + emit_dups => 1, + ); + + + &$orig_rsrc; + }; + + weaken( $assertion_arounds->{refaddr $replacement} = $replacement ); + + attributes->import( + $origin, + $replacement, + attributes::get($orig_rsrc) + ); + } + + + # no rsrc_instance to mangle + next if $class_of_interest eq 'DBIx::Class::Row'; + + + my $orig_rsrc_instance = $class_of_interest->can('result_source_instance') + or die "How did we get here?!"; + + # Do the around() per definition-site as result_source_instance is a CAG inherited cref + unless ( $assertion_arounds->{refaddr $orig_rsrc_instance} ) { + + my ($origin) = get_subname($orig_rsrc_instance); + + no warnings 'redefine'; + no strict 'refs'; + + *{"${origin}::result_source_instance"} = my $replacement = set_subname "${origin}::result_source_instance" => sub { + + + @_ == 1 + and + # special cased as we do not care whether there is a source + ( (CORE::caller(4))[3] || '' ) ne 'DBIx::Class::Schema::_register_source' + and + # special case because I am paranoid + ( (CORE::caller(4))[3] || '' ) ne 'DBIx::Class::Row::throw_exception' + and + ( (CORE::caller(1))[3] || '' ) !~ / ^ DBIx::Class:: (?: + Row::result_source + | + Row::throw_exception + | + ResultSourceProxy::Table:: (?: _init_result_source_instance | table ) + | + ResultSourceHandle::STORABLE_thaw + ) $ /x + and + (CORE::caller(0))[1] !~ / (?: ^ | [\/\\] ) x?t [\/\\] .+? \.t $ /x + and + emit_loud_diag( + msg => 'Incorrect direct call of result_source_instance() as getter must be changed to result_source()', + confess => 1 + ); + + + grep { + ! (CORE::caller($_))[7] + and + ( (CORE::caller($_))[3] || '' ) eq '(eval)' + and + ( (CORE::caller($_))[1] || '' ) !~ / (?: ^ | [\/\\] ) x?t [\/\\] .+? \.t $ /x + } (0..2) + and + # special cased as we do not care whether there is a source + ( (CORE::caller(4))[3] || '' ) ne 'DBIx::Class::Schema::_register_source' + and + # special case because I am paranoid + ( (CORE::caller(4))[3] || '' ) ne 'DBIx::Class::Row::throw_exception' + and + # special case for Storable, which in turn calls from an eval + ( (CORE::caller(1))[3] || '' ) ne 'DBIx::Class::ResultSourceHandle::STORABLE_thaw' + and + emit_loud_diag( + # not much else we can do (aside from exit(1) which is too obnoxious) + msg => 'Incorrect call of result_source_instance() in an eval', + skip_frames => 1, + emit_dups => 1, + ); + + &$orig_rsrc_instance; + }; + + weaken( $assertion_arounds->{refaddr $replacement} = $replacement ); + + attributes->import( + $origin, + $replacement, + attributes::get($orig_rsrc_instance) + ); + } + } + + Class::C3::initialize if DBIx::Class::_ENV_::OLD_MRO; + } + # + # END Check an explicit level of indirection + return $self; }