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