t/lib/DBICTest.pm

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