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'}) {
23 select( ( select(\*STDOUT), $|=1 )[0] );
29 use DBICTest::Util qw(
30 local_umask slurp_bytes tmpdir await_flock
31 dbg DEBUG_TEST_CONCURRENCY_LOCKS PEEPEENESS
33 use DBICTest::Util::LeakTracer qw/populate_weakregistry assert_empty_weakregistry/;
35 # The actual ASSERT logic is in BaseSchema for pesky load-order reasons
36 # Hence run this through once, *before* DBICTest::Schema and friends load
39 DBIx::Class::_ENV_::ASSERT_NO_ERRONEOUS_METAINSTANCE_USE
41 DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS
43 require DBIx::Class::Row;
44 require DBICTest::BaseSchema;
45 DBICTest::BaseSchema->connect( sub {} );
50 use DBIx::Class::_Util qw( detected_reinvoked_destructor scope_guard modver_gt_or_eq );
52 use Fcntl qw/:DEFAULT :flock/;
57 DBICTest - Library to be used by DBIx::Class test scripts
61 BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) }
68 my $schema = DBICTest->init_schema();
72 This module provides the basic utilities to write tests against
77 The module does not export anything by default, nor provides individual
78 function exports in the conventional sense. Instead the following tags are
83 Same as C<use SQL::Abstract::Test
84 qw(L<is_same_sql_bind|SQL::Abstract::Test/is_same_sql_bind>
85 L<is_same_sql|SQL::Abstract::Test/is_same_sql>
86 L<is_same_bind|SQL::Abstract::Test/is_same_bind>)>
90 Some tests are very time sensitive and need to run on their own, without
91 being disturbed by anything else grabbing CPU or disk IO. Hence why everything
92 using C<DBICTest> grabs a shared lock, and the few tests that request a
93 C<:GlobalLock> will ask for an exclusive one and block until they can get it.
99 my $schema = DBICTest->init_schema(
102 storage_type=>'::DBI::Replicated',
104 balancer_type=>'DBIx::Class::Storage::DBI::Replicated::Balancer::Random'
108 This method removes the test SQLite database in t/var/DBIxClass.db
109 and then creates a new, empty database.
111 This method will call L<deploy_schema()|/deploy_schema> by default, unless the
112 C<no_deploy> flag is set.
114 Also, by default, this method will call L<populate_schema()|/populate_schema>
115 by default, unless the C<no_deploy> or C<no_populate> flags are set.
119 # see L</:GlobalLock>
120 our ($global_lock_fh, $global_exclusive_lock);
124 my $lockpath = tmpdir . '_dbictest_global.lock';
127 my $u = local_umask(0); # so that the file opens as 666, and any user can lock
128 sysopen ($global_lock_fh, $lockpath, O_RDWR|O_CREAT)
129 or die "Unable to open $lockpath: $!";
133 if ($exp eq ':GlobalLock') {
134 DEBUG_TEST_CONCURRENCY_LOCKS > 1
135 and dbg "Waiting for EXCLUSIVE global lock...";
137 await_flock ($global_lock_fh, LOCK_EX) or die "Unable to lock $lockpath: $!";
139 DEBUG_TEST_CONCURRENCY_LOCKS > 1
140 and dbg "Got EXCLUSIVE global lock";
142 $global_exclusive_lock = 1;
144 elsif ($exp eq ':DiffSQL') {
145 require SQL::Abstract::Test;
146 my $into = caller(0);
147 for (qw(is_same_sql_bind is_same_sql is_same_bind)) {
149 *{"${into}::$_"} = \&{"SQL::Abstract::Test::$_"};
153 croak "Unknown export $exp requested from $self";
157 unless ($global_exclusive_lock) {
158 DEBUG_TEST_CONCURRENCY_LOCKS > 1
159 and dbg "Waiting for SHARED global lock...";
161 await_flock ($global_lock_fh, LOCK_SH) or die "Unable to lock $lockpath: $!";
163 DEBUG_TEST_CONCURRENCY_LOCKS > 1
164 and dbg "Got SHARED global lock";
169 # referencing here delays destruction even more
170 if ($global_lock_fh) {
171 DEBUG_TEST_CONCURRENCY_LOCKS > 1
172 and dbg "Release @{[ $global_exclusive_lock ? 'EXCLUSIVE' : 'SHARED' ]} global lock (END)";
179 sub _sqlite_dbfilename {
180 my $holder = $ENV{DBICTEST_LOCK_HOLDER} || $$;
181 $holder = $$ if $holder == -1;
183 return "t/var/DBIxClass-$holder.db";
186 $SIG{INT} = sub { _cleanup_dbfile(); exit 1 };
188 my $need_global_cleanup;
189 sub _cleanup_dbfile {
190 # cleanup if this is us
192 ! $ENV{DBICTEST_LOCK_HOLDER}
194 $ENV{DBICTEST_LOCK_HOLDER} == -1
196 $ENV{DBICTEST_LOCK_HOLDER} == $$
198 if ($need_global_cleanup and my $dbh = DBICTest->schema->storage->_dbh) {
202 my $db_file = _sqlite_dbfilename();
203 unlink $_ for ($db_file, "${db_file}-journal");
208 return $ENV{"DBICTEST_DSN"} ? 1:0;
214 return $self->_sqlite_dbfilename if (
215 defined $args{sqlite_use_file} ? $args{sqlite_use_file} : $ENV{'DBICTEST_SQLITE_USE_FILE'}
224 if ($ENV{DBICTEST_DSN}) {
226 (map { $ENV{"DBICTEST_${_}"} || '' } qw/DSN DBUSER DBPASS/),
227 { AutoCommit => 1, %args },
230 my $db_file = $self->_sqlite_dbname(%args);
232 for ($db_file, "${db_file}-journal") {
234 unlink ($_) or carp (
235 "Unable to unlink existing test database file $_ ($!), creation of fresh database / further tests may fail!"
239 return ("dbi:SQLite:${db_file}", '', '', {
242 # this is executed on every connect, and thus installs a disconnect/DESTROY
243 # guard for every new $dbh
244 on_connect_do => sub {
247 my $dbh = $storage->_get_dbh;
250 $dbh->do ('PRAGMA synchronous = OFF');
253 $ENV{DBICTEST_SQLITE_REVERSE_DEFAULT_ORDER}
255 # the pragma does not work correctly before libsqlite 3.7.9
256 $storage->_server_info->{normalized_dbms_version} >= 3.007009
258 $dbh->do ('PRAGMA reverse_unordered_selects = ON');
261 # set a *DBI* disconnect callback, to make sure the physical SQLite
262 # file is still there (i.e. the test does not attempt to delete
263 # an open database, which fails on Win32)
264 if (! $storage->{master} and my $guard_cb = __mk_disconnect_guard($db_file)) {
265 $dbh->{Callbacks} = {
266 connect => sub { $guard_cb->('connect') },
267 disconnect => sub { $guard_cb->('disconnect') },
268 DESTROY => sub { &detected_reinvoked_destructor; $guard_cb->('DESTROY') },
276 sub __mk_disconnect_guard {
281 # this perl leaks handles, delaying DESTROY, can't work right
288 my $orig_inode = (stat($db_file))[1]
291 my $clan_connect_caller = '*UNKNOWN*';
293 while ( my ($pack, $file, $line) = CORE::caller(++$i) ) {
294 next if $file eq __FILE__;
295 next if $pack =~ /^DBIx::Class|^Try::Tiny/;
296 $clan_connect_caller = "$file line $line";
303 return if $failed_once;
306 if ($event eq 'connect') {
307 # this is necessary in case we are disconnected and connected again, all within the same $dbh object
311 elsif ($event eq 'disconnect') {
312 return unless $connected; # we already disconnected earlier
315 elsif ($event eq 'DESTROY' and ! $connected ) {
321 $fail_reason = 'is missing';
324 my $cur_inode = (stat($db_file))[1];
326 if ($orig_inode != $cur_inode) {
327 my @inodes = ($orig_inode, $cur_inode);
328 # unless this is a fixed perl (P5RT#84590) pack/unpack before display
329 # to match the unsigned longs returned by `stat`
330 @inodes = map { unpack ('L', pack ('l', $_) ) } @inodes
331 unless $Config{st_ino_size};
333 $fail_reason = sprintf
334 'was recreated (initially inode %s, now %s)',
343 require Test::Builder;
344 my $t = Test::Builder->new;
345 local $Test::Builder::Level = $Test::Builder::Level + 3;
347 "$db_file originally created at $clan_connect_caller $fail_reason before $event "
348 . 'of DBI handle - a strong indicator that the database file was tampered with while '
349 . 'still being open. This action would fail massively if running under Win32, hence '
350 . 'we make sure it fails on any OS :)'
354 return; # this empty return is a DBI requirement
358 my $weak_registry = {};
367 $ENV{DBICTEST_VIA_REPLICATED} &&= (
370 ( ! defined $args{sqlite_use_file} or $args{sqlite_use_file} )
373 $args{storage_type} = ['::DBI::Replicated', { balancer_type => '::Random' }];
374 $args{sqlite_use_file} = 1;
377 my @dsn = $self->_database(%args);
379 if ($args{compose_connection}) {
380 $need_global_cleanup = 1;
381 $schema = DBICTest::Schema->compose_connection(
385 $schema = DBICTest::Schema->compose_namespace('DBICTest');
388 if( $args{storage_type}) {
389 $schema->storage_type($args{storage_type});
392 if ( !$args{no_connect} ) {
393 $schema->connection(@dsn);
395 if( $ENV{DBICTEST_VIA_REPLICATED} ) {
397 # add explicit ReadOnly=1 if we can support it
398 $dsn[0] =~ /^dbi:SQLite:/i
402 modver_gt_or_eq('DBD::SQLite', '1.49_05')
404 $dsn[0] =~ s/^dbi:SQLite:/dbi:SQLite(ReadOnly=1):/i;
406 $schema->storage->connect_replicants(\@dsn);
410 if ( !$args{no_deploy} ) {
411 __PACKAGE__->deploy_schema( $schema, $args{deploy_args} );
412 __PACKAGE__->populate_schema( $schema )
413 if( !$args{no_populate} );
416 populate_weakregistry ( $weak_registry, $schema->storage )
417 if $INC{'Test/Builder.pm'} and $schema->storage;
423 # Make sure we run after any cleanup in other END blocks
424 push @{ B::end_av()->object_2svref }, sub {
425 assert_empty_weakregistry($weak_registry, 'quiet');
431 DBICTest->deploy_schema( $schema );
433 This method does one of two things to the schema. It can either call
434 the experimental $schema->deploy() if the DBICTEST_SQLT_DEPLOY environment
435 variable is set, otherwise the default is to read in the t/lib/sqlite.sql
436 file and execute the SQL within. Either way you end up with a fresh set
437 of tables for testing.
444 my $args = shift || {};
447 if ( ($ENV{TRAVIS}||'') eq 'true' and my $old_dbg = $schema->storage->debug ) {
448 $guard = scope_guard { $schema->storage->debug($old_dbg) };
449 $schema->storage->debug(0);
452 if ($ENV{"DBICTEST_SQLT_DEPLOY"}) {
453 $schema->deploy($args);
455 my $sql = slurp_bytes( 't/lib/sqlite.sql' );
456 for my $chunk ( split (/;\s*\n+/, $sql) ) {
457 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
458 $schema->storage->dbh_do(sub { $_[1]->do($chunk) }) or print "Error on SQL: $chunk\n";
465 =head2 populate_schema
467 DBICTest->populate_schema( $schema );
469 After you deploy your schema you can use this method to populate
470 the tables with test data.
474 sub populate_schema {
479 if ( ($ENV{TRAVIS}||'') eq 'true' and my $old_dbg = $schema->storage->debug ) {
480 $guard = scope_guard { $schema->storage->debug($old_dbg) };
481 $schema->storage->debug(0);
484 $schema->populate('Genre', [
489 $schema->populate('Artist', [
490 [ qw/artistid name/ ],
491 [ 1, 'Caterwauler McCrae' ],
492 [ 2, 'Random Boy Band' ],
493 [ 3, 'We Are Goth' ],
496 $schema->populate('CD', [
497 [ qw/cdid artist title year genreid/ ],
498 [ 1, 1, "Spoonful of bees", 1999, 1 ],
499 [ 2, 1, "Forkful of bees", 2001 ],
500 [ 3, 1, "Caterwaulin' Blues", 1997 ],
501 [ 4, 2, "Generic Manufactured Singles", 2001 ],
502 [ 5, 3, "Come Be Depressed With Us", 1998 ],
505 $schema->populate('LinerNotes', [
506 [ qw/liner_id notes/ ],
507 [ 2, "Buy Whiskey!" ],
509 [ 5, "Kill Yourself!" ],
512 $schema->populate('Tag', [
513 [ qw/tagid cd tag/ ],
525 $schema->populate('TwoKeys', [
532 $schema->populate('FourKeys', [
533 [ qw/foo bar hello goodbye sensors/ ],
534 [ 1, 2, 3, 4, 'online' ],
535 [ 5, 4, 3, 6, 'offline' ],
538 $schema->populate('OneKey', [
539 [ qw/id artist cd/ ],
545 $schema->populate('SelfRef', [
551 $schema->populate('SelfRefAlias', [
552 [ qw/self_ref alias/ ],
556 $schema->populate('ArtistUndirectedMap', [
561 $schema->populate('Producer', [
562 [ qw/producerid name/ ],
563 [ 1, 'Matt S Trout' ],
564 [ 2, 'Bob The Builder' ],
565 [ 3, 'Fred The Phenotype' ],
568 $schema->populate('CD_to_Producer', [
575 $schema->populate('TreeLike', [
576 [ qw/id parent name/ ],
577 [ 1, undef, 'root' ],
586 $schema->populate('Track', [
587 [ qw/trackid cd position title/ ],
588 [ 4, 2, 1, "Stung with Success"],
589 [ 5, 2, 2, "Stripy"],
590 [ 6, 2, 3, "Sticky Honey"],
591 [ 7, 3, 1, "Yowlin"],
592 [ 8, 3, 2, "Howlin"],
593 [ 9, 3, 3, "Fowlin"],
594 [ 10, 4, 1, "Boring Name"],
595 [ 11, 4, 2, "Boring Song"],
596 [ 12, 4, 3, "No More Ideas"],
598 [ 14, 5, 2, "Under The Weather"],
599 [ 15, 5, 3, "Suicidal"],
600 [ 16, 1, 1, "The Bees Knees"],
601 [ 17, 1, 2, "Apiary"],
602 [ 18, 1, 3, "Beehind You"],
605 $schema->populate('Event', [
606 [ qw/id starts_at created_on varchar_date varchar_datetime skip_inflation/ ],
607 [ 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'],
610 $schema->populate('Link', [
611 [ qw/id url title/ ],
615 $schema->populate('Bookmark', [
620 $schema->populate('Collection', [
621 [ qw/collectionid name/ ],
626 $schema->populate('TypedObject', [
627 [ qw/objectid type value/ ],
628 [ 1, "pointy", "Awl" ],
629 [ 2, "round", "Bearing" ],
630 [ 3, "pointy", "Knife" ],
631 [ 4, "pointy", "Tooth" ],
632 [ 5, "round", "Head" ],
634 $schema->populate('CollectionObject', [
635 [ qw/collection object/ ],
643 $schema->populate('Owners', [
649 $schema->populate('BooksInLibrary', [
650 [ qw/id owner title source price/ ],
651 [ 1, 1, "Programming Perl", "Library", 23 ],
652 [ 2, 1, "Dynamical Systems", "Library", 37 ],
653 [ 3, 2, "Best Recipe Cookbook", "Library", 65 ],