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