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