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