1 package # hide from PAUSE
4 # load early so that `perl -It/lib -MDBICTest` keeps working
11 # this noop trick initializes the STDOUT, so that the TAP::Harness
12 # issued IO::Select->can_read calls (which are blocking wtf wtf wtf)
13 # keep spinning and scheduling jobs
14 # This results in an overall much smoother job-queue drainage, since
15 # the Harness blocks less
16 # (ideally this needs to be addressed in T::H, but a quick patchjob
17 # broke everything so tabling it for now)
19 # FIXME - there probably is some way to determine a harness run (T::H or
20 # prove) but I do not know it offhand, especially on older environments
21 # Go with the safer option
22 if ($INC{'Test/Builder.pm'}) {
29 use DBICTest::Util qw(
30 local_umask tmpdir await_flock
31 dbg DEBUG_TEST_CONCURRENCY_LOCKS PEEPEENESS
33 use DBICTest::Util::LeakTracer qw/populate_weakregistry assert_empty_weakregistry/;
35 use DBIx::Class::_Util qw( detected_reinvoked_destructor scope_guard );
37 use Path::Class::File ();
38 use Fcntl qw/:DEFAULT :flock/;
43 DBICTest - Library to be used by DBIx::Class test scripts
47 BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) }
54 my $schema = DBICTest->init_schema();
58 This module provides the basic utilities to write tests against
63 The module does not export anything by default, nor provides individual
64 function exports in the conventional sense. Instead the following tags are
69 Same as C<use SQL::Abstract::Test
70 qw(L<is_same_sql_bind|SQL::Abstract::Test/is_same_sql_bind>
71 L<is_same_sql|SQL::Abstract::Test/is_same_sql>
72 L<is_same_bind|SQL::Abstract::Test/is_same_bind>)>
76 Some tests are very time sensitive and need to run on their own, without
77 being disturbed by anything else grabbing CPU or disk IO. Hence why everything
78 using C<DBICTest> grabs a shared lock, and the few tests that request a
79 C<:GlobalLock> will ask for an exclusive one and block until they can get it.
85 my $schema = DBICTest->init_schema(
88 storage_type=>'::DBI::Replicated',
90 balancer_type=>'DBIx::Class::Storage::DBI::Replicated::Balancer::Random'
94 This method removes the test SQLite database in t/var/DBIxClass.db
95 and then creates a new, empty database.
97 This method will call L<deploy_schema()|/deploy_schema> by default, unless the
98 C<no_deploy> flag is set.
100 Also, by default, this method will call L<populate_schema()|/populate_schema>
101 by default, unless the C<no_deploy> or C<no_populate> flags are set.
105 # see L</:GlobalLock>
106 our ($global_lock_fh, $global_exclusive_lock);
110 my $lockpath = tmpdir . '_dbictest_global.lock';
113 my $u = local_umask(0); # so that the file opens as 666, and any user can lock
114 sysopen ($global_lock_fh, $lockpath, O_RDWR|O_CREAT)
115 or die "Unable to open $lockpath: $!";
119 if ($exp eq ':GlobalLock') {
120 DEBUG_TEST_CONCURRENCY_LOCKS > 1
121 and dbg "Waiting for EXCLUSIVE global lock...";
123 await_flock ($global_lock_fh, LOCK_EX) or die "Unable to lock $lockpath: $!";
125 DEBUG_TEST_CONCURRENCY_LOCKS > 1
126 and dbg "Got EXCLUSIVE global lock";
128 $global_exclusive_lock = 1;
130 elsif ($exp eq ':DiffSQL') {
131 require SQL::Abstract::Test;
132 my $into = caller(0);
133 for (qw(is_same_sql_bind is_same_sql is_same_bind)) {
135 *{"${into}::$_"} = \&{"SQL::Abstract::Test::$_"};
139 croak "Unknown export $exp requested from $self";
143 unless ($global_exclusive_lock) {
144 DEBUG_TEST_CONCURRENCY_LOCKS > 1
145 and dbg "Waiting for SHARED global lock...";
147 await_flock ($global_lock_fh, LOCK_SH) or die "Unable to lock $lockpath: $!";
149 DEBUG_TEST_CONCURRENCY_LOCKS > 1
150 and dbg "Got SHARED global lock";
155 # referencing here delays destruction even more
156 if ($global_lock_fh) {
157 DEBUG_TEST_CONCURRENCY_LOCKS > 1
158 and dbg "Release @{[ $global_exclusive_lock ? 'EXCLUSIVE' : 'SHARED' ]} global lock (END)";
164 my $dir = Path::Class::File->new(__FILE__)->dir->parent->subdir('var');
165 $dir->mkpath unless -d "$dir";
168 sub _sqlite_dbfilename {
169 my $holder = $ENV{DBICTEST_LOCK_HOLDER} || $$;
170 $holder = $$ if $holder == -1;
172 # useful for missing cleanup debugging
173 #if ( $holder == $$) {
179 return "$dir/DBIxClass-$holder.db";
187 $SIG{INT} = sub { _cleanup_dbfile(); exit 1 };
189 my $need_global_cleanup;
190 sub _cleanup_dbfile {
191 # cleanup if this is us
193 ! $ENV{DBICTEST_LOCK_HOLDER}
195 $ENV{DBICTEST_LOCK_HOLDER} == -1
197 $ENV{DBICTEST_LOCK_HOLDER} == $$
199 if ($need_global_cleanup and my $dbh = DBICTest->schema->storage->_dbh) {
203 my $db_file = _sqlite_dbfilename();
204 unlink $_ for ($db_file, "${db_file}-journal");
209 return $ENV{"DBICTEST_DSN"} ? 1:0;
215 return $self->_sqlite_dbfilename if (
216 defined $args{sqlite_use_file} ? $args{sqlite_use_file} : $ENV{'DBICTEST_SQLITE_USE_FILE'}
225 if ($ENV{DBICTEST_DSN}) {
227 (map { $ENV{"DBICTEST_${_}"} || '' } qw/DSN DBUSER DBPASS/),
228 { AutoCommit => 1, %args },
231 my $db_file = $self->_sqlite_dbname(%args);
233 for ($db_file, "${db_file}-journal") {
235 unlink ($_) or carp (
236 "Unable to unlink existing test database file $_ ($!), creation of fresh database / further tests may fail!"
240 return ("dbi:SQLite:${db_file}", '', '', {
243 # this is executed on every connect, and thus installs a disconnect/DESTROY
244 # guard for every new $dbh
245 on_connect_do => sub {
248 my $dbh = $storage->_get_dbh;
251 $dbh->do ('PRAGMA synchronous = OFF');
254 $ENV{DBICTEST_SQLITE_REVERSE_DEFAULT_ORDER}
256 # the pragma does not work correctly before libsqlite 3.7.9
257 $storage->_server_info->{normalized_dbms_version} >= 3.007009
259 $dbh->do ('PRAGMA reverse_unordered_selects = ON');
262 # set a *DBI* disconnect callback, to make sure the physical SQLite
263 # file is still there (i.e. the test does not attempt to delete
264 # an open database, which fails on Win32)
265 if (! $storage->{master} and my $guard_cb = __mk_disconnect_guard($db_file)) {
266 $dbh->{Callbacks} = {
267 connect => sub { $guard_cb->('connect') },
268 disconnect => sub { $guard_cb->('disconnect') },
269 DESTROY => sub { &detected_reinvoked_destructor; $guard_cb->('DESTROY') },
277 sub __mk_disconnect_guard {
282 # this perl leaks handles, delaying DESTROY, can't work right
289 my $orig_inode = (stat($db_file))[1]
292 my $clan_connect_caller = '*UNKNOWN*';
294 while ( my ($pack, $file, $line) = caller(++$i) ) {
295 next if $file eq __FILE__;
296 next if $pack =~ /^DBIx::Class|^Try::Tiny/;
297 $clan_connect_caller = "$file line $line";
304 return if $failed_once;
307 if ($event eq 'connect') {
308 # this is necessary in case we are disconnected and connected again, all within the same $dbh object
312 elsif ($event eq 'disconnect') {
313 return unless $connected; # we already disconnected earlier
316 elsif ($event eq 'DESTROY' and ! $connected ) {
322 $fail_reason = 'is missing';
325 my $cur_inode = (stat($db_file))[1];
327 if ($orig_inode != $cur_inode) {
328 my @inodes = ($orig_inode, $cur_inode);
329 # unless this is a fixed perl (P5RT#84590) pack/unpack before display
330 # to match the unsigned longs returned by `stat`
331 @inodes = map { unpack ('L', pack ('l', $_) ) } @inodes
332 unless $Config{st_ino_size};
334 $fail_reason = sprintf
335 'was recreated (initially inode %s, now %s)',
344 require Test::Builder;
345 my $t = Test::Builder->new;
346 local $Test::Builder::Level = $Test::Builder::Level + 3;
348 "$db_file originally created at $clan_connect_caller $fail_reason before $event "
349 . 'of DBI handle - a strong indicator that the database file was tampered with while '
350 . 'still being open. This action would fail massively if running under Win32, hence '
351 . 'we make sure it fails on any OS :)'
355 return; # this empty return is a DBI requirement
359 my $weak_registry = {};
368 $ENV{DBICTEST_VIA_REPLICATED} &&=
369 ( !$args{storage_type} && !defined $args{sqlite_use_file} )
371 $args{storage_type} = ['::DBI::Replicated', { balancer_type => '::Random' }];
372 $args{sqlite_use_file} = 1;
375 my @dsn = $self->_database(%args);
377 if ($args{compose_connection}) {
378 $need_global_cleanup = 1;
379 $schema = DBICTest::Schema->compose_connection(
383 $schema = DBICTest::Schema->compose_namespace('DBICTest');
386 if( $args{storage_type}) {
387 $schema->storage_type($args{storage_type});
390 if ( !$args{no_connect} ) {
391 $schema->connection(@dsn);
393 $schema->storage->connect_replicants(\@dsn)
394 if $ENV{DBICTEST_VIA_REPLICATED};
397 if ( !$args{no_deploy} ) {
398 __PACKAGE__->deploy_schema( $schema, $args{deploy_args} );
399 __PACKAGE__->populate_schema( $schema )
400 if( !$args{no_populate} );
403 populate_weakregistry ( $weak_registry, $schema->storage )
404 if $INC{'Test/Builder.pm'} and $schema->storage;
410 # Make sure we run after any cleanup in other END blocks
411 push @{ B::end_av()->object_2svref }, sub {
412 assert_empty_weakregistry($weak_registry, 'quiet');
418 DBICTest->deploy_schema( $schema );
420 This method does one of two things to the schema. It can either call
421 the experimental $schema->deploy() if the DBICTEST_SQLT_DEPLOY environment
422 variable is set, otherwise the default is to read in the t/lib/sqlite.sql
423 file and execute the SQL within. Either way you end up with a fresh set
424 of tables for testing.
431 my $args = shift || {};
434 if ( ($ENV{TRAVIS}||'') eq 'true' and my $old_dbg = $schema->storage->debug ) {
435 $guard = scope_guard { $schema->storage->debug($old_dbg) };
436 $schema->storage->debug(0);
439 if ($ENV{"DBICTEST_SQLT_DEPLOY"}) {
440 $schema->deploy($args);
442 my $filename = Path::Class::File->new(__FILE__)->dir
443 ->file('sqlite.sql')->stringify;
444 my $sql = do { local (@ARGV, $/) = $filename ; <> };
445 for my $chunk ( split (/;\s*\n+/, $sql) ) {
446 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
447 $schema->storage->dbh_do(sub { $_[1]->do($chunk) }) or print "Error on SQL: $chunk\n";
454 =head2 populate_schema
456 DBICTest->populate_schema( $schema );
458 After you deploy your schema you can use this method to populate
459 the tables with test data.
463 sub populate_schema {
468 if ( ($ENV{TRAVIS}||'') eq 'true' and my $old_dbg = $schema->storage->debug ) {
469 $guard = scope_guard { $schema->storage->debug($old_dbg) };
470 $schema->storage->debug(0);
473 $schema->populate('Genre', [
478 $schema->populate('Artist', [
479 [ qw/artistid name/ ],
480 [ 1, 'Caterwauler McCrae' ],
481 [ 2, 'Random Boy Band' ],
482 [ 3, 'We Are Goth' ],
485 $schema->populate('CD', [
486 [ qw/cdid artist title year genreid/ ],
487 [ 1, 1, "Spoonful of bees", 1999, 1 ],
488 [ 2, 1, "Forkful of bees", 2001 ],
489 [ 3, 1, "Caterwaulin' Blues", 1997 ],
490 [ 4, 2, "Generic Manufactured Singles", 2001 ],
491 [ 5, 3, "Come Be Depressed With Us", 1998 ],
494 $schema->populate('LinerNotes', [
495 [ qw/liner_id notes/ ],
496 [ 2, "Buy Whiskey!" ],
498 [ 5, "Kill Yourself!" ],
501 $schema->populate('Tag', [
502 [ qw/tagid cd tag/ ],
514 $schema->populate('TwoKeys', [
521 $schema->populate('FourKeys', [
522 [ qw/foo bar hello goodbye sensors/ ],
523 [ 1, 2, 3, 4, 'online' ],
524 [ 5, 4, 3, 6, 'offline' ],
527 $schema->populate('OneKey', [
528 [ qw/id artist cd/ ],
534 $schema->populate('SelfRef', [
540 $schema->populate('SelfRefAlias', [
541 [ qw/self_ref alias/ ],
545 $schema->populate('ArtistUndirectedMap', [
550 $schema->populate('Producer', [
551 [ qw/producerid name/ ],
552 [ 1, 'Matt S Trout' ],
553 [ 2, 'Bob The Builder' ],
554 [ 3, 'Fred The Phenotype' ],
557 $schema->populate('CD_to_Producer', [
564 $schema->populate('TreeLike', [
565 [ qw/id parent name/ ],
566 [ 1, undef, 'root' ],
575 $schema->populate('Track', [
576 [ qw/trackid cd position title/ ],
577 [ 4, 2, 1, "Stung with Success"],
578 [ 5, 2, 2, "Stripy"],
579 [ 6, 2, 3, "Sticky Honey"],
580 [ 7, 3, 1, "Yowlin"],
581 [ 8, 3, 2, "Howlin"],
582 [ 9, 3, 3, "Fowlin"],
583 [ 10, 4, 1, "Boring Name"],
584 [ 11, 4, 2, "Boring Song"],
585 [ 12, 4, 3, "No More Ideas"],
587 [ 14, 5, 2, "Under The Weather"],
588 [ 15, 5, 3, "Suicidal"],
589 [ 16, 1, 1, "The Bees Knees"],
590 [ 17, 1, 2, "Apiary"],
591 [ 18, 1, 3, "Beehind You"],
594 $schema->populate('Event', [
595 [ qw/id starts_at created_on varchar_date varchar_datetime skip_inflation/ ],
596 [ 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'],
599 $schema->populate('Link', [
600 [ qw/id url title/ ],
604 $schema->populate('Bookmark', [
609 $schema->populate('Collection', [
610 [ qw/collectionid name/ ],
615 $schema->populate('TypedObject', [
616 [ qw/objectid type value/ ],
617 [ 1, "pointy", "Awl" ],
618 [ 2, "round", "Bearing" ],
619 [ 3, "pointy", "Knife" ],
620 [ 4, "pointy", "Tooth" ],
621 [ 5, "round", "Head" ],
623 $schema->populate('CollectionObject', [
624 [ qw/collection object/ ],
632 $schema->populate('Owners', [
638 $schema->populate('BooksInLibrary', [
639 [ qw/id owner title source price/ ],
640 [ 1, 1, "Programming Perl", "Library", 23 ],
641 [ 2, 1, "Dynamical Systems", "Library", 37 ],
642 [ 3, 2, "Best Recipe Cookbook", "Library", 65 ],