t/lib/DBICTest/BaseSchema.pm

   1 package #hide from pause
   2   DBICTest::BaseSchema;
   3
   4 use strict;
   5 use warnings;
   6 use base qw(DBICTest::Base DBIx::Class::Schema);
   7
   8 use Fcntl qw(:DEFAULT :seek :flock);
   9 use IO::Handle ();
  10 use DBIx::Class::_Util qw( emit_loud_diag scope_guard set_subname get_subname );
  11 use DBICTest::Util::LeakTracer qw(populate_weakregistry assert_empty_weakregistry);
  12 use DBICTest::Util qw( local_umask tmpdir await_flock dbg DEBUG_TEST_CONCURRENCY_LOCKS );
  13 use Scalar::Util qw( refaddr weaken );
  14 use Devel::GlobalDestruction ();
  15 use namespace::clean;
  16
  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
  63 if( $ENV{DBICTEST_ASSERT_NO_SPURIOUS_EXCEPTION_ACTION} ) {
  64   my $ea = __PACKAGE__->exception_action( sub {
  65
  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 );
  71     while( ! $disarmed and my @fr = caller(++$fr_num) ) {
  72
  73       $throw_exception_fr_num ||= (
  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)'
  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||())
 118     ) if (
 119       ! $disarmed
 120         and
 121       (
 122         $eval_fr_num
 123           or
 124         ! $throw_exception_fr_num
 125       )
 126     );
 127
 128     DBIx::Class::Exception->throw( $_[0] );
 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 (
 139       # blindly rethrow if nobody is waiting for us
 140       ( defined $^S and ! $^S )
 141         or
 142       (caller(0))[0] !~ $interesting_ns_rx
 143         or
 144       (
 145         caller(0) eq 'main'
 146           and
 147         ( (caller(1))[0] || '' ) !~ $interesting_ns_rx
 148       )
 149     );
 150
 151     &$ea;
 152   };
 153 }
 154
 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
 160   require DBICTest::SQLTracerObj;
 161
 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
 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   };
 173
 174   my $sg = scope_guard {
 175     $self->storage->$_ ( $orig_states->{$_} ) for keys %$orig_states;
 176   };
 177
 178   $self->storage->debugcb(undef);
 179   $self->storage->debugobj( my $tracer_obj = DBICTest::SQLTracerObj->new );
 180   $self->storage->debug(1);
 181
 182   local $Test::Builder::Level = $Test::Builder::Level + 2;
 183   $cref->();
 184
 185   return $tracer_obj->{sqlbinds} || [];
 186 }
 187
 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
 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
 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) == $$) {
 262     DEBUG_TEST_CONCURRENCY_LOCKS
 263       and dbg "$locker->{type} LOCK RELEASED (END): $locker->{lock_name}";
 264   }
 265 }
 266
 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 }
 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
 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
 313     ($_[0]||'') !~ /^ (?i:dbi) \: SQLite (?: \: | \W ) .*? (?: dbname\= )? (?: \:memory\: | t [\/\\] var [\/\\] DBIxClass\-) /x
 314   ) {
 315
 316     my $locktype;
 317
 318     {
 319       # guard against infinite recursion
 320       local $ENV{DBICTEST_LOCK_HOLDER} = -1;
 321
 322       # we need to work with a forced fresh clone so that we do not upset any state
 323       # of the main $schema (some tests examine it quite closely)
 324       local $SIG{__WARN__} = sub {};
 325       local $SIG{__DIE__} if $SIG{__DIE__};
 326       local $@;
 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 {
 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;
 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;
 342       };
 343     }
 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
 352       DEBUG_TEST_CONCURRENCY_LOCKS
 353         and $locker
 354         and dbg "$locker->{type} LOCK RELEASED (UNDEF): $locker->{lock_name}";
 355
 356       undef $locker;
 357
 358       my $lockpath = tmpdir . "_dbictest_$locktype.lock";
 359
 360       DEBUG_TEST_CONCURRENCY_LOCKS
 361         and dbg "Waiting for $locktype LOCK: $lockpath...";
 362
 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       }
 368
 369       await_flock ($lock_fh, LOCK_EX) or die "Unable to lock $lockpath: $!";
 370
 371       DEBUG_TEST_CONCURRENCY_LOCKS
 372         and dbg "Got $locktype LOCK: $lockpath";
 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       ) {
 383         DEBUG_TEST_CONCURRENCY_LOCKS
 384           and dbg "Post-grab WAIT for $old_pid START: $lockpath";
 385
 386         for (1..50) {
 387           kill (0, $old_pid) or last;
 388           select( undef, undef, undef, 0.1 );
 389         }
 390
 391         DEBUG_TEST_CONCURRENCY_LOCKS
 392           and dbg "Post-grab WAIT for $old_pid FINISHED: $lockpath";
 393       }
 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
 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 );
 493
 494         attributes->import(
 495           $origin,
 496           $replacement,
 497           attributes::get($orig_rsrc)
 498         );
 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 );
 574
 575         attributes->import(
 576           $origin,
 577           $replacement,
 578           attributes::get($orig_rsrc_instance)
 579         );
 580       }
 581     }
 582
 583     Class::C3::initialize if DBIx::Class::_ENV_::OLD_MRO;
 584   }
 585   #
 586   # END Check an explicit level of indirection
 587
 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 {
 599   # Make sure we run after any cleanup in other END blocks
 600   push @{ B::end_av()->object_2svref }, sub {
 601     assert_empty_weakregistry($weak_registry, 'quiet');
 602   };
 603 }
 604
 605 1;