t/lib/DBICTest.pm

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