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