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 (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     my @dsn = $self->_database(%args);
 324
 325     if ($args{compose_connection}) {
 326       $need_global_cleanup = 1;
 327       $schema = DBICTest::Schema->compose_connection(
 328                   'DBICTest', @dsn
 329                 );
 330     } else {
 331       $schema = DBICTest::Schema->compose_namespace('DBICTest');
 332     }
 333
 334     if( $args{storage_type}) {
 335       $schema->storage_type($args{storage_type});
 336     }
 337
 338     if ( !$args{no_connect} ) {
 339       $schema->connection(@dsn);
 340     }
 341
 342     if ( !$args{no_deploy} ) {
 343         __PACKAGE__->deploy_schema( $schema, $args{deploy_args} );
 344         __PACKAGE__->populate_schema( $schema )
 345          if( !$args{no_populate} );
 346     }
 347
 348     populate_weakregistry ( $weak_registry, $schema->storage )
 349       if $INC{'Test/Builder.pm'} and $schema->storage;
 350
 351     return $schema;
 352 }
 353
 354 END {
 355   # Make sure we run after any cleanup in other END blocks
 356   push @{ B::end_av()->object_2svref }, sub {
 357     assert_empty_weakregistry($weak_registry, 'quiet');
 358   };
 359 }
 360
 361 =head2 deploy_schema
 362
 363   DBICTest->deploy_schema( $schema );
 364
 365 This method does one of two things to the schema.  It can either call
 366 the experimental $schema->deploy() if the DBICTEST_SQLT_DEPLOY environment
 367 variable is set, otherwise the default is to read in the t/lib/sqlite.sql
 368 file and execute the SQL within. Either way you end up with a fresh set
 369 of tables for testing.
 370
 371 =cut
 372
 373 sub deploy_schema {
 374     my $self = shift;
 375     my $schema = shift;
 376     my $args = shift || {};
 377
 378     local $schema->storage->{debug}
 379       if ($ENV{TRAVIS}||'') eq 'true';
 380
 381     if ($ENV{"DBICTEST_SQLT_DEPLOY"}) {
 382         $schema->deploy($args);
 383     } else {
 384         my $filename = Path::Class::File->new(__FILE__)->dir
 385           ->file('sqlite.sql')->stringify;
 386         my $sql = do { local (@ARGV, $/) = $filename ; <> };
 387         for my $chunk ( split (/;\s*\n+/, $sql) ) {
 388           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
 389             $schema->storage->dbh_do(sub { $_[1]->do($chunk) }) or print "Error on SQL: $chunk\n";
 390           }
 391         }
 392     }
 393     return;
 394 }
 395
 396 =head2 populate_schema
 397
 398   DBICTest->populate_schema( $schema );
 399
 400 After you deploy your schema you can use this method to populate
 401 the tables with test data.
 402
 403 =cut
 404
 405 sub populate_schema {
 406     my $self = shift;
 407     my $schema = shift;
 408
 409     local $schema->storage->{debug}
 410       if ($ENV{TRAVIS}||'') eq 'true';
 411
 412     $schema->populate('Genre', [
 413       [qw/genreid name/],
 414       [qw/1       emo  /],
 415     ]);
 416
 417     $schema->populate('Artist', [
 418         [ qw/artistid name/ ],
 419         [ 1, 'Caterwauler McCrae' ],
 420         [ 2, 'Random Boy Band' ],
 421         [ 3, 'We Are Goth' ],
 422     ]);
 423
 424     $schema->populate('CD', [
 425         [ qw/cdid artist title year genreid/ ],
 426         [ 1, 1, "Spoonful of bees", 1999, 1 ],
 427         [ 2, 1, "Forkful of bees", 2001 ],
 428         [ 3, 1, "Caterwaulin' Blues", 1997 ],
 429         [ 4, 2, "Generic Manufactured Singles", 2001 ],
 430         [ 5, 3, "Come Be Depressed With Us", 1998 ],
 431     ]);
 432
 433     $schema->populate('LinerNotes', [
 434         [ qw/liner_id notes/ ],
 435         [ 2, "Buy Whiskey!" ],
 436         [ 4, "Buy Merch!" ],
 437         [ 5, "Kill Yourself!" ],
 438     ]);
 439
 440     $schema->populate('Tag', [
 441         [ qw/tagid cd tag/ ],
 442         [ 1, 1, "Blue" ],
 443         [ 2, 2, "Blue" ],
 444         [ 3, 3, "Blue" ],
 445         [ 4, 5, "Blue" ],
 446         [ 5, 2, "Cheesy" ],
 447         [ 6, 4, "Cheesy" ],
 448         [ 7, 5, "Cheesy" ],
 449         [ 8, 2, "Shiny" ],
 450         [ 9, 4, "Shiny" ],
 451     ]);
 452
 453     $schema->populate('TwoKeys', [
 454         [ qw/artist cd/ ],
 455         [ 1, 1 ],
 456         [ 1, 2 ],
 457         [ 2, 2 ],
 458     ]);
 459
 460     $schema->populate('FourKeys', [
 461         [ qw/foo bar hello goodbye sensors/ ],
 462         [ 1, 2, 3, 4, 'online' ],
 463         [ 5, 4, 3, 6, 'offline' ],
 464     ]);
 465
 466     $schema->populate('OneKey', [
 467         [ qw/id artist cd/ ],
 468         [ 1, 1, 1 ],
 469         [ 2, 1, 2 ],
 470         [ 3, 2, 2 ],
 471     ]);
 472
 473     $schema->populate('SelfRef', [
 474         [ qw/id name/ ],
 475         [ 1, 'First' ],
 476         [ 2, 'Second' ],
 477     ]);
 478
 479     $schema->populate('SelfRefAlias', [
 480         [ qw/self_ref alias/ ],
 481         [ 1, 2 ]
 482     ]);
 483
 484     $schema->populate('ArtistUndirectedMap', [
 485         [ qw/id1 id2/ ],
 486         [ 1, 2 ]
 487     ]);
 488
 489     $schema->populate('Producer', [
 490         [ qw/producerid name/ ],
 491         [ 1, 'Matt S Trout' ],
 492         [ 2, 'Bob The Builder' ],
 493         [ 3, 'Fred The Phenotype' ],
 494     ]);
 495
 496     $schema->populate('CD_to_Producer', [
 497         [ qw/cd producer/ ],
 498         [ 1, 1 ],
 499         [ 1, 2 ],
 500         [ 1, 3 ],
 501     ]);
 502
 503     $schema->populate('TreeLike', [
 504         [ qw/id parent name/ ],
 505         [ 1, undef, 'root' ],
 506         [ 2, 1, 'foo'  ],
 507         [ 3, 2, 'bar'  ],
 508         [ 6, 2, 'blop' ],
 509         [ 4, 3, 'baz'  ],
 510         [ 5, 4, 'quux' ],
 511         [ 7, 3, 'fong'  ],
 512     ]);
 513
 514     $schema->populate('Track', [
 515         [ qw/trackid cd  position title/ ],
 516         [ 4, 2, 1, "Stung with Success"],
 517         [ 5, 2, 2, "Stripy"],
 518         [ 6, 2, 3, "Sticky Honey"],
 519         [ 7, 3, 1, "Yowlin"],
 520         [ 8, 3, 2, "Howlin"],
 521         [ 9, 3, 3, "Fowlin"],
 522         [ 10, 4, 1, "Boring Name"],
 523         [ 11, 4, 2, "Boring Song"],
 524         [ 12, 4, 3, "No More Ideas"],
 525         [ 13, 5, 1, "Sad"],
 526         [ 14, 5, 2, "Under The Weather"],
 527         [ 15, 5, 3, "Suicidal"],
 528         [ 16, 1, 1, "The Bees Knees"],
 529         [ 17, 1, 2, "Apiary"],
 530         [ 18, 1, 3, "Beehind You"],
 531     ]);
 532
 533     $schema->populate('Event', [
 534         [ qw/id starts_at created_on varchar_date varchar_datetime skip_inflation/ ],
 535         [ 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'],
 536     ]);
 537
 538     $schema->populate('Link', [
 539         [ qw/id url title/ ],
 540         [ 1, '', 'aaa' ]
 541     ]);
 542
 543     $schema->populate('Bookmark', [
 544         [ qw/id link/ ],
 545         [ 1, 1 ]
 546     ]);
 547
 548     $schema->populate('Collection', [
 549         [ qw/collectionid name/ ],
 550         [ 1, "Tools" ],
 551         [ 2, "Body Parts" ],
 552     ]);
 553
 554     $schema->populate('TypedObject', [
 555         [ qw/objectid type value/ ],
 556         [ 1, "pointy", "Awl" ],
 557         [ 2, "round", "Bearing" ],
 558         [ 3, "pointy", "Knife" ],
 559         [ 4, "pointy", "Tooth" ],
 560         [ 5, "round", "Head" ],
 561     ]);
 562     $schema->populate('CollectionObject', [
 563         [ qw/collection object/ ],
 564         [ 1, 1 ],
 565         [ 1, 2 ],
 566         [ 1, 3 ],
 567         [ 2, 4 ],
 568         [ 2, 5 ],
 569     ]);
 570
 571     $schema->populate('Owners', [
 572         [ qw/id name/ ],
 573         [ 1, "Newton" ],
 574         [ 2, "Waltham" ],
 575     ]);
 576
 577     $schema->populate('BooksInLibrary', [
 578         [ qw/id owner title source price/ ],
 579         [ 1, 1, "Programming Perl", "Library", 23 ],
 580         [ 2, 1, "Dynamical Systems", "Library",  37 ],
 581         [ 3, 2, "Best Recipe Cookbook", "Library", 65 ],
 582     ]);
 583 }
 584
 585 1;