Commit | Line | Data |
27a701f9 |
1 | package #hide from pause |
2 | DBICTest::BaseSchema; |
3 | |
4 | use strict; |
5 | use warnings; |
bedbc811 |
6 | use base qw(DBICTest::Base DBIx::Class::Schema); |
27a701f9 |
7 | |
e952df76 |
8 | use Fcntl qw(:DEFAULT :seek :flock); |
e48635f7 |
9 | use IO::Handle (); |
e570488a |
10 | use DBIx::Class::_Util qw( emit_loud_diag scope_guard set_subname get_subname ); |
e952df76 |
11 | use DBICTest::Util::LeakTracer qw(populate_weakregistry assert_empty_weakregistry); |
439a7283 |
12 | use DBICTest::Util qw( local_umask tmpdir await_flock dbg DEBUG_TEST_CONCURRENCY_LOCKS ); |
e570488a |
13 | use Scalar::Util qw( refaddr weaken ); |
e952df76 |
14 | use namespace::clean; |
15 | |
ddcc02d1 |
16 | if( $ENV{DBICTEST_ASSERT_NO_SPURIOUS_EXCEPTION_ACTION} ) { |
5c33c8be |
17 | my $ea = __PACKAGE__->exception_action( sub { |
ddcc02d1 |
18 | |
44c1a75d |
19 | # Can not rely on $^S here at all - the exception_action |
20 | # itself is always called in an eval so that the goto-guard |
21 | # can work (see 7cb35852) |
22 | |
23 | my ( $fr_num, $disarmed, $throw_exception_fr_num, $eval_fr_num ); |
ddcc02d1 |
24 | while( ! $disarmed and my @fr = caller(++$fr_num) ) { |
25 | |
26 | $throw_exception_fr_num ||= ( |
44c1a75d |
27 | $fr[3] =~ /^DBIx::Class::(?:ResultSource|Schema|Storage|Exception)::throw(?:_exception)?$/ |
28 | and |
29 | # there may be evals in the throwers themselves - skip those |
30 | ( $eval_fr_num ) = ( undef ) |
31 | and |
32 | $fr_num |
33 | ); |
34 | |
35 | # now that the above stops un-setting us, we can find the first |
36 | # ineresting eval |
37 | $eval_fr_num ||= ( |
38 | $fr[3] eq '(eval)' |
ddcc02d1 |
39 | and |
40 | $fr_num |
41 | ); |
42 | |
43 | $disarmed = !! ( |
44 | $fr[1] =~ / \A (?: \. [\/\\] )? x?t [\/\\] .+ \.t \z /x |
45 | and |
46 | ( |
47 | $fr[3] =~ /\A (?: |
48 | Test::Exception::throws_ok |
49 | | |
50 | Test::Exception::dies_ok |
51 | | |
52 | Try::Tiny::try |
53 | | |
54 | \Q(eval)\E |
55 | ) \z /x |
56 | or |
57 | ( |
58 | $fr[3] eq 'Test::Exception::lives_ok' |
59 | and |
60 | ( $::TODO or Test::Builder->new->in_todo ) |
61 | ) |
62 | ) |
63 | ); |
64 | } |
65 | |
66 | Test::Builder->new->ok(0, join "\n", |
67 | 'Unexpected &exception_action invocation', |
68 | '', |
69 | ' You almost certainly used eval/try instead of dbic_internal_try()', |
70 | " Adjust *one* of the eval-ish constructs in the callstack starting" . DBICTest::Util::stacktrace($throw_exception_fr_num||()) |
44c1a75d |
71 | ) if ( |
72 | ! $disarmed |
73 | and |
74 | ( |
75 | $eval_fr_num |
76 | or |
77 | ! $throw_exception_fr_num |
78 | ) |
79 | ); |
ddcc02d1 |
80 | |
81 | DBIx::Class::Exception->throw( $_[0] ); |
5c33c8be |
82 | }); |
83 | |
84 | my $interesting_ns_rx = qr/^ (?: main$ | DBIx::Class:: | DBICTest:: ) /x; |
85 | |
86 | # hard-set $SIG{__DIE__} to the class-wide exception_action |
87 | # with a little escape preceeding it |
88 | $SIG{__DIE__} = sub { |
89 | |
90 | # without this there would be false positives everywhere :( |
91 | die @_ if ( |
44c1a75d |
92 | # blindly rethrow if nobody is waiting for us |
93 | ( defined $^S and ! $^S ) |
94 | or |
5c33c8be |
95 | (caller(0))[0] !~ $interesting_ns_rx |
96 | or |
97 | ( |
98 | caller(0) eq 'main' |
99 | and |
4ee643f5 |
100 | ( (caller(1))[0] || '' ) !~ $interesting_ns_rx |
5c33c8be |
101 | ) |
102 | ); |
103 | |
104 | &$ea; |
105 | }; |
ddcc02d1 |
106 | } |
107 | |
2cfc22dd |
108 | sub capture_executed_sql_bind { |
109 | my ($self, $cref) = @_; |
110 | |
111 | $self->throw_exception("Expecting a coderef to run") unless ref $cref eq 'CODE'; |
112 | |
4faaf174 |
113 | require DBICTest::SQLTracerObj; |
114 | |
2cfc22dd |
115 | # hack around stupid, stupid API |
116 | no warnings 'redefine'; |
117 | local *DBIx::Class::Storage::DBI::_format_for_trace = sub { $_[1] }; |
118 | Class::C3->reinitialize if DBIx::Class::_ENV_::OLD_MRO; |
119 | |
b74b15b0 |
120 | # can not use local() due to an unknown number of storages |
121 | # (think replicated) |
122 | my $orig_states = { map |
123 | { $_ => $self->storage->$_ } |
124 | qw(debugcb debugobj debug) |
125 | }; |
4faaf174 |
126 | |
bbf6a9a5 |
127 | my $sg = scope_guard { |
b74b15b0 |
128 | $self->storage->$_ ( $orig_states->{$_} ) for keys %$orig_states; |
bbf6a9a5 |
129 | }; |
b74b15b0 |
130 | |
131 | $self->storage->debugcb(undef); |
132 | $self->storage->debugobj( my $tracer_obj = DBICTest::SQLTracerObj->new ); |
133 | $self->storage->debug(1); |
2cfc22dd |
134 | |
49eeb48d |
135 | local $Test::Builder::Level = $Test::Builder::Level + 2; |
2cfc22dd |
136 | $cref->(); |
137 | |
138 | return $tracer_obj->{sqlbinds} || []; |
139 | } |
140 | |
49eeb48d |
141 | sub is_executed_querycount { |
142 | my ($self, $cref, $exp_counts, $msg) = @_; |
143 | |
144 | local $Test::Builder::Level = $Test::Builder::Level + 1; |
145 | |
146 | $self->throw_exception("Expecting an hashref of counts or an integer representing total query count") |
147 | unless ref $exp_counts eq 'HASH' or (defined $exp_counts and ! ref $exp_counts); |
148 | |
149 | my @got = map { $_->[0] } @{ $self->capture_executed_sql_bind($cref) }; |
150 | |
151 | return Test::More::is( @got, $exp_counts, $msg ) |
152 | unless ref $exp_counts; |
153 | |
154 | my $got_counts = { map { $_ => 0 } keys %$exp_counts }; |
155 | $got_counts->{$_}++ for @got; |
156 | |
157 | return Test::More::is_deeply( |
158 | $got_counts, |
159 | $exp_counts, |
160 | $msg, |
161 | ); |
162 | } |
163 | |
2cfc22dd |
164 | sub is_executed_sql_bind { |
165 | my ($self, $cref, $sqlbinds, $msg) = @_; |
166 | |
167 | local $Test::Builder::Level = $Test::Builder::Level + 1; |
168 | |
169 | $self->throw_exception("Expecting an arrayref of SQL/Bind pairs") unless ref $sqlbinds eq 'ARRAY'; |
170 | |
171 | my @expected = @$sqlbinds; |
172 | |
173 | my @got = map { $_->[1] } @{ $self->capture_executed_sql_bind($cref) }; |
174 | |
175 | |
176 | return Test::Builder->new->ok(1, $msg || "No queries executed while running $cref") |
177 | if !@got and !@expected; |
178 | |
179 | require SQL::Abstract::Test; |
180 | my $ret = 1; |
181 | while (@expected or @got) { |
182 | my $left = shift @got; |
183 | my $right = shift @expected; |
184 | |
185 | # allow the right side to "simplify" the entire shebang |
186 | if ($left and $right) { |
187 | $left = [ @$left ]; |
188 | for my $i (1..$#$right) { |
189 | if ( |
190 | ! ref $right->[$i] |
191 | and |
192 | ref $left->[$i] eq 'ARRAY' |
193 | and |
194 | @{$left->[$i]} == 2 |
195 | ) { |
196 | $left->[$i] = $left->[$i][1] |
197 | } |
198 | } |
199 | } |
200 | |
201 | $ret &= SQL::Abstract::Test::is_same_sql_bind( |
202 | \( $left || [] ), |
203 | \( $right || [] ), |
204 | $msg, |
205 | ); |
206 | } |
207 | |
208 | return $ret; |
209 | } |
210 | |
e952df76 |
211 | our $locker; |
212 | END { |
213 | # we need the $locker to be referenced here for delayed destruction |
214 | if ($locker->{lock_name} and ($ENV{DBICTEST_LOCK_HOLDER}||0) == $$) { |
69016f65 |
215 | DEBUG_TEST_CONCURRENCY_LOCKS |
216 | and dbg "$locker->{type} LOCK RELEASED (END): $locker->{lock_name}"; |
e952df76 |
217 | } |
218 | } |
219 | |
e570488a |
220 | my ( $weak_registry, $assertion_arounds ) = ( {}, {} ); |
221 | |
222 | sub DBICTest::__RsrcRedefiner_iThreads_handler__::CLONE { |
223 | if( DBIx::Class::_ENV_::ASSERT_NO_ERRONEOUS_METAINSTANCE_USE ) { |
224 | %$assertion_arounds = map { |
225 | (defined $_) |
226 | ? ( refaddr($_) => $_ ) |
227 | : () |
228 | } values %$assertion_arounds; |
229 | |
230 | weaken($_) for values %$assertion_arounds; |
231 | } |
232 | } |
e952df76 |
233 | |
234 | sub connection { |
235 | my $self = shift->next::method(@_); |
236 | |
237 | # MASSIVE FIXME |
238 | # we can't really lock based on DSN, as we do not yet have a way to tell that e.g. |
239 | # DBICTEST_MSSQL_DSN=dbi:Sybase:server=192.168.0.11:1433;database=dbtst |
240 | # and |
241 | # DBICTEST_MSSQL_ODBC_DSN=dbi:ODBC:server=192.168.0.11;port=1433;database=dbtst;driver=FreeTDS;tds_version=8.0 |
242 | # are the same server |
243 | # hence we lock everything based on sqlt_type or just globally if not available |
244 | # just pretend we are python you know? :) |
245 | |
246 | |
247 | # when we get a proper DSN resolution sanitize to produce a portable lockfile name |
248 | # this may look weird and unnecessary, but consider running tests from |
249 | # windows over a samba share >.> |
250 | #utf8::encode($dsn); |
251 | #$dsn =~ s/([^A-Za-z0-9_\-\.\=])/ sprintf '~%02X', ord($1) /ge; |
252 | #$dsn =~ s/^dbi/dbi/i; |
253 | |
254 | # provide locking for physical (non-memory) DSNs, so that tests can |
255 | # safely run in parallel. While the harness (make -jN test) does set |
256 | # an envvar, we can not detect when a user invokes prove -jN. Hence |
257 | # perform the locking at all times, it shouldn't hurt. |
258 | # the lock fh *should* inherit across forks/subprocesses |
e952df76 |
259 | if ( |
260 | ! $DBICTest::global_exclusive_lock |
261 | and |
262 | ( ! $ENV{DBICTEST_LOCK_HOLDER} or $ENV{DBICTEST_LOCK_HOLDER} == $$ ) |
263 | and |
264 | ref($_[0]) ne 'CODE' |
265 | and |
e4328872 |
266 | ($_[0]||'') !~ /^ (?i:dbi) \: SQLite (?: \: | \W ) .*? (?: dbname\= )? (?: \:memory\: | t [\/\\] var [\/\\] DBIxClass\-) /x |
e952df76 |
267 | ) { |
268 | |
0f6d86e4 |
269 | my $locktype; |
270 | |
271 | { |
e952df76 |
272 | # guard against infinite recursion |
273 | local $ENV{DBICTEST_LOCK_HOLDER} = -1; |
274 | |
0f6d86e4 |
275 | # we need to work with a forced fresh clone so that we do not upset any state |
e952df76 |
276 | # of the main $schema (some tests examine it quite closely) |
277 | local $SIG{__WARN__} = sub {}; |
7db939de |
278 | local $SIG{__DIE__} if $SIG{__DIE__}; |
e952df76 |
279 | local $@; |
0f6d86e4 |
280 | |
281 | # this will either give us an undef $locktype or will determine things |
282 | # properly with a default ( possibly connecting in the process ) |
283 | eval { |
bf726d9c |
284 | my $cur_storage = $self->storage; |
285 | |
286 | $cur_storage = $cur_storage->master |
287 | if $cur_storage->isa('DBIx::Class::Storage::DBI::Replicated'); |
288 | |
289 | my $s = ref($self)->connect(@{$cur_storage->connect_info})->storage; |
0f6d86e4 |
290 | |
291 | $locktype = $s->sqlt_type || 'generic'; |
292 | |
293 | # in case sqlt_type did connect, doesn't matter if it fails or something |
294 | $s->disconnect; |
e952df76 |
295 | }; |
0f6d86e4 |
296 | } |
e952df76 |
297 | |
298 | # Never hold more than one lock. This solves the "lock in order" issues |
299 | # unrelated tests may have |
300 | # Also if there is no connection - there is no lock to be had |
301 | if ($locktype and (!$locker or $locker->{type} ne $locktype)) { |
302 | |
303 | # this will release whatever lock we may currently be holding |
304 | # which is fine since the type does not match as checked above |
69016f65 |
305 | DEBUG_TEST_CONCURRENCY_LOCKS |
306 | and $locker |
307 | and dbg "$locker->{type} LOCK RELEASED (UNDEF): $locker->{lock_name}"; |
308 | |
e952df76 |
309 | undef $locker; |
310 | |
439a7283 |
311 | my $lockpath = tmpdir . "_dbictest_$locktype.lock"; |
e952df76 |
312 | |
69016f65 |
313 | DEBUG_TEST_CONCURRENCY_LOCKS |
314 | and dbg "Waiting for $locktype LOCK: $lockpath..."; |
315 | |
e952df76 |
316 | my $lock_fh; |
317 | { |
318 | my $u = local_umask(0); # so that the file opens as 666, and any user can lock |
319 | sysopen ($lock_fh, $lockpath, O_RDWR|O_CREAT) or die "Unable to open $lockpath: $!"; |
320 | } |
69016f65 |
321 | |
630e2ea8 |
322 | await_flock ($lock_fh, LOCK_EX) or die "Unable to lock $lockpath: $!"; |
69016f65 |
323 | |
324 | DEBUG_TEST_CONCURRENCY_LOCKS |
325 | and dbg "Got $locktype LOCK: $lockpath"; |
e952df76 |
326 | |
327 | # see if anyone was holding a lock before us, and wait up to 5 seconds for them to terminate |
328 | # if we do not do this we may end up trampling over some long-running END or somesuch |
329 | seek ($lock_fh, 0, SEEK_SET) or die "seek failed $!"; |
330 | my $old_pid; |
331 | if ( |
332 | read ($lock_fh, $old_pid, 100) |
333 | and |
334 | ($old_pid) = $old_pid =~ /^(\d+)$/ |
335 | ) { |
69016f65 |
336 | DEBUG_TEST_CONCURRENCY_LOCKS |
337 | and dbg "Post-grab WAIT for $old_pid START: $lockpath"; |
338 | |
e952df76 |
339 | for (1..50) { |
340 | kill (0, $old_pid) or last; |
5a8d5308 |
341 | select( undef, undef, undef, 0.1 ); |
e952df76 |
342 | } |
69016f65 |
343 | |
344 | DEBUG_TEST_CONCURRENCY_LOCKS |
345 | and dbg "Post-grab WAIT for $old_pid FINISHED: $lockpath"; |
e952df76 |
346 | } |
e952df76 |
347 | |
348 | truncate $lock_fh, 0; |
349 | seek ($lock_fh, 0, SEEK_SET) or die "seek failed $!"; |
350 | $lock_fh->autoflush(1); |
351 | print $lock_fh $$; |
352 | |
353 | $ENV{DBICTEST_LOCK_HOLDER} ||= $$; |
354 | |
355 | $locker = { |
356 | type => $locktype, |
357 | fh => $lock_fh, |
358 | lock_name => "$lockpath", |
359 | }; |
360 | } |
361 | } |
362 | |
363 | if ($INC{'Test/Builder.pm'}) { |
364 | populate_weakregistry ( $weak_registry, $self->storage ); |
365 | |
366 | my $cur_connect_call = $self->storage->on_connect_call; |
367 | |
368 | $self->storage->on_connect_call([ |
369 | (ref $cur_connect_call eq 'ARRAY' |
370 | ? @$cur_connect_call |
371 | : ($cur_connect_call || ()) |
372 | ), |
373 | [sub { |
374 | populate_weakregistry( $weak_registry, shift->_dbh ) |
375 | }], |
376 | ]); |
377 | } |
378 | |
e570488a |
379 | # |
380 | # Check an explicit level of indirection: makes sure that folks doing |
381 | # use `base "DBIx::Class::Core"; __PACKAGE__->add_column("foo")` |
382 | # will see the correct error message |
383 | # |
384 | # In the future this all is likely to be folded into a single method in |
385 | # some way, but that's a fight for another maint |
386 | # |
387 | if( DBIx::Class::_ENV_::ASSERT_NO_ERRONEOUS_METAINSTANCE_USE ) { |
388 | |
389 | for my $class_of_interest ( |
390 | 'DBIx::Class::Row', |
391 | map { $self->class($_) } ($self->sources) |
392 | ) { |
393 | |
394 | my $orig_rsrc = $class_of_interest->can('result_source') |
395 | or die "How did we get here?!"; |
396 | |
397 | unless ( $assertion_arounds->{refaddr $orig_rsrc} ) { |
398 | |
399 | my ($origin) = get_subname($orig_rsrc); |
400 | |
401 | no warnings 'redefine'; |
402 | no strict 'refs'; |
403 | |
404 | *{"${origin}::result_source"} = my $replacement = set_subname "${origin}::result_source" => sub { |
405 | |
406 | |
407 | @_ > 1 |
408 | and |
409 | (CORE::caller(0))[1] !~ / (?: ^ | [\/\\] ) x?t [\/\\] .+? \.t $ /x |
410 | and |
411 | emit_loud_diag( |
412 | msg => 'Incorrect indirect call of result_source() as setter must be changed to result_source_instance()', |
413 | confess => 1, |
414 | ); |
415 | |
416 | |
417 | grep { |
418 | ! (CORE::caller($_))[7] |
419 | and |
420 | ( (CORE::caller($_))[3] || '' ) eq '(eval)' |
421 | and |
422 | ( (CORE::caller($_))[1] || '' ) !~ / (?: ^ | [\/\\] ) x?t [\/\\] .+? \.t $ /x |
423 | } (0..2) |
424 | and |
425 | # these evals are legit |
426 | ( (CORE::caller(4))[3] || '' ) !~ /^ (?: |
427 | DBIx::Class::Schema::_ns_get_rsrc_instance |
428 | | |
429 | DBIx::Class::Relationship::BelongsTo::belongs_to |
430 | | |
431 | DBIx::Class::Relationship::HasOne::_has_one |
432 | | |
433 | Class::C3::Componentised::.+ |
434 | ) $/x |
435 | and |
436 | emit_loud_diag( |
437 | # not much else we can do (aside from exit(1) which is too obnoxious) |
438 | msg => 'Incorrect call of result_source() in an eval', |
439 | ); |
440 | |
441 | |
442 | &$orig_rsrc; |
443 | }; |
444 | |
445 | weaken( $assertion_arounds->{refaddr $replacement} = $replacement ); |
446 | } |
447 | |
448 | |
449 | # no rsrc_instance to mangle |
450 | next if $class_of_interest eq 'DBIx::Class::Row'; |
451 | |
452 | |
453 | my $orig_rsrc_instance = $class_of_interest->can('result_source_instance') |
454 | or die "How did we get here?!"; |
455 | |
456 | # Do the around() per definition-site as result_source_instance is a CAG inherited cref |
457 | unless ( $assertion_arounds->{refaddr $orig_rsrc_instance} ) { |
458 | |
459 | my ($origin) = get_subname($orig_rsrc_instance); |
460 | |
461 | no warnings 'redefine'; |
462 | no strict 'refs'; |
463 | |
464 | *{"${origin}::result_source_instance"} = my $replacement = set_subname "${origin}::result_source_instance" => sub { |
465 | |
466 | |
467 | @_ == 1 |
468 | and |
469 | # special cased as we do not care whether there is a source |
470 | ( (CORE::caller(4))[3] || '' ) ne 'DBIx::Class::Schema::_register_source' |
471 | and |
472 | # special case because I am paranoid |
473 | ( (CORE::caller(4))[3] || '' ) ne 'DBIx::Class::Row::throw_exception' |
474 | and |
475 | ( (CORE::caller(1))[3] || '' ) !~ / ^ DBIx::Class:: (?: |
476 | Row::result_source |
477 | | |
478 | Row::throw_exception |
479 | | |
480 | ResultSourceProxy::Table:: (?: _init_result_source_instance | table ) |
481 | | |
482 | ResultSourceHandle::STORABLE_thaw |
483 | ) $ /x |
484 | and |
485 | (CORE::caller(0))[1] !~ / (?: ^ | [\/\\] ) x?t [\/\\] .+? \.t $ /x |
486 | and |
487 | emit_loud_diag( |
488 | msg => 'Incorrect direct call of result_source_instance() as getter must be changed to result_source()', |
489 | confess => 1 |
490 | ); |
491 | |
492 | |
493 | grep { |
494 | ! (CORE::caller($_))[7] |
495 | and |
496 | ( (CORE::caller($_))[3] || '' ) eq '(eval)' |
497 | and |
498 | ( (CORE::caller($_))[1] || '' ) !~ / (?: ^ | [\/\\] ) x?t [\/\\] .+? \.t $ /x |
499 | } (0..2) |
500 | and |
501 | # special cased as we do not care whether there is a source |
502 | ( (CORE::caller(4))[3] || '' ) ne 'DBIx::Class::Schema::_register_source' |
503 | and |
504 | # special case because I am paranoid |
505 | ( (CORE::caller(4))[3] || '' ) ne 'DBIx::Class::Row::throw_exception' |
506 | and |
507 | # special case for Storable, which in turn calls from an eval |
508 | ( (CORE::caller(1))[3] || '' ) ne 'DBIx::Class::ResultSourceHandle::STORABLE_thaw' |
509 | and |
510 | emit_loud_diag( |
511 | # not much else we can do (aside from exit(1) which is too obnoxious) |
512 | msg => 'Incorrect call of result_source_instance() in an eval', |
513 | skip_frames => 1, |
514 | show_dups => 1, |
515 | ); |
516 | |
517 | &$orig_rsrc_instance; |
518 | }; |
519 | |
520 | weaken( $assertion_arounds->{refaddr $replacement} = $replacement ); |
521 | } |
522 | |
523 | } |
524 | |
525 | Class::C3::initialize if DBIx::Class::_ENV_::OLD_MRO; |
526 | } |
527 | # |
528 | # END Check an explicit level of indirection |
529 | |
e952df76 |
530 | return $self; |
531 | } |
532 | |
533 | sub clone { |
534 | my $self = shift->next::method(@_); |
535 | populate_weakregistry ( $weak_registry, $self ) |
536 | if $INC{'Test/Builder.pm'}; |
537 | $self; |
538 | } |
539 | |
540 | END { |
961d79db |
541 | # Make sure we run after any cleanup in other END blocks |
961d79db |
542 | push @{ B::end_av()->object_2svref }, sub { |
543 | assert_empty_weakregistry($weak_registry, 'quiet'); |
544 | }; |
e952df76 |
545 | } |
27a701f9 |
546 | |
547 | 1; |