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