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