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 use DBICTest::Schema;
  35 use DBIx::Class::_Util qw( detected_reinvoked_destructor scope_guard modver_gt_or_eq );
  36 use Carp;
  37 use Fcntl qw/:DEFAULT :flock/;
  38 use Config;
  39
  40 =head1 NAME
  41
  42 DBICTest - Library to be used by DBIx::Class test scripts
  43
  44 =head1 SYNOPSIS
  45
  46   BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) }
  47
  48   use warnings;
  49   use strict;
  50   use Test::More;
  51   use DBICTest;
  52
  53   my $schema = DBICTest->init_schema();
  54
  55 =head1 DESCRIPTION
  56
  57 This module provides the basic utilities to write tests against
  58 DBIx::Class.
  59
  60 =head1 EXPORTS
  61
  62 The module does not export anything by default, nor provides individual
  63 function exports in the conventional sense. Instead the following tags are
  64 recognized:
  65
  66 =head2 :DiffSQL
  67
  68 Same as C<use SQL::Abstract::Test
  69 qw(L<is_same_sql_bind|SQL::Abstract::Test/is_same_sql_bind>
  70 L<is_same_sql|SQL::Abstract::Test/is_same_sql>
  71 L<is_same_bind|SQL::Abstract::Test/is_same_bind>)>
  72
  73 =head2 :GlobalLock
  74
  75 Some tests are very time sensitive and need to run on their own, without
  76 being disturbed by anything else grabbing CPU or disk IO. Hence why everything
  77 using C<DBICTest> grabs a shared lock, and the few tests that request a
  78 C<:GlobalLock> will ask for an exclusive one and block until they can get it.
  79
  80 =head1 METHODS
  81
  82 =head2 init_schema
  83
  84   my $schema = DBICTest->init_schema(
  85     no_deploy=>1,
  86     no_populate=>1,
  87     storage_type=>'::DBI::Replicated',
  88     storage_type_args=>{
  89       balancer_type=>'DBIx::Class::Storage::DBI::Replicated::Balancer::Random'
  90     },
  91   );
  92
  93 This method removes the test SQLite database in t/var/DBIxClass.db
  94 and then creates a new, empty database.
  95
  96 This method will call L<deploy_schema()|/deploy_schema> by default, unless the
  97 C<no_deploy> flag is set.
  98
  99 Also, by default, this method will call L<populate_schema()|/populate_schema>
 100 by default, unless the C<no_deploy> or C<no_populate> flags are set.
 101
 102 =cut
 103
 104 # see L</:GlobalLock>
 105 our ($global_lock_fh, $global_exclusive_lock);
 106 sub import {
 107     my $self = shift;
 108
 109     my $lockpath = tmpdir . '_dbictest_global.lock';
 110
 111     {
 112       my $u = local_umask(0); # so that the file opens as 666, and any user can lock
 113       sysopen ($global_lock_fh, $lockpath, O_RDWR|O_CREAT)
 114         or die "Unable to open $lockpath: $!";
 115     }
 116
 117     for my $exp (@_) {
 118         if ($exp eq ':GlobalLock') {
 119             DEBUG_TEST_CONCURRENCY_LOCKS > 1
 120               and dbg "Waiting for EXCLUSIVE global lock...";
 121
 122             await_flock ($global_lock_fh, LOCK_EX) or die "Unable to lock $lockpath: $!";
 123
 124             DEBUG_TEST_CONCURRENCY_LOCKS > 1
 125               and dbg "Got EXCLUSIVE global lock";
 126
 127             $global_exclusive_lock = 1;
 128         }
 129         elsif ($exp eq ':DiffSQL') {
 130             require SQL::Abstract::Test;
 131             my $into = caller(0);
 132             for (qw(is_same_sql_bind is_same_sql is_same_bind)) {
 133               no strict 'refs';
 134               *{"${into}::$_"} = \&{"SQL::Abstract::Test::$_"};
 135             }
 136         }
 137         else {
 138             croak "Unknown export $exp requested from $self";
 139         }
 140     }
 141
 142     unless ($global_exclusive_lock) {
 143         DEBUG_TEST_CONCURRENCY_LOCKS > 1
 144           and dbg "Waiting for SHARED global lock...";
 145
 146         await_flock ($global_lock_fh, LOCK_SH) or die "Unable to lock $lockpath: $!";
 147
 148         DEBUG_TEST_CONCURRENCY_LOCKS > 1
 149           and dbg "Got SHARED global lock";
 150     }
 151 }
 152
 153 END {
 154   # referencing here delays destruction even more
 155   if ($global_lock_fh) {
 156     DEBUG_TEST_CONCURRENCY_LOCKS > 1
 157       and dbg "Release @{[ $global_exclusive_lock ? 'EXCLUSIVE' : 'SHARED' ]} global lock (END)";
 158     1;
 159   }
 160
 161   _cleanup_dbfile();
 162 }
 163
 164 sub _sqlite_dbfilename {
 165   my $holder = $ENV{DBICTEST_LOCK_HOLDER} || $$;
 166   $holder = $$ if $holder == -1;
 167
 168   return "t/var/DBIxClass-$holder.db";
 169 }
 170
 171 $SIG{INT} = sub { _cleanup_dbfile(); exit 1 };
 172
 173 my $need_global_cleanup;
 174 sub _cleanup_dbfile {
 175     # cleanup if this is us
 176     if (
 177       ! $ENV{DBICTEST_LOCK_HOLDER}
 178         or
 179       $ENV{DBICTEST_LOCK_HOLDER} == -1
 180         or
 181       $ENV{DBICTEST_LOCK_HOLDER} == $$
 182     ) {
 183         if ($need_global_cleanup and my $dbh = DBICTest->schema->storage->_dbh) {
 184           $dbh->disconnect;
 185         }
 186
 187         my $db_file = _sqlite_dbfilename();
 188         unlink $_ for ($db_file, "${db_file}-journal");
 189     }
 190 }
 191
 192 sub has_custom_dsn {
 193     return $ENV{"DBICTEST_DSN"} ? 1:0;
 194 }
 195
 196 sub _sqlite_dbname {
 197     my $self = shift;
 198     my %args = @_;
 199     return $self->_sqlite_dbfilename if (
 200       defined $args{sqlite_use_file} ? $args{sqlite_use_file} : $ENV{'DBICTEST_SQLITE_USE_FILE'}
 201     );
 202     return ":memory:";
 203 }
 204
 205 sub _database {
 206     my $self = shift;
 207     my %args = @_;
 208
 209     if ($ENV{DBICTEST_DSN}) {
 210       return (
 211         (map { $ENV{"DBICTEST_${_}"} || '' } qw/DSN DBUSER DBPASS/),
 212         { AutoCommit => 1, %args },
 213       );
 214     }
 215     my $db_file = $self->_sqlite_dbname(%args);
 216
 217     for ($db_file, "${db_file}-journal") {
 218       next unless -e $_;
 219       unlink ($_) or carp (
 220         "Unable to unlink existing test database file $_ ($!), creation of fresh database / further tests may fail!"
 221       );
 222     }
 223
 224     return ("dbi:SQLite:${db_file}", '', '', {
 225       AutoCommit => 1,
 226
 227       # this is executed on every connect, and thus installs a disconnect/DESTROY
 228       # guard for every new $dbh
 229       on_connect_do => sub {
 230
 231         my $storage = shift;
 232         my $dbh = $storage->_get_dbh;
 233
 234         # no fsync on commit
 235         $dbh->do ('PRAGMA synchronous = OFF');
 236
 237         if (
 238           $ENV{DBICTEST_SQLITE_REVERSE_DEFAULT_ORDER}
 239             and
 240           # the pragma does not work correctly before libsqlite 3.7.9
 241           $storage->_server_info->{normalized_dbms_version} >= 3.007009
 242         ) {
 243           $dbh->do ('PRAGMA reverse_unordered_selects = ON');
 244         }
 245
 246         # set a *DBI* disconnect callback, to make sure the physical SQLite
 247         # file is still there (i.e. the test does not attempt to delete
 248         # an open database, which fails on Win32)
 249         if (! $storage->{master} and my $guard_cb = __mk_disconnect_guard($db_file)) {
 250           $dbh->{Callbacks} = {
 251             connect => sub { $guard_cb->('connect') },
 252             disconnect => sub { $guard_cb->('disconnect') },
 253             DESTROY => sub { &detected_reinvoked_destructor; $guard_cb->('DESTROY') },
 254           };
 255         }
 256       },
 257       %args,
 258     });
 259 }
 260
 261 sub __mk_disconnect_guard {
 262
 263   my $db_file = shift;
 264
 265   return if (
 266     # this perl leaks handles, delaying DESTROY, can't work right
 267     PEEPEENESS
 268       or
 269     ! -f $db_file
 270   );
 271
 272
 273   my $orig_inode = (stat($db_file))[1]
 274     or return;
 275
 276   my $clan_connect_caller = '*UNKNOWN*';
 277   my $i;
 278   while ( my ($pack, $file, $line) = caller(++$i) ) {
 279     next if $file eq __FILE__;
 280     next if $pack =~ /^DBIx::Class|^Try::Tiny/;
 281     $clan_connect_caller = "$file line $line";
 282   }
 283
 284   my $failed_once = 0;
 285   my $connected = 1;
 286
 287   return sub {
 288     return if $failed_once;
 289
 290     my $event = shift;
 291     if ($event eq 'connect') {
 292       # this is necessary in case we are disconnected and connected again, all within the same $dbh object
 293       $connected = 1;
 294       return;
 295     }
 296     elsif ($event eq 'disconnect') {
 297       return unless $connected; # we already disconnected earlier
 298       $connected = 0;
 299     }
 300     elsif ($event eq 'DESTROY' and ! $connected ) {
 301       return;
 302     }
 303
 304     my $fail_reason;
 305     if (! -e $db_file) {
 306       $fail_reason = 'is missing';
 307     }
 308     else {
 309       my $cur_inode = (stat($db_file))[1];
 310
 311       if ($orig_inode != $cur_inode) {
 312         my @inodes = ($orig_inode, $cur_inode);
 313         # unless this is a fixed perl (P5RT#84590) pack/unpack before display
 314         # to match the unsigned longs returned by `stat`
 315         @inodes = map { unpack ('L', pack ('l', $_) ) } @inodes
 316           unless $Config{st_ino_size};
 317
 318         $fail_reason = sprintf
 319           'was recreated (initially inode %s, now %s)',
 320           @inodes
 321         ;
 322       }
 323     }
 324
 325     if ($fail_reason) {
 326       $failed_once++;
 327
 328       require Test::Builder;
 329       my $t = Test::Builder->new;
 330       local $Test::Builder::Level = $Test::Builder::Level + 3;
 331       $t->ok (0,
 332         "$db_file originally created at $clan_connect_caller $fail_reason before $event "
 333       . 'of DBI handle - a strong indicator that the database file was tampered with while '
 334       . 'still being open. This action would fail massively if running under Win32, hence '
 335       . 'we make sure it fails on any OS :)'
 336       );
 337     }
 338
 339     return; # this empty return is a DBI requirement
 340   };
 341 }
 342
 343 my $weak_registry = {};
 344
 345 sub init_schema {
 346     my $self = shift;
 347     my %args = @_;
 348
 349     my $schema;
 350
 351     if (
 352       $ENV{DBICTEST_VIA_REPLICATED} &&= (
 353         !$args{storage_type}
 354           &&
 355         ( ! defined $args{sqlite_use_file} or $args{sqlite_use_file} )
 356       )
 357     ) {
 358       $args{storage_type} = ['::DBI::Replicated', { balancer_type => '::Random' }];
 359       $args{sqlite_use_file} = 1;
 360     }
 361
 362     my @dsn = $self->_database(%args);
 363
 364     if ($args{compose_connection}) {
 365       $need_global_cleanup = 1;
 366       $schema = DBICTest::Schema->compose_connection(
 367                   'DBICTest', @dsn
 368                 );
 369     } else {
 370       $schema = DBICTest::Schema->compose_namespace('DBICTest');
 371     }
 372
 373     if( $args{storage_type}) {
 374       $schema->storage_type($args{storage_type});
 375     }
 376
 377     if ( !$args{no_connect} ) {
 378       $schema->connection(@dsn);
 379
 380       if( $ENV{DBICTEST_VIA_REPLICATED} ) {
 381
 382         # add explicit ReadOnly=1 if we can support it
 383         $dsn[0] =~ /^dbi:SQLite:/i
 384           and
 385         require DBD::SQLite
 386           and
 387         modver_gt_or_eq('DBD::SQLite', '1.49_05')
 388           and
 389         $dsn[0] =~ s/^dbi:SQLite:/dbi:SQLite(ReadOnly=1):/i;
 390
 391         $schema->storage->connect_replicants(\@dsn);
 392       }
 393     }
 394
 395     if ( !$args{no_deploy} ) {
 396         __PACKAGE__->deploy_schema( $schema, $args{deploy_args} );
 397         __PACKAGE__->populate_schema( $schema )
 398          if( !$args{no_populate} );
 399     }
 400
 401     populate_weakregistry ( $weak_registry, $schema->storage )
 402       if $INC{'Test/Builder.pm'} and $schema->storage;
 403
 404     return $schema;
 405 }
 406
 407 END {
 408   # Make sure we run after any cleanup in other END blocks
 409   push @{ B::end_av()->object_2svref }, sub {
 410     assert_empty_weakregistry($weak_registry, 'quiet');
 411   };
 412 }
 413
 414 =head2 deploy_schema
 415
 416   DBICTest->deploy_schema( $schema );
 417
 418 This method does one of two things to the schema.  It can either call
 419 the experimental $schema->deploy() if the DBICTEST_SQLT_DEPLOY environment
 420 variable is set, otherwise the default is to read in the t/lib/sqlite.sql
 421 file and execute the SQL within. Either way you end up with a fresh set
 422 of tables for testing.
 423
 424 =cut
 425
 426 sub deploy_schema {
 427     my $self = shift;
 428     my $schema = shift;
 429     my $args = shift || {};
 430
 431     my $guard;
 432     if ( ($ENV{TRAVIS}||'') eq 'true' and my $old_dbg = $schema->storage->debug ) {
 433       $guard = scope_guard { $schema->storage->debug($old_dbg) };
 434       $schema->storage->debug(0);
 435     }
 436
 437     if ($ENV{"DBICTEST_SQLT_DEPLOY"}) {
 438         $schema->deploy($args);
 439     } else {
 440         my $sql = slurp_bytes( 't/lib/sqlite.sql' );
 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;