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