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