t/lib/DBICTest.pm

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