t/lib/DBICTest.pm

   1 package # hide from PAUSE
   2     DBICTest;
   3
   4 # load early so that `perl -It/lib -MDBICTest` keeps  working
   5 use ANFANG;
   6
   7 use strict;
   8 use warnings;
   9
  10
  11 # this noop trick initializes the STDOUT, so that the TAP::Harness
  12 # issued IO::Select->can_read calls (which are blocking wtf wtf wtf)
  13 # keep spinning and scheduling jobs
  14 # This results in an overall much smoother job-queue drainage, since
  15 # the Harness blocks less
  16 # (ideally this needs to be addressed in T::H, but a quick patchjob
  17 # broke everything so tabling it for now)
  18 BEGIN {
  19   # FIXME - there probably is some way to determine a harness run (T::H or
  20   # prove) but I do not know it offhand, especially on older environments
  21   # Go with the safer option
  22   if ($INC{'Test/Builder.pm'}) {
  23     select( ( select(\*STDOUT), $|=1 )[0] );
  24     print STDOUT "#\n";
  25   }
  26 }
  27
  28
  29 use DBICTest::Util qw(
  30   local_umask slurp_bytes tmpdir await_flock
  31   dbg DEBUG_TEST_CONCURRENCY_LOCKS PEEPEENESS
  32 );
  33 use DBICTest::Util::LeakTracer qw/populate_weakregistry assert_empty_weakregistry/;
  34
  35 # The actual ASSERT logic is in BaseSchema for pesky load-order reasons
  36 # Hence run this through once, *before* DBICTest::Schema and friends load
  37 BEGIN {
  38   if (
  39     DBIx::Class::_ENV_::ASSERT_NO_ERRONEOUS_METAINSTANCE_USE
  40       or
  41     DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS
  42   ) {
  43     require DBIx::Class::Row;
  44     require DBICTest::BaseSchema;
  45     DBICTest::BaseSchema->connect( sub {} );
  46   }
  47 }
  48
  49 use DBICTest::Schema;
  50 use DBIx::Class::_Util qw( detected_reinvoked_destructor scope_guard modver_gt_or_eq );
  51 use Carp;
  52 use Fcntl qw/:DEFAULT :flock/;
  53 use Config;
  54
  55 =head1 NAME
  56
  57 DBICTest - Library to be used by DBIx::Class test scripts
  58
  59 =head1 SYNOPSIS
  60
  61   BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) }
  62
  63   use warnings;
  64   use strict;
  65   use Test::More;
  66   use DBICTest;
  67
  68   my $schema = DBICTest->init_schema();
  69
  70 =head1 DESCRIPTION
  71
  72 This module provides the basic utilities to write tests against
  73 DBIx::Class.
  74
  75 =head1 EXPORTS
  76
  77 The module does not export anything by default, nor provides individual
  78 function exports in the conventional sense. Instead the following tags are
  79 recognized:
  80
  81 =head2 :DiffSQL
  82
  83 Same as C<use SQL::Abstract::Test
  84 qw(L<is_same_sql_bind|SQL::Abstract::Test/is_same_sql_bind>
  85 L<is_same_sql|SQL::Abstract::Test/is_same_sql>
  86 L<is_same_bind|SQL::Abstract::Test/is_same_bind>)>
  87
  88 =head2 :GlobalLock
  89
  90 Some tests are very time sensitive and need to run on their own, without
  91 being disturbed by anything else grabbing CPU or disk IO. Hence why everything
  92 using C<DBICTest> grabs a shared lock, and the few tests that request a
  93 C<:GlobalLock> will ask for an exclusive one and block until they can get it.
  94
  95 =head1 METHODS
  96
  97 =head2 init_schema
  98
  99   my $schema = DBICTest->init_schema(
 100     no_deploy=>1,
 101     no_populate=>1,
 102     storage_type=>'::DBI::Replicated',
 103     storage_type_args=>{
 104       balancer_type=>'DBIx::Class::Storage::DBI::Replicated::Balancer::Random'
 105     },
 106   );
 107
 108 This method removes the test SQLite database in t/var/DBIxClass.db
 109 and then creates a new, empty database.
 110
 111 This method will call L<deploy_schema()|/deploy_schema> by default, unless the
 112 C<no_deploy> flag is set.
 113
 114 Also, by default, this method will call L<populate_schema()|/populate_schema>
 115 by default, unless the C<no_deploy> or C<no_populate> flags are set.
 116
 117 =cut
 118
 119 # see L</:GlobalLock>
 120 our ($global_lock_fh, $global_exclusive_lock);
 121 sub import {
 122     my $self = shift;
 123
 124     my $lockpath = tmpdir . '_dbictest_global.lock';
 125
 126     {
 127       my $u = local_umask(0); # so that the file opens as 666, and any user can lock
 128       sysopen ($global_lock_fh, $lockpath, O_RDWR|O_CREAT)
 129         or die "Unable to open $lockpath: $!";
 130     }
 131
 132     for my $exp (@_) {
 133         if ($exp eq ':GlobalLock') {
 134             DEBUG_TEST_CONCURRENCY_LOCKS > 1
 135               and dbg "Waiting for EXCLUSIVE global lock...";
 136
 137             await_flock ($global_lock_fh, LOCK_EX) or die "Unable to lock $lockpath: $!";
 138
 139             DEBUG_TEST_CONCURRENCY_LOCKS > 1
 140               and dbg "Got EXCLUSIVE global lock";
 141
 142             $global_exclusive_lock = 1;
 143         }
 144         elsif ($exp eq ':DiffSQL') {
 145             require SQL::Abstract::Test;
 146             my $into = caller(0);
 147             for (qw(is_same_sql_bind is_same_sql is_same_bind)) {
 148               no strict 'refs';
 149               *{"${into}::$_"} = \&{"SQL::Abstract::Test::$_"};
 150             }
 151         }
 152         else {
 153             croak "Unknown export $exp requested from $self";
 154         }
 155     }
 156
 157     unless ($global_exclusive_lock) {
 158         DEBUG_TEST_CONCURRENCY_LOCKS > 1
 159           and dbg "Waiting for SHARED global lock...";
 160
 161         await_flock ($global_lock_fh, LOCK_SH) or die "Unable to lock $lockpath: $!";
 162
 163         DEBUG_TEST_CONCURRENCY_LOCKS > 1
 164           and dbg "Got SHARED global lock";
 165     }
 166 }
 167
 168 END {
 169   # referencing here delays destruction even more
 170   if ($global_lock_fh) {
 171     DEBUG_TEST_CONCURRENCY_LOCKS > 1
 172       and dbg "Release @{[ $global_exclusive_lock ? 'EXCLUSIVE' : 'SHARED' ]} global lock (END)";
 173     1;
 174   }
 175
 176   _cleanup_dbfile();
 177 }
 178
 179 sub _sqlite_dbfilename {
 180   my $holder = $ENV{DBICTEST_LOCK_HOLDER} || $$;
 181   $holder = $$ if $holder == -1;
 182
 183   return "t/var/DBIxClass-$holder.db";
 184 }
 185
 186 $SIG{INT} = sub { _cleanup_dbfile(); exit 1 };
 187
 188 my $need_global_cleanup;
 189 sub _cleanup_dbfile {
 190     # cleanup if this is us
 191     if (
 192       ! $ENV{DBICTEST_LOCK_HOLDER}
 193         or
 194       $ENV{DBICTEST_LOCK_HOLDER} == -1
 195         or
 196       $ENV{DBICTEST_LOCK_HOLDER} == $$
 197     ) {
 198         if ($need_global_cleanup and my $dbh = DBICTest->schema->storage->_dbh) {
 199           $dbh->disconnect;
 200         }
 201
 202         my $db_file = _sqlite_dbfilename();
 203         unlink $_ for ($db_file, "${db_file}-journal");
 204     }
 205 }
 206
 207 sub has_custom_dsn {
 208     return $ENV{"DBICTEST_DSN"} ? 1:0;
 209 }
 210
 211 sub _sqlite_dbname {
 212     my $self = shift;
 213     my %args = @_;
 214     return $self->_sqlite_dbfilename if (
 215       defined $args{sqlite_use_file} ? $args{sqlite_use_file} : $ENV{'DBICTEST_SQLITE_USE_FILE'}
 216     );
 217     return ":memory:";
 218 }
 219
 220 sub _database {
 221     my $self = shift;
 222     my %args = @_;
 223
 224     if ($ENV{DBICTEST_DSN}) {
 225       return (
 226         (map { $ENV{"DBICTEST_${_}"} || '' } qw/DSN DBUSER DBPASS/),
 227         { AutoCommit => 1, %args },
 228       );
 229     }
 230     my $db_file = $self->_sqlite_dbname(%args);
 231
 232     for ($db_file, "${db_file}-journal") {
 233       next unless -e $_;
 234       unlink ($_) or carp (
 235         "Unable to unlink existing test database file $_ ($!), creation of fresh database / further tests may fail!"
 236       );
 237     }
 238
 239     return ("dbi:SQLite:${db_file}", '', '', {
 240       AutoCommit => 1,
 241
 242       # this is executed on every connect, and thus installs a disconnect/DESTROY
 243       # guard for every new $dbh
 244       on_connect_do => sub {
 245
 246         my $storage = shift;
 247         my $dbh = $storage->_get_dbh;
 248
 249         # no fsync on commit
 250         $dbh->do ('PRAGMA synchronous = OFF');
 251
 252         if (
 253           $ENV{DBICTEST_SQLITE_REVERSE_DEFAULT_ORDER}
 254             and
 255           # the pragma does not work correctly before libsqlite 3.7.9
 256           $storage->_server_info->{normalized_dbms_version} >= 3.007009
 257         ) {
 258           $dbh->do ('PRAGMA reverse_unordered_selects = ON');
 259         }
 260
 261         # set a *DBI* disconnect callback, to make sure the physical SQLite
 262         # file is still there (i.e. the test does not attempt to delete
 263         # an open database, which fails on Win32)
 264         if (! $storage->{master} and my $guard_cb = __mk_disconnect_guard($db_file)) {
 265           $dbh->{Callbacks} = {
 266             connect => sub { $guard_cb->('connect') },
 267             disconnect => sub { $guard_cb->('disconnect') },
 268             DESTROY => sub { &detected_reinvoked_destructor; $guard_cb->('DESTROY') },
 269           };
 270         }
 271       },
 272       %args,
 273     });
 274 }
 275
 276 sub __mk_disconnect_guard {
 277
 278   my $db_file = shift;
 279
 280   return if (
 281     # this perl leaks handles, delaying DESTROY, can't work right
 282     PEEPEENESS
 283       or
 284     ! -f $db_file
 285   );
 286
 287
 288   my $orig_inode = (stat($db_file))[1]
 289     or return;
 290
 291   my $clan_connect_caller = '*UNKNOWN*';
 292   my $i;
 293   while ( my ($pack, $file, $line) = CORE::caller(++$i) ) {
 294     next if $file eq __FILE__;
 295     next if $pack =~ /^DBIx::Class|^Try::Tiny/;
 296     $clan_connect_caller = "$file line $line";
 297   }
 298
 299   my $failed_once = 0;
 300   my $connected = 1;
 301
 302   return sub {
 303     return if $failed_once;
 304
 305     my $event = shift;
 306     if ($event eq 'connect') {
 307       # this is necessary in case we are disconnected and connected again, all within the same $dbh object
 308       $connected = 1;
 309       return;
 310     }
 311     elsif ($event eq 'disconnect') {
 312       return unless $connected; # we already disconnected earlier
 313       $connected = 0;
 314     }
 315     elsif ($event eq 'DESTROY' and ! $connected ) {
 316       return;
 317     }
 318
 319     my $fail_reason;
 320     if (! -e $db_file) {
 321       $fail_reason = 'is missing';
 322     }
 323     else {
 324       my $cur_inode = (stat($db_file))[1];
 325
 326       if ($orig_inode != $cur_inode) {
 327         my @inodes = ($orig_inode, $cur_inode);
 328         # unless this is a fixed perl (P5RT#84590) pack/unpack before display
 329         # to match the unsigned longs returned by `stat`
 330         @inodes = map { unpack ('L', pack ('l', $_) ) } @inodes
 331           unless $Config{st_ino_size};
 332
 333         $fail_reason = sprintf
 334           'was recreated (initially inode %s, now %s)',
 335           @inodes
 336         ;
 337       }
 338     }
 339
 340     if ($fail_reason) {
 341       $failed_once++;
 342
 343       require Test::Builder;
 344       my $t = Test::Builder->new;
 345       local $Test::Builder::Level = $Test::Builder::Level + 3;
 346       $t->ok (0,
 347         "$db_file originally created at $clan_connect_caller $fail_reason before $event "
 348       . 'of DBI handle - a strong indicator that the database file was tampered with while '
 349       . 'still being open. This action would fail massively if running under Win32, hence '
 350       . 'we make sure it fails on any OS :)'
 351       );
 352     }
 353
 354     return; # this empty return is a DBI requirement
 355   };
 356 }
 357
 358 my $weak_registry = {};
 359
 360 sub init_schema {
 361     my $self = shift;
 362     my %args = @_;
 363
 364     my $schema;
 365
 366     if (
 367       $ENV{DBICTEST_VIA_REPLICATED} &&= (
 368         !$args{storage_type}
 369           &&
 370         ( ! defined $args{sqlite_use_file} or $args{sqlite_use_file} )
 371       )
 372     ) {
 373       $args{storage_type} = ['::DBI::Replicated', { balancer_type => '::Random' }];
 374       $args{sqlite_use_file} = 1;
 375     }
 376
 377     my @dsn = $self->_database(%args);
 378
 379     if ($args{compose_connection}) {
 380       $need_global_cleanup = 1;
 381       $schema = DBICTest::Schema->compose_connection(
 382                   'DBICTest', @dsn
 383                 );
 384     } else {
 385       $schema = DBICTest::Schema->compose_namespace('DBICTest');
 386     }
 387
 388     if( $args{storage_type}) {
 389       $schema->storage_type($args{storage_type});
 390     }
 391
 392     if ( !$args{no_connect} ) {
 393       $schema->connection(@dsn);
 394
 395       if( $ENV{DBICTEST_VIA_REPLICATED} ) {
 396
 397         # add explicit ReadOnly=1 if we can support it
 398         $dsn[0] =~ /^dbi:SQLite:/i
 399           and
 400         require DBD::SQLite
 401           and
 402         modver_gt_or_eq('DBD::SQLite', '1.49_05')
 403           and
 404         $dsn[0] =~ s/^dbi:SQLite:/dbi:SQLite(ReadOnly=1):/i;
 405
 406         $schema->storage->connect_replicants(\@dsn);
 407       }
 408     }
 409
 410     if ( !$args{no_deploy} ) {
 411         __PACKAGE__->deploy_schema( $schema, $args{deploy_args} );
 412         __PACKAGE__->populate_schema( $schema )
 413          if( !$args{no_populate} );
 414     }
 415
 416     populate_weakregistry ( $weak_registry, $schema->storage )
 417       if $INC{'Test/Builder.pm'} and $schema->storage;
 418
 419     return $schema;
 420 }
 421
 422 END {
 423   # Make sure we run after any cleanup in other END blocks
 424   push @{ B::end_av()->object_2svref }, sub {
 425     assert_empty_weakregistry($weak_registry, 'quiet');
 426   };
 427 }
 428
 429 =head2 deploy_schema
 430
 431   DBICTest->deploy_schema( $schema );
 432
 433 This method does one of two things to the schema.  It can either call
 434 the experimental $schema->deploy() if the DBICTEST_SQLT_DEPLOY environment
 435 variable is set, otherwise the default is to read in the t/lib/sqlite.sql
 436 file and execute the SQL within. Either way you end up with a fresh set
 437 of tables for testing.
 438
 439 =cut
 440
 441 sub deploy_schema {
 442     my $self = shift;
 443     my $schema = shift;
 444     my $args = shift || {};
 445
 446     my $guard;
 447     if ( ($ENV{TRAVIS}||'') eq 'true' and my $old_dbg = $schema->storage->debug ) {
 448       $guard = scope_guard { $schema->storage->debug($old_dbg) };
 449       $schema->storage->debug(0);
 450     }
 451
 452     if ($ENV{"DBICTEST_SQLT_DEPLOY"}) {
 453         $schema->deploy($args);
 454     } else {
 455         my $sql = slurp_bytes( 't/lib/sqlite.sql' );
 456         for my $chunk ( split (/;\s*\n+/, $sql) ) {
 457           if ( $chunk =~ / ^ (?! --\s* ) \S /xm ) {  # there is some real sql in the chunk - a non-space at the start of the string which is not a comment
 458             $schema->storage->dbh_do(sub { $_[1]->do($chunk) }) or print "Error on SQL: $chunk\n";
 459           }
 460         }
 461     }
 462     return;
 463 }
 464
 465 =head2 populate_schema
 466
 467   DBICTest->populate_schema( $schema );
 468
 469 After you deploy your schema you can use this method to populate
 470 the tables with test data.
 471
 472 =cut
 473
 474 sub populate_schema {
 475     my $self = shift;
 476     my $schema = shift;
 477
 478     my $guard;
 479     if ( ($ENV{TRAVIS}||'') eq 'true' and my $old_dbg = $schema->storage->debug ) {
 480       $guard = scope_guard { $schema->storage->debug($old_dbg) };
 481       $schema->storage->debug(0);
 482     }
 483
 484     $schema->populate('Genre', [
 485       [qw/genreid name/],
 486       [qw/1       emo  /],
 487     ]);
 488
 489     $schema->populate('Artist', [
 490         [ qw/artistid name/ ],
 491         [ 1, 'Caterwauler McCrae' ],
 492         [ 2, 'Random Boy Band' ],
 493         [ 3, 'We Are Goth' ],
 494     ]);
 495
 496     $schema->populate('CD', [
 497         [ qw/cdid artist title year genreid/ ],
 498         [ 1, 1, "Spoonful of bees", 1999, 1 ],
 499         [ 2, 1, "Forkful of bees", 2001 ],
 500         [ 3, 1, "Caterwaulin' Blues", 1997 ],
 501         [ 4, 2, "Generic Manufactured Singles", 2001 ],
 502         [ 5, 3, "Come Be Depressed With Us", 1998 ],
 503     ]);
 504
 505     $schema->populate('LinerNotes', [
 506         [ qw/liner_id notes/ ],
 507         [ 2, "Buy Whiskey!" ],
 508         [ 4, "Buy Merch!" ],
 509         [ 5, "Kill Yourself!" ],
 510     ]);
 511
 512     $schema->populate('Tag', [
 513         [ qw/tagid cd tag/ ],
 514         [ 1, 1, "Blue" ],
 515         [ 2, 2, "Blue" ],
 516         [ 3, 3, "Blue" ],
 517         [ 4, 5, "Blue" ],
 518         [ 5, 2, "Cheesy" ],
 519         [ 6, 4, "Cheesy" ],
 520         [ 7, 5, "Cheesy" ],
 521         [ 8, 2, "Shiny" ],
 522         [ 9, 4, "Shiny" ],
 523     ]);
 524
 525     $schema->populate('TwoKeys', [
 526         [ qw/artist cd/ ],
 527         [ 1, 1 ],
 528         [ 1, 2 ],
 529         [ 2, 2 ],
 530     ]);
 531
 532     $schema->populate('FourKeys', [
 533         [ qw/foo bar hello goodbye sensors/ ],
 534         [ 1, 2, 3, 4, 'online' ],
 535         [ 5, 4, 3, 6, 'offline' ],
 536     ]);
 537
 538     $schema->populate('OneKey', [
 539         [ qw/id artist cd/ ],
 540         [ 1, 1, 1 ],
 541         [ 2, 1, 2 ],
 542         [ 3, 2, 2 ],
 543     ]);
 544
 545     $schema->populate('SelfRef', [
 546         [ qw/id name/ ],
 547         [ 1, 'First' ],
 548         [ 2, 'Second' ],
 549     ]);
 550
 551     $schema->populate('SelfRefAlias', [
 552         [ qw/self_ref alias/ ],
 553         [ 1, 2 ]
 554     ]);
 555
 556     $schema->populate('ArtistUndirectedMap', [
 557         [ qw/id1 id2/ ],
 558         [ 1, 2 ]
 559     ]);
 560
 561     $schema->populate('Producer', [
 562         [ qw/producerid name/ ],
 563         [ 1, 'Matt S Trout' ],
 564         [ 2, 'Bob The Builder' ],
 565         [ 3, 'Fred The Phenotype' ],
 566     ]);
 567
 568     $schema->populate('CD_to_Producer', [
 569         [ qw/cd producer/ ],
 570         [ 1, 1 ],
 571         [ 1, 2 ],
 572         [ 1, 3 ],
 573     ]);
 574
 575     $schema->populate('TreeLike', [
 576         [ qw/id parent name/ ],
 577         [ 1, undef, 'root' ],
 578         [ 2, 1, 'foo'  ],
 579         [ 3, 2, 'bar'  ],
 580         [ 6, 2, 'blop' ],
 581         [ 4, 3, 'baz'  ],
 582         [ 5, 4, 'quux' ],
 583         [ 7, 3, 'fong'  ],
 584     ]);
 585
 586     $schema->populate('Track', [
 587         [ qw/trackid cd  position title/ ],
 588         [ 4, 2, 1, "Stung with Success"],
 589         [ 5, 2, 2, "Stripy"],
 590         [ 6, 2, 3, "Sticky Honey"],
 591         [ 7, 3, 1, "Yowlin"],
 592         [ 8, 3, 2, "Howlin"],
 593         [ 9, 3, 3, "Fowlin"],
 594         [ 10, 4, 1, "Boring Name"],
 595         [ 11, 4, 2, "Boring Song"],
 596         [ 12, 4, 3, "No More Ideas"],
 597         [ 13, 5, 1, "Sad"],
 598         [ 14, 5, 2, "Under The Weather"],
 599         [ 15, 5, 3, "Suicidal"],
 600         [ 16, 1, 1, "The Bees Knees"],
 601         [ 17, 1, 2, "Apiary"],
 602         [ 18, 1, 3, "Beehind You"],
 603     ]);
 604
 605     $schema->populate('Event', [
 606         [ qw/id starts_at created_on varchar_date varchar_datetime skip_inflation/ ],
 607         [ 1, '2006-04-25 22:24:33', '2006-06-22 21:00:05', '2006-07-23', '2006-05-22 19:05:07', '2006-04-21 18:04:06'],
 608     ]);
 609
 610     $schema->populate('Link', [
 611         [ qw/id url title/ ],
 612         [ 1, '', 'aaa' ]
 613     ]);
 614
 615     $schema->populate('Bookmark', [
 616         [ qw/id link/ ],
 617         [ 1, 1 ]
 618     ]);
 619
 620     $schema->populate('Collection', [
 621         [ qw/collectionid name/ ],
 622         [ 1, "Tools" ],
 623         [ 2, "Body Parts" ],
 624     ]);
 625
 626     $schema->populate('TypedObject', [
 627         [ qw/objectid type value/ ],
 628         [ 1, "pointy", "Awl" ],
 629         [ 2, "round", "Bearing" ],
 630         [ 3, "pointy", "Knife" ],
 631         [ 4, "pointy", "Tooth" ],
 632         [ 5, "round", "Head" ],
 633     ]);
 634     $schema->populate('CollectionObject', [
 635         [ qw/collection object/ ],
 636         [ 1, 1 ],
 637         [ 1, 2 ],
 638         [ 1, 3 ],
 639         [ 2, 4 ],
 640         [ 2, 5 ],
 641     ]);
 642
 643     $schema->populate('Owners', [
 644         [ qw/id name/ ],
 645         [ 1, "Newton" ],
 646         [ 2, "Waltham" ],
 647     ]);
 648
 649     $schema->populate('BooksInLibrary', [
 650         [ qw/id owner title source price/ ],
 651         [ 1, 1, "Programming Perl", "Library", 23 ],
 652         [ 2, 1, "Dynamical Systems", "Library",  37 ],
 653         [ 3, 2, "Best Recipe Cookbook", "Library", 65 ],
 654     ]);
 655 }
 656
 657 1;