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 Carp;
  11 use Path::Class::File ();
  12 use File::Spec;
  13 use Fcntl qw/:DEFAULT :flock/;
  14 use Config;
  15
  16 =head1 NAME
  17
  18 DBICTest - Library to be used by DBIx::Class test scripts
  19
  20 =head1 SYNOPSIS
  21
  22   use lib qw(t/lib);
  23   use DBICTest;
  24   use Test::More;
  25
  26   my $schema = DBICTest->init_schema();
  27
  28 =head1 DESCRIPTION
  29
  30 This module provides the basic utilities to write tests against
  31 DBIx::Class.
  32
  33 =head1 EXPORTS
  34
  35 The module does not export anything by default, nor provides individual
  36 function exports in the conventional sense. Instead the following tags are
  37 recognized:
  38
  39 =head2 :DiffSQL
  40
  41 Same as C<use SQL::Abstract::Test
  42 qw(L<is_same_sql_bind|SQL::Abstract::Test/is_same_sql_bind>
  43 L<is_same_sql|SQL::Abstract::Test/is_same_sql>
  44 L<is_same_bind|SQL::Abstract::Test/is_same_bind>)>
  45
  46 =head2 :GlobalLock
  47
  48 Some tests are very time sensitive and need to run on their own, without
  49 being disturbed by anything else grabbing CPU or disk IO. Hence why everything
  50 using C<DBICTest> grabs a shared lock, and the few tests that request a
  51 C<:GlobalLock> will ask for an exclusive one and block until they can get it.
  52
  53 =head1 METHODS
  54
  55 =head2 init_schema
  56
  57   my $schema = DBICTest->init_schema(
  58     no_deploy=>1,
  59     no_populate=>1,
  60     storage_type=>'::DBI::Replicated',
  61     storage_type_args=>{
  62       balancer_type=>'DBIx::Class::Storage::DBI::Replicated::Balancer::Random'
  63     },
  64   );
  65
  66 This method removes the test SQLite database in t/var/DBIxClass.db
  67 and then creates a new, empty database.
  68
  69 This method will call L<deploy_schema()|/deploy_schema> by default, unless the
  70 C<no_deploy> flag is set.
  71
  72 Also, by default, this method will call L<populate_schema()|/populate_schema>
  73 by default, unless the C<no_deploy> or C<no_populate> flags are set.
  74
  75 =cut
  76
  77 # see L</:GlobalLock>
  78 our ($global_lock_fh, $global_exclusive_lock);
  79 sub import {
  80     my $self = shift;
  81
  82     my $lockpath = DBICTest::RunMode->tmpdir->file('_dbictest_global.lock');
  83
  84     {
  85       my $u = local_umask(0); # so that the file opens as 666, and any user can lock
  86       sysopen ($global_lock_fh, $lockpath, O_RDWR|O_CREAT)
  87         or die "Unable to open $lockpath: $!";
  88     }
  89
  90     for my $exp (@_) {
  91         if ($exp eq ':GlobalLock') {
  92             flock ($global_lock_fh, LOCK_EX) or die "Unable to lock $lockpath: $!";
  93             $global_exclusive_lock = 1;
  94         }
  95         elsif ($exp eq ':DiffSQL') {
  96             require SQL::Abstract::Test;
  97             my $into = caller(0);
  98             for (qw(is_same_sql_bind is_same_sql is_same_bind)) {
  99               no strict 'refs';
 100               *{"${into}::$_"} = \&{"SQL::Abstract::Test::$_"};
 101             }
 102         }
 103         else {
 104             croak "Unknown export $exp requested from $self";
 105         }
 106     }
 107
 108     unless ($global_exclusive_lock) {
 109         flock ($global_lock_fh, LOCK_SH) or die "Unable to lock $lockpath: $!";
 110     }
 111 }
 112
 113 END {
 114     if ($global_lock_fh) {
 115         # delay destruction even more
 116     }
 117 }
 118
 119 {
 120     my $dir = Path::Class::File->new(__FILE__)->dir->parent->subdir('var');
 121     $dir->mkpath unless -d "$dir";
 122     $dir = "$dir";
 123
 124     sub _sqlite_dbfilename {
 125         my $holder = $ENV{DBICTEST_LOCK_HOLDER} || $$;
 126         $holder = $$ if $holder == -1;
 127
 128         # useful for missing cleanup debugging
 129         #if ( $holder == $$) {
 130         #  my $x = $0;
 131         #  $x =~ s/\//#/g;
 132         #  $holder .= "-$x";
 133         #}
 134
 135         return "$dir/DBIxClass-$holder.db";
 136     }
 137
 138     END {
 139         _cleanup_dbfile();
 140     }
 141 }
 142
 143 $SIG{INT} = sub { _cleanup_dbfile(); exit 1 };
 144
 145 sub _cleanup_dbfile {
 146     # cleanup if this is us
 147     if (
 148       ! $ENV{DBICTEST_LOCK_HOLDER}
 149         or
 150       $ENV{DBICTEST_LOCK_HOLDER} == -1
 151         or
 152       $ENV{DBICTEST_LOCK_HOLDER} == $$
 153     ) {
 154         my $db_file = _sqlite_dbfilename();
 155         unlink $_ for ($db_file, "${db_file}-journal");
 156     }
 157 }
 158
 159 sub has_custom_dsn {
 160     return $ENV{"DBICTEST_DSN"} ? 1:0;
 161 }
 162
 163 sub _sqlite_dbname {
 164     my $self = shift;
 165     my %args = @_;
 166     return $self->_sqlite_dbfilename if (
 167       defined $args{sqlite_use_file} ? $args{sqlite_use_file} : $ENV{'DBICTEST_SQLITE_USE_FILE'}
 168     );
 169     return ":memory:";
 170 }
 171
 172 sub _database {
 173     my $self = shift;
 174     my %args = @_;
 175
 176     if ($ENV{DBICTEST_DSN}) {
 177       return (
 178         (map { $ENV{"DBICTEST_${_}"} || '' } qw/DSN DBUSER DBPASS/),
 179         { AutoCommit => 1, %args },
 180       );
 181     }
 182     my $db_file = $self->_sqlite_dbname(%args);
 183
 184     for ($db_file, "${db_file}-journal") {
 185       next unless -e $_;
 186       unlink ($_) or carp (
 187         "Unable to unlink existing test database file $_ ($!), creation of fresh database / further tests may fail!"
 188       );
 189     }
 190
 191     return ("dbi:SQLite:${db_file}", '', '', {
 192       AutoCommit => 1,
 193
 194       # this is executed on every connect, and thus installs a disconnect/DESTROY
 195       # guard for every new $dbh
 196       on_connect_do => sub {
 197
 198         my $storage = shift;
 199         my $dbh = $storage->_get_dbh;
 200
 201         # no fsync on commit
 202         $dbh->do ('PRAGMA synchronous = OFF');
 203
 204         if (
 205           $ENV{DBICTEST_SQLITE_REVERSE_DEFAULT_ORDER}
 206             and
 207           # the pragma does not work correctly before libsqlite 3.7.9
 208           $storage->_server_info->{normalized_dbms_version} >= 3.007009
 209         ) {
 210           $dbh->do ('PRAGMA reverse_unordered_selects = ON');
 211         }
 212
 213         # set a *DBI* disconnect callback, to make sure the physical SQLite
 214         # file is still there (i.e. the test does not attempt to delete
 215         # an open database, which fails on Win32)
 216         if (my $guard_cb = __mk_disconnect_guard($db_file)) {
 217           $dbh->{Callbacks} = {
 218             connect => sub { $guard_cb->('connect') },
 219             disconnect => sub { $guard_cb->('disconnect') },
 220             DESTROY => sub { $guard_cb->('DESTROY') },
 221           };
 222         }
 223       },
 224       %args,
 225     });
 226 }
 227
 228 sub __mk_disconnect_guard {
 229
 230   my $db_file = shift;
 231
 232   return if (
 233     # this perl leaks handles, delaying DESTROY, can't work right
 234     DBIx::Class::_ENV_::PEEPEENESS
 235       or
 236     ! -f $db_file
 237   );
 238
 239
 240   my $orig_inode = (stat($db_file))[1]
 241     or return;
 242
 243   my $clan_connect_caller = '*UNKNOWN*';
 244   my $i;
 245   while ( my ($pack, $file, $line) = caller(++$i) ) {
 246     next if $file eq __FILE__;
 247     next if $pack =~ /^DBIx::Class|^Try::Tiny/;
 248     $clan_connect_caller = "$file line $line";
 249   }
 250
 251   my $failed_once = 0;
 252   my $connected = 1;
 253
 254   return sub {
 255     return if $failed_once;
 256
 257     my $event = shift;
 258     if ($event eq 'connect') {
 259       # this is necessary in case we are disconnected and connected again, all within the same $dbh object
 260       $connected = 1;
 261       return;
 262     }
 263     elsif ($event eq 'disconnect') {
 264       $connected = 0;
 265     }
 266     elsif ($event eq 'DESTROY' and ! $connected ) {
 267       return;
 268     }
 269
 270     my $fail_reason;
 271     if (! -e $db_file) {
 272       $fail_reason = 'is missing';
 273     }
 274     else {
 275       my $cur_inode = (stat($db_file))[1];
 276
 277       if ($orig_inode != $cur_inode) {
 278         my @inodes = ($orig_inode, $cur_inode);
 279         # unless this is a fixed perl (P5RT#84590) pack/unpack before display
 280         # to match the unsigned longs returned by `stat`
 281         @inodes = map { unpack ('L', pack ('l', $_) ) } @inodes
 282           unless $Config{st_ino_size};
 283
 284         $fail_reason = sprintf
 285           'was recreated (initially inode %s, now %s)',
 286           @inodes
 287         ;
 288       }
 289     }
 290
 291     if ($fail_reason) {
 292       $failed_once++;
 293
 294       require Test::Builder;
 295       my $t = Test::Builder->new;
 296       local $Test::Builder::Level = $Test::Builder::Level + 3;
 297       $t->ok (0,
 298         "$db_file originally created at $clan_connect_caller $fail_reason before $event "
 299       . 'of DBI handle - a strong indicator that the database file was tampered with while '
 300       . 'still being open. This action would fail massively if running under Win32, hence '
 301       . 'we make sure it fails on any OS :)'
 302       );
 303     }
 304
 305     return; # this empty return is a DBI requirement
 306   };
 307 }
 308
 309 my $weak_registry = {};
 310
 311 sub init_schema {
 312     my $self = shift;
 313     my %args = @_;
 314
 315     my $schema;
 316
 317     if ($args{compose_connection}) {
 318       $schema = DBICTest::Schema->compose_connection(
 319                   'DBICTest', $self->_database(%args)
 320                 );
 321     } else {
 322       $schema = DBICTest::Schema->compose_namespace('DBICTest');
 323     }
 324
 325     if( $args{storage_type}) {
 326       $schema->storage_type($args{storage_type});
 327     }
 328
 329     if ( !$args{no_connect} ) {
 330       $schema = $schema->connect($self->_database(%args));
 331     }
 332
 333     if ( !$args{no_deploy} ) {
 334         __PACKAGE__->deploy_schema( $schema, $args{deploy_args} );
 335         __PACKAGE__->populate_schema( $schema )
 336          if( !$args{no_populate} );
 337     }
 338
 339     populate_weakregistry ( $weak_registry, $schema->storage )
 340       if $INC{'Test/Builder.pm'} and $schema->storage;
 341
 342     return $schema;
 343 }
 344
 345 END {
 346   # Make sure we run after any cleanup in other END blocks
 347   require B;
 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;