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 namespace::clean;
  15
  16 if( $ENV{DBICTEST_ASSERT_NO_SPURIOUS_EXCEPTION_ACTION} ) {
  17   my $ea = __PACKAGE__->exception_action( sub {
  18
  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 );
  24     while( ! $disarmed and my @fr = caller(++$fr_num) ) {
  25
  26       $throw_exception_fr_num ||= (
  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)'
  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||())
  71     ) if (
  72       ! $disarmed
  73         and
  74       (
  75         $eval_fr_num
  76           or
  77         ! $throw_exception_fr_num
  78       )
  79     );
  80
  81     DBIx::Class::Exception->throw( $_[0] );
  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 (
  92       # blindly rethrow if nobody is waiting for us
  93       ( defined $^S and ! $^S )
  94         or
  95       (caller(0))[0] !~ $interesting_ns_rx
  96         or
  97       (
  98         caller(0) eq 'main'
  99           and
 100         ( (caller(1))[0] || '' ) !~ $interesting_ns_rx
 101       )
 102     );
 103
 104     &$ea;
 105   };
 106 }
 107
 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
 113   require DBICTest::SQLTracerObj;
 114
 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
 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   };
 126
 127   my $sg = scope_guard {
 128     $self->storage->$_ ( $orig_states->{$_} ) for keys %$orig_states;
 129   };
 130
 131   $self->storage->debugcb(undef);
 132   $self->storage->debugobj( my $tracer_obj = DBICTest::SQLTracerObj->new );
 133   $self->storage->debug(1);
 134
 135   local $Test::Builder::Level = $Test::Builder::Level + 2;
 136   $cref->();
 137
 138   return $tracer_obj->{sqlbinds} || [];
 139 }
 140
 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
 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
 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) == $$) {
 215     DEBUG_TEST_CONCURRENCY_LOCKS
 216       and dbg "$locker->{type} LOCK RELEASED (END): $locker->{lock_name}";
 217   }
 218 }
 219
 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 }
 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
 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
 266     ($_[0]||'') !~ /^ (?i:dbi) \: SQLite (?: \: | \W ) .*? (?: dbname\= )? (?: \:memory\: | t [\/\\] var [\/\\] DBIxClass\-) /x
 267   ) {
 268
 269     my $locktype;
 270
 271     {
 272       # guard against infinite recursion
 273       local $ENV{DBICTEST_LOCK_HOLDER} = -1;
 274
 275       # we need to work with a forced fresh clone so that we do not upset any state
 276       # of the main $schema (some tests examine it quite closely)
 277       local $SIG{__WARN__} = sub {};
 278       local $SIG{__DIE__} if $SIG{__DIE__};
 279       local $@;
 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 {
 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;
 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;
 295       };
 296     }
 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
 305       DEBUG_TEST_CONCURRENCY_LOCKS
 306         and $locker
 307         and dbg "$locker->{type} LOCK RELEASED (UNDEF): $locker->{lock_name}";
 308
 309       undef $locker;
 310
 311       my $lockpath = tmpdir . "_dbictest_$locktype.lock";
 312
 313       DEBUG_TEST_CONCURRENCY_LOCKS
 314         and dbg "Waiting for $locktype LOCK: $lockpath...";
 315
 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       }
 321
 322       await_flock ($lock_fh, LOCK_EX) or die "Unable to lock $lockpath: $!";
 323
 324       DEBUG_TEST_CONCURRENCY_LOCKS
 325         and dbg "Got $locktype LOCK: $lockpath";
 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       ) {
 336         DEBUG_TEST_CONCURRENCY_LOCKS
 337           and dbg "Post-grab WAIT for $old_pid START: $lockpath";
 338
 339         for (1..50) {
 340           kill (0, $old_pid) or last;
 341           select( undef, undef, undef, 0.1 );
 342         }
 343
 344         DEBUG_TEST_CONCURRENCY_LOCKS
 345           and dbg "Post-grab WAIT for $old_pid FINISHED: $lockpath";
 346       }
 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
 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         attributes->import(
 448           $origin,
 449           $replacement,
 450           attributes::get($orig_rsrc)
 451         );
 452       }
 453
 454
 455       # no rsrc_instance to mangle
 456       next if $class_of_interest eq 'DBIx::Class::Row';
 457
 458
 459       my $orig_rsrc_instance = $class_of_interest->can('result_source_instance')
 460         or die "How did we get here?!";
 461
 462       # Do the around() per definition-site as result_source_instance is a CAG inherited cref
 463       unless ( $assertion_arounds->{refaddr $orig_rsrc_instance} ) {
 464
 465         my ($origin) = get_subname($orig_rsrc_instance);
 466
 467         no warnings 'redefine';
 468         no strict 'refs';
 469
 470         *{"${origin}::result_source_instance"} = my $replacement = set_subname "${origin}::result_source_instance" => sub {
 471
 472
 473           @_ == 1
 474             and
 475           # special cased as we do not care whether there is a source
 476           ( (CORE::caller(4))[3] || '' ) ne 'DBIx::Class::Schema::_register_source'
 477             and
 478           # special case because I am paranoid
 479           ( (CORE::caller(4))[3] || '' ) ne 'DBIx::Class::Row::throw_exception'
 480             and
 481           ( (CORE::caller(1))[3] || '' ) !~ / ^ DBIx::Class:: (?:
 482             Row::result_source
 483               |
 484             Row::throw_exception
 485               |
 486             ResultSourceProxy::Table:: (?: _init_result_source_instance | table )
 487               |
 488             ResultSourceHandle::STORABLE_thaw
 489           ) $ /x
 490             and
 491           (CORE::caller(0))[1] !~ / (?: ^ | [\/\\] ) x?t [\/\\] .+? \.t $ /x
 492             and
 493           emit_loud_diag(
 494             msg => 'Incorrect direct call of result_source_instance() as getter must be changed to result_source()',
 495             confess => 1
 496           );
 497
 498
 499           grep {
 500             ! (CORE::caller($_))[7]
 501               and
 502             ( (CORE::caller($_))[3] || '' ) eq '(eval)'
 503               and
 504             ( (CORE::caller($_))[1] || '' ) !~ / (?: ^ | [\/\\] ) x?t [\/\\] .+? \.t $ /x
 505           } (0..2)
 506             and
 507           # special cased as we do not care whether there is a source
 508           ( (CORE::caller(4))[3] || '' ) ne 'DBIx::Class::Schema::_register_source'
 509             and
 510           # special case because I am paranoid
 511           ( (CORE::caller(4))[3] || '' ) ne 'DBIx::Class::Row::throw_exception'
 512             and
 513           # special case for Storable, which in turn calls from an eval
 514           ( (CORE::caller(1))[3] || '' ) ne 'DBIx::Class::ResultSourceHandle::STORABLE_thaw'
 515             and
 516           emit_loud_diag(
 517             # not much else we can do (aside from exit(1) which is too obnoxious)
 518             msg => 'Incorrect call of result_source_instance() in an eval',
 519             skip_frames => 1,
 520             show_dups => 1,
 521           );
 522
 523           &$orig_rsrc_instance;
 524         };
 525
 526         weaken( $assertion_arounds->{refaddr $replacement} = $replacement );
 527
 528         attributes->import(
 529           $origin,
 530           $replacement,
 531           attributes::get($orig_rsrc_instance)
 532         );
 533       }
 534     }
 535
 536     Class::C3::initialize if DBIx::Class::_ENV_::OLD_MRO;
 537   }
 538   #
 539   # END Check an explicit level of indirection
 540
 541   return $self;
 542 }
 543
 544 sub clone {
 545   my $self = shift->next::method(@_);
 546   populate_weakregistry ( $weak_registry, $self )
 547     if $INC{'Test/Builder.pm'};
 548   $self;
 549 }
 550
 551 END {
 552   # Make sure we run after any cleanup in other END blocks
 553   push @{ B::end_av()->object_2svref }, sub {
 554     assert_empty_weakregistry($weak_registry, 'quiet');
 555   };
 556 }
 557
 558 1;