t/lib/DBICTest.pm

   1 package # hide from PAUSE
   2     DBICTest;
   3
   4 use strict;
   5 use warnings;
   6
   7 # this noop trick initializes the STDOUT, so that the TAP::Harness
   8 # issued IO::Select->can_read calls (which are blocking wtf wtf wtf)
   9 # keep spinning and scheduling jobs
  10 # This results in an overall much smoother job-queue drainage, since
  11 # the Harness blocks less
  12 # (ideally this needs to be addressed in T::H, but a quick patchjob
  13 # broke everything so tabling it for now)
  14 BEGIN {
  15   if ($INC{'Test/Builder.pm'}) {
  16     local $| = 1;
  17     print "#\n";
  18   }
  19 }
  20
  21 use Module::Runtime 'module_notional_filename';
  22 BEGIN {
  23   for my $mod (qw( SQL::Abstract::Test SQL::Abstract )) {
  24     if ( $INC{ module_notional_filename($mod) } ) {
  25       # FIXME this does not seem to work in BEGIN - why?!
  26       #require Carp;
  27       #$Carp::Internal{ (__PACKAGE__) }++;
  28       #Carp::croak( __PACKAGE__ . " must be loaded before $mod" );
  29
  30       my ($fr, @frame) = 1;
  31       while (@frame = caller($fr++)) {
  32         last if $frame[1] !~ m|^t/lib/DBICTest|;
  33       }
  34
  35       die __PACKAGE__ . " must be loaded before $mod (or modules using $mod) at $frame[1] line $frame[2]\n";
  36     }
  37   }
  38 }
  39
  40 use DBICTest::Schema;
  41 use DBICTest::Util::LeakTracer qw/populate_weakregistry assert_empty_weakregistry/;
  42 use DBICTest::Util 'local_umask';
  43 use Carp;
  44 use Path::Class::File ();
  45 use File::Spec;
  46 use Fcntl qw/:DEFAULT :flock/;
  47 use Config;
  48
  49 =head1 NAME
  50
  51 DBICTest - Library to be used by DBIx::Class test scripts
  52
  53 =head1 SYNOPSIS
  54
  55   use lib qw(t/lib);
  56   use DBICTest;
  57   use Test::More;
  58
  59   my $schema = DBICTest->init_schema();
  60
  61 =head1 DESCRIPTION
  62
  63 This module provides the basic utilities to write tests against
  64 DBIx::Class.
  65
  66 =head1 EXPORTS
  67
  68 The module does not export anything by default, nor provides individual
  69 function exports in the conventional sense. Instead the following tags are
  70 recognized:
  71
  72 =head2 :DiffSQL
  73
  74 Same as C<use SQL::Abstract::Test
  75 qw(L<is_same_sql_bind|SQL::Abstract::Test/is_same_sql_bind>
  76 L<is_same_sql|SQL::Abstract::Test/is_same_sql>
  77 L<is_same_bind|SQL::Abstract::Test/is_same_bind>)>
  78
  79 =head2 :GlobalLock
  80
  81 Some tests are very time sensitive and need to run on their own, without
  82 being disturbed by anything else grabbing CPU or disk IO. Hence why everything
  83 using C<DBICTest> grabs a shared lock, and the few tests that request a
  84 C<:GlobalLock> will ask for an exclusive one and block until they can get it.
  85
  86 =head1 METHODS
  87
  88 =head2 init_schema
  89
  90   my $schema = DBICTest->init_schema(
  91     no_deploy=>1,
  92     no_populate=>1,
  93     storage_type=>'::DBI::Replicated',
  94     storage_type_args=>{
  95       balancer_type=>'DBIx::Class::Storage::DBI::Replicated::Balancer::Random'
  96     },
  97   );
  98
  99 This method removes the test SQLite database in t/var/DBIxClass.db
 100 and then creates a new, empty database.
 101
 102 This method will call L<deploy_schema()|/deploy_schema> by default, unless the
 103 C<no_deploy> flag is set.
 104
 105 Also, by default, this method will call L<populate_schema()|/populate_schema>
 106 by default, unless the C<no_deploy> or C<no_populate> flags are set.
 107
 108 =cut
 109
 110 # see L</:GlobalLock>
 111 our ($global_lock_fh, $global_exclusive_lock);
 112 sub import {
 113     my $self = shift;
 114
 115     my $lockpath = DBICTest::RunMode->tmpdir->file('_dbictest_global.lock');
 116
 117     {
 118       my $u = local_umask(0); # so that the file opens as 666, and any user can lock
 119       sysopen ($global_lock_fh, $lockpath, O_RDWR|O_CREAT)
 120         or die "Unable to open $lockpath: $!";
 121     }
 122
 123     for my $exp (@_) {
 124         if ($exp eq ':GlobalLock') {
 125             flock ($global_lock_fh, LOCK_EX) or die "Unable to lock $lockpath: $!";
 126             $global_exclusive_lock = 1;
 127         }
 128         elsif ($exp eq ':DiffSQL') {
 129             require SQL::Abstract::Test;
 130             my $into = caller(0);
 131             for (qw(is_same_sql_bind is_same_sql is_same_bind)) {
 132               no strict 'refs';
 133               *{"${into}::$_"} = \&{"SQL::Abstract::Test::$_"};
 134             }
 135         }
 136         else {
 137             croak "Unknown export $exp requested from $self";
 138         }
 139     }
 140
 141     unless ($global_exclusive_lock) {
 142         flock ($global_lock_fh, LOCK_SH) or die "Unable to lock $lockpath: $!";
 143     }
 144 }
 145
 146 END {
 147     if ($global_lock_fh) {
 148         # delay destruction even more
 149     }
 150 }
 151
 152 {
 153     my $dir = Path::Class::File->new(__FILE__)->dir->parent->subdir('var');
 154     $dir->mkpath unless -d "$dir";
 155     $dir = "$dir";
 156
 157     sub _sqlite_dbfilename {
 158         my $holder = $ENV{DBICTEST_LOCK_HOLDER} || $$;
 159         $holder = $$ if $holder == -1;
 160
 161         # useful for missing cleanup debugging
 162         #if ( $holder == $$) {
 163         #  my $x = $0;
 164         #  $x =~ s/\//#/g;
 165         #  $holder .= "-$x";
 166         #}
 167
 168         return "$dir/DBIxClass-$holder.db";
 169     }
 170
 171     END {
 172         _cleanup_dbfile();
 173     }
 174 }
 175
 176 $SIG{INT} = sub { _cleanup_dbfile(); exit 1 };
 177
 178 sub _cleanup_dbfile {
 179     # cleanup if this is us
 180     if (
 181       ! $ENV{DBICTEST_LOCK_HOLDER}
 182         or
 183       $ENV{DBICTEST_LOCK_HOLDER} == -1
 184         or
 185       $ENV{DBICTEST_LOCK_HOLDER} == $$
 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 (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 { $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     DBIx::Class::_ENV_::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       $connected = 0;
 298     }
 299     elsif ($event eq 'DESTROY' and ! $connected ) {
 300       return;
 301     }
 302
 303     my $fail_reason;
 304     if (! -e $db_file) {
 305       $fail_reason = 'is missing';
 306     }
 307     else {
 308       my $cur_inode = (stat($db_file))[1];
 309
 310       if ($orig_inode != $cur_inode) {
 311         my @inodes = ($orig_inode, $cur_inode);
 312         # unless this is a fixed perl (P5RT#84590) pack/unpack before display
 313         # to match the unsigned longs returned by `stat`
 314         @inodes = map { unpack ('L', pack ('l', $_) ) } @inodes
 315           unless $Config{st_ino_size};
 316
 317         $fail_reason = sprintf
 318           'was recreated (initially inode %s, now %s)',
 319           @inodes
 320         ;
 321       }
 322     }
 323
 324     if ($fail_reason) {
 325       $failed_once++;
 326
 327       require Test::Builder;
 328       my $t = Test::Builder->new;
 329       local $Test::Builder::Level = $Test::Builder::Level + 3;
 330       $t->ok (0,
 331         "$db_file originally created at $clan_connect_caller $fail_reason before $event "
 332       . 'of DBI handle - a strong indicator that the database file was tampered with while '
 333       . 'still being open. This action would fail massively if running under Win32, hence '
 334       . 'we make sure it fails on any OS :)'
 335       );
 336     }
 337
 338     return; # this empty return is a DBI requirement
 339   };
 340 }
 341
 342 my $weak_registry = {};
 343
 344 sub init_schema {
 345     my $self = shift;
 346     my %args = @_;
 347
 348     my $schema;
 349
 350     if ($args{compose_connection}) {
 351       $schema = DBICTest::Schema->compose_connection(
 352                   'DBICTest', $self->_database(%args)
 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 = $schema->connect($self->_database(%args));
 364     }
 365
 366     if ( !$args{no_deploy} ) {
 367         __PACKAGE__->deploy_schema( $schema, $args{deploy_args} );
 368         __PACKAGE__->populate_schema( $schema )
 369          if( !$args{no_populate} );
 370     }
 371
 372     populate_weakregistry ( $weak_registry, $schema->storage )
 373       if $INC{'Test/Builder.pm'} and $schema->storage;
 374
 375     return $schema;
 376 }
 377
 378 END {
 379     assert_empty_weakregistry($weak_registry, 'quiet');
 380 }
 381
 382 =head2 deploy_schema
 383
 384   DBICTest->deploy_schema( $schema );
 385
 386 This method does one of two things to the schema.  It can either call
 387 the experimental $schema->deploy() if the DBICTEST_SQLT_DEPLOY environment
 388 variable is set, otherwise the default is to read in the t/lib/sqlite.sql
 389 file and execute the SQL within. Either way you end up with a fresh set
 390 of tables for testing.
 391
 392 =cut
 393
 394 sub deploy_schema {
 395     my $self = shift;
 396     my $schema = shift;
 397     my $args = shift || {};
 398
 399     local $schema->storage->{debug}
 400       if ($ENV{TRAVIS}||'') eq 'true';
 401
 402     if ($ENV{"DBICTEST_SQLT_DEPLOY"}) {
 403         $schema->deploy($args);
 404     } else {
 405         my $filename = Path::Class::File->new(__FILE__)->dir
 406           ->file('sqlite.sql')->stringify;
 407         my $sql = do { local (@ARGV, $/) = $filename ; <> };
 408         for my $chunk ( split (/;\s*\n+/, $sql) ) {
 409           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
 410             $schema->storage->dbh_do(sub { $_[1]->do($chunk) }) or print "Error on SQL: $chunk\n";
 411           }
 412         }
 413     }
 414     return;
 415 }
 416
 417 =head2 populate_schema
 418
 419   DBICTest->populate_schema( $schema );
 420
 421 After you deploy your schema you can use this method to populate
 422 the tables with test data.
 423
 424 =cut
 425
 426 sub populate_schema {
 427     my $self = shift;
 428     my $schema = shift;
 429
 430     local $schema->storage->{debug}
 431       if ($ENV{TRAVIS}||'') eq 'true';
 432
 433     $schema->populate('Genre', [
 434       [qw/genreid name/],
 435       [qw/1       emo  /],
 436     ]);
 437
 438     $schema->populate('Artist', [
 439         [ qw/artistid name/ ],
 440         [ 1, 'Caterwauler McCrae' ],
 441         [ 2, 'Random Boy Band' ],
 442         [ 3, 'We Are Goth' ],
 443     ]);
 444
 445     $schema->populate('CD', [
 446         [ qw/cdid artist title year genreid/ ],
 447         [ 1, 1, "Spoonful of bees", 1999, 1 ],
 448         [ 2, 1, "Forkful of bees", 2001 ],
 449         [ 3, 1, "Caterwaulin' Blues", 1997 ],
 450         [ 4, 2, "Generic Manufactured Singles", 2001 ],
 451         [ 5, 3, "Come Be Depressed With Us", 1998 ],
 452     ]);
 453
 454     $schema->populate('LinerNotes', [
 455         [ qw/liner_id notes/ ],
 456         [ 2, "Buy Whiskey!" ],
 457         [ 4, "Buy Merch!" ],
 458         [ 5, "Kill Yourself!" ],
 459     ]);
 460
 461     $schema->populate('Tag', [
 462         [ qw/tagid cd tag/ ],
 463         [ 1, 1, "Blue" ],
 464         [ 2, 2, "Blue" ],
 465         [ 3, 3, "Blue" ],
 466         [ 4, 5, "Blue" ],
 467         [ 5, 2, "Cheesy" ],
 468         [ 6, 4, "Cheesy" ],
 469         [ 7, 5, "Cheesy" ],
 470         [ 8, 2, "Shiny" ],
 471         [ 9, 4, "Shiny" ],
 472     ]);
 473
 474     $schema->populate('TwoKeys', [
 475         [ qw/artist cd/ ],
 476         [ 1, 1 ],
 477         [ 1, 2 ],
 478         [ 2, 2 ],
 479     ]);
 480
 481     $schema->populate('FourKeys', [
 482         [ qw/foo bar hello goodbye sensors/ ],
 483         [ 1, 2, 3, 4, 'online' ],
 484         [ 5, 4, 3, 6, 'offline' ],
 485     ]);
 486
 487     $schema->populate('OneKey', [
 488         [ qw/id artist cd/ ],
 489         [ 1, 1, 1 ],
 490         [ 2, 1, 2 ],
 491         [ 3, 2, 2 ],
 492     ]);
 493
 494     $schema->populate('SelfRef', [
 495         [ qw/id name/ ],
 496         [ 1, 'First' ],
 497         [ 2, 'Second' ],
 498     ]);
 499
 500     $schema->populate('SelfRefAlias', [
 501         [ qw/self_ref alias/ ],
 502         [ 1, 2 ]
 503     ]);
 504
 505     $schema->populate('ArtistUndirectedMap', [
 506         [ qw/id1 id2/ ],
 507         [ 1, 2 ]
 508     ]);
 509
 510     $schema->populate('Producer', [
 511         [ qw/producerid name/ ],
 512         [ 1, 'Matt S Trout' ],
 513         [ 2, 'Bob The Builder' ],
 514         [ 3, 'Fred The Phenotype' ],
 515     ]);
 516
 517     $schema->populate('CD_to_Producer', [
 518         [ qw/cd producer/ ],
 519         [ 1, 1 ],
 520         [ 1, 2 ],
 521         [ 1, 3 ],
 522     ]);
 523
 524     $schema->populate('TreeLike', [
 525         [ qw/id parent name/ ],
 526         [ 1, undef, 'root' ],
 527         [ 2, 1, 'foo'  ],
 528         [ 3, 2, 'bar'  ],
 529         [ 6, 2, 'blop' ],
 530         [ 4, 3, 'baz'  ],
 531         [ 5, 4, 'quux' ],
 532         [ 7, 3, 'fong'  ],
 533     ]);
 534
 535     $schema->populate('Track', [
 536         [ qw/trackid cd  position title/ ],
 537         [ 4, 2, 1, "Stung with Success"],
 538         [ 5, 2, 2, "Stripy"],
 539         [ 6, 2, 3, "Sticky Honey"],
 540         [ 7, 3, 1, "Yowlin"],
 541         [ 8, 3, 2, "Howlin"],
 542         [ 9, 3, 3, "Fowlin"],
 543         [ 10, 4, 1, "Boring Name"],
 544         [ 11, 4, 2, "Boring Song"],
 545         [ 12, 4, 3, "No More Ideas"],
 546         [ 13, 5, 1, "Sad"],
 547         [ 14, 5, 2, "Under The Weather"],
 548         [ 15, 5, 3, "Suicidal"],
 549         [ 16, 1, 1, "The Bees Knees"],
 550         [ 17, 1, 2, "Apiary"],
 551         [ 18, 1, 3, "Beehind You"],
 552     ]);
 553
 554     $schema->populate('Event', [
 555         [ qw/id starts_at created_on varchar_date varchar_datetime skip_inflation/ ],
 556         [ 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'],
 557     ]);
 558
 559     $schema->populate('Link', [
 560         [ qw/id url title/ ],
 561         [ 1, '', 'aaa' ]
 562     ]);
 563
 564     $schema->populate('Bookmark', [
 565         [ qw/id link/ ],
 566         [ 1, 1 ]
 567     ]);
 568
 569     $schema->populate('Collection', [
 570         [ qw/collectionid name/ ],
 571         [ 1, "Tools" ],
 572         [ 2, "Body Parts" ],
 573     ]);
 574
 575     $schema->populate('TypedObject', [
 576         [ qw/objectid type value/ ],
 577         [ 1, "pointy", "Awl" ],
 578         [ 2, "round", "Bearing" ],
 579         [ 3, "pointy", "Knife" ],
 580         [ 4, "pointy", "Tooth" ],
 581         [ 5, "round", "Head" ],
 582     ]);
 583     $schema->populate('CollectionObject', [
 584         [ qw/collection object/ ],
 585         [ 1, 1 ],
 586         [ 1, 2 ],
 587         [ 1, 3 ],
 588         [ 2, 4 ],
 589         [ 2, 5 ],
 590     ]);
 591
 592     $schema->populate('Owners', [
 593         [ qw/id name/ ],
 594         [ 1, "Newton" ],
 595         [ 2, "Waltham" ],
 596     ]);
 597
 598     $schema->populate('BooksInLibrary', [
 599         [ qw/id owner title source price/ ],
 600         [ 1, 1, "Programming Perl", "Library", 23 ],
 601         [ 2, 1, "Dynamical Systems", "Library",  37 ],
 602         [ 3, 2, "Best Recipe Cookbook", "Library", 65 ],
 603     ]);
 604 }
 605
 606 1;