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