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