X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=t%2Flib%2FDBICTest%2FBaseSchema.pm;h=5f52f75b029ff4d96c09dc8a64b446c6f6cecc96;hb=e570488ade8f327f47dd3318db3443a348d561d6;hp=cdc7a02e71d126bfe860bffc0fc87b4142e5442b;hpb=c7e856308aeac1faa6f4d8ad59da096e009d70f4;p=dbsrgits%2FDBIx-Class.git diff --git a/t/lib/DBICTest/BaseSchema.pm b/t/lib/DBICTest/BaseSchema.pm index cdc7a02..5f52f75 100644 --- a/t/lib/DBICTest/BaseSchema.pm +++ b/t/lib/DBICTest/BaseSchema.pm @@ -6,11 +6,105 @@ use warnings; use base qw(DBICTest::Base DBIx::Class::Schema); use Fcntl qw(:DEFAULT :seek :flock); -use Time::HiRes 'sleep'; +use IO::Handle (); +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 'local_umask'; +use DBICTest::Util qw( local_umask tmpdir await_flock dbg DEBUG_TEST_CONCURRENCY_LOCKS ); +use Scalar::Util qw( refaddr weaken ); use namespace::clean; +if( $ENV{DBICTEST_ASSERT_NO_SPURIOUS_EXCEPTION_ACTION} ) { + my $ea = __PACKAGE__->exception_action( sub { + + # Can not rely on $^S here at all - the exception_action + # itself is always called in an eval so that the goto-guard + # can work (see 7cb35852) + + my ( $fr_num, $disarmed, $throw_exception_fr_num, $eval_fr_num ); + while( ! $disarmed and my @fr = caller(++$fr_num) ) { + + $throw_exception_fr_num ||= ( + $fr[3] =~ /^DBIx::Class::(?:ResultSource|Schema|Storage|Exception)::throw(?:_exception)?$/ + and + # there may be evals in the throwers themselves - skip those + ( $eval_fr_num ) = ( undef ) + and + $fr_num + ); + + # now that the above stops un-setting us, we can find the first + # ineresting eval + $eval_fr_num ||= ( + $fr[3] eq '(eval)' + and + $fr_num + ); + + $disarmed = !! ( + $fr[1] =~ / \A (?: \. [\/\\] )? x?t [\/\\] .+ \.t \z /x + and + ( + $fr[3] =~ /\A (?: + Test::Exception::throws_ok + | + Test::Exception::dies_ok + | + Try::Tiny::try + | + \Q(eval)\E + ) \z /x + or + ( + $fr[3] eq 'Test::Exception::lives_ok' + and + ( $::TODO or Test::Builder->new->in_todo ) + ) + ) + ); + } + + Test::Builder->new->ok(0, join "\n", + 'Unexpected &exception_action invocation', + '', + ' You almost certainly used eval/try instead of dbic_internal_try()', + " Adjust *one* of the eval-ish constructs in the callstack starting" . DBICTest::Util::stacktrace($throw_exception_fr_num||()) + ) if ( + ! $disarmed + and + ( + $eval_fr_num + or + ! $throw_exception_fr_num + ) + ); + + DBIx::Class::Exception->throw( $_[0] ); + }); + + my $interesting_ns_rx = qr/^ (?: main$ | DBIx::Class:: | DBICTest:: ) /x; + + # hard-set $SIG{__DIE__} to the class-wide exception_action + # with a little escape preceeding it + $SIG{__DIE__} = sub { + + # without this there would be false positives everywhere :( + die @_ if ( + # blindly rethrow if nobody is waiting for us + ( defined $^S and ! $^S ) + or + (caller(0))[0] !~ $interesting_ns_rx + or + ( + caller(0) eq 'main' + and + ( (caller(1))[0] || '' ) !~ $interesting_ns_rx + ) + ); + + &$ea; + }; +} + sub capture_executed_sql_bind { my ($self, $cref) = @_; @@ -23,10 +117,20 @@ sub capture_executed_sql_bind { local *DBIx::Class::Storage::DBI::_format_for_trace = sub { $_[1] }; Class::C3->reinitialize if DBIx::Class::_ENV_::OLD_MRO; + # can not use local() due to an unknown number of storages + # (think replicated) + my $orig_states = { map + { $_ => $self->storage->$_ } + qw(debugcb debugobj debug) + }; + + my $sg = scope_guard { + $self->storage->$_ ( $orig_states->{$_} ) for keys %$orig_states; + }; - local $self->storage->{debugcb}; - local $self->storage->{debugobj} = my $tracer_obj = DBICTest::SQLTracerObj->new; - local $self->storage->{debug} = 1; + $self->storage->debugcb(undef); + $self->storage->debugobj( my $tracer_obj = DBICTest::SQLTracerObj->new ); + $self->storage->debug(1); local $Test::Builder::Level = $Test::Builder::Level + 2; $cref->(); @@ -108,11 +212,24 @@ our $locker; END { # we need the $locker to be referenced here for delayed destruction if ($locker->{lock_name} and ($ENV{DBICTEST_LOCK_HOLDER}||0) == $$) { - #warn "$$ $0 $locker->{type} LOCK RELEASED"; + DEBUG_TEST_CONCURRENCY_LOCKS + and dbg "$locker->{type} LOCK RELEASED (END): $locker->{lock_name}"; } } -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(@_); @@ -139,13 +256,6 @@ sub connection { # an envvar, we can not detect when a user invokes prove -jN. Hence # perform the locking at all times, it shouldn't hurt. # the lock fh *should* inherit across forks/subprocesses - # - # File locking is hard. Really hard. By far the best lock implementation - # I've seen is part of the guts of File::Temp. However it is sadly not - # reusable. Since I am not aware of folks doing NFS parallel testing, - # nor are we known to work on VMS, I am just going to punt this and - # use the portable-ish flock() provided by perl itself. If this does - # not work for you - patches more than welcome. if ( ! $DBICTest::global_exclusive_lock and @@ -153,31 +263,37 @@ sub connection { and ref($_[0]) ne 'CODE' and - ($_[0]||'') !~ /^ (?i:dbi) \: SQLite \: (?: dbname\= )? (?: \:memory\: | t [\/\\] var [\/\\] DBIxClass\-) /x + ($_[0]||'') !~ /^ (?i:dbi) \: SQLite (?: \: | \W ) .*? (?: dbname\= )? (?: \:memory\: | t [\/\\] var [\/\\] DBIxClass\-) /x ) { - my $locktype = do { + my $locktype; + + { # guard against infinite recursion local $ENV{DBICTEST_LOCK_HOLDER} = -1; - # we need to connect a forced fresh clone so that we do not upset any state + # 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__} if $SIG{__DIE__}; local $@; - my $storage = eval { - my $st = ref($self)->connect(@{$self->storage->connect_info})->storage; - $st->ensure_connected; # do connect here, to catch a possible throw - $st; + + # this will either give us an undef $locktype or will determine things + # properly with a default ( possibly connecting in the process ) + eval { + my $cur_storage = $self->storage; + + $cur_storage = $cur_storage->master + if $cur_storage->isa('DBIx::Class::Storage::DBI::Replicated'); + + my $s = ref($self)->connect(@{$cur_storage->connect_info})->storage; + + $locktype = $s->sqlt_type || 'generic'; + + # in case sqlt_type did connect, doesn't matter if it fails or something + $s->disconnect; }; - $storage - ? do { - my $t = $storage->sqlt_type || 'generic'; - eval { $storage->disconnect }; - $t; - } - : undef - ; - }; + } # Never hold more than one lock. This solves the "lock in order" issues # unrelated tests may have @@ -186,18 +302,27 @@ sub connection { # this will release whatever lock we may currently be holding # which is fine since the type does not match as checked above + DEBUG_TEST_CONCURRENCY_LOCKS + and $locker + and dbg "$locker->{type} LOCK RELEASED (UNDEF): $locker->{lock_name}"; + undef $locker; - my $lockpath = DBICTest::RunMode->tmpdir->file("_dbictest_$locktype.lock"); + my $lockpath = tmpdir . "_dbictest_$locktype.lock"; + + DEBUG_TEST_CONCURRENCY_LOCKS + and dbg "Waiting for $locktype LOCK: $lockpath..."; - #warn "$$ $0 $locktype GRABBING LOCK"; my $lock_fh; { my $u = local_umask(0); # so that the file opens as 666, and any user can lock sysopen ($lock_fh, $lockpath, O_RDWR|O_CREAT) or die "Unable to open $lockpath: $!"; } - flock ($lock_fh, LOCK_EX) or die "Unable to lock $lockpath: $!"; - #warn "$$ $0 $locktype LOCK GRABBED"; + + await_flock ($lock_fh, LOCK_EX) or die "Unable to lock $lockpath: $!"; + + DEBUG_TEST_CONCURRENCY_LOCKS + and dbg "Got $locktype LOCK: $lockpath"; # see if anyone was holding a lock before us, and wait up to 5 seconds for them to terminate # if we do not do this we may end up trampling over some long-running END or somesuch @@ -208,12 +333,17 @@ sub connection { and ($old_pid) = $old_pid =~ /^(\d+)$/ ) { + DEBUG_TEST_CONCURRENCY_LOCKS + and dbg "Post-grab WAIT for $old_pid START: $lockpath"; + for (1..50) { kill (0, $old_pid) or last; - sleep 0.1; + select( undef, undef, undef, 0.1 ); } + + DEBUG_TEST_CONCURRENCY_LOCKS + and dbg "Post-grab WAIT for $old_pid FINISHED: $lockpath"; } - #warn "$$ $0 $locktype POST GRAB WAIT"; truncate $lock_fh, 0; seek ($lock_fh, 0, SEEK_SET) or die "seek failed $!"; @@ -246,6 +376,157 @@ 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', + ); + + + &$orig_rsrc; + }; + + weaken( $assertion_arounds->{refaddr $replacement} = $replacement ); + } + + + # 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, + show_dups => 1, + ); + + &$orig_rsrc_instance; + }; + + weaken( $assertion_arounds->{refaddr $replacement} = $replacement ); + } + + } + + Class::C3::initialize if DBIx::Class::_ENV_::OLD_MRO; + } + # + # END Check an explicit level of indirection + return $self; } @@ -257,7 +538,10 @@ sub clone { } END { - assert_empty_weakregistry($weak_registry, 'quiet'); + # Make sure we run after any cleanup in other END blocks + push @{ B::end_av()->object_2svref }, sub { + assert_empty_weakregistry($weak_registry, 'quiet'); + }; } 1;