1 package # hide from PAUSE
8 # this noop trick initializes the STDOUT, so that the TAP::Harness
9 # issued IO::Select->can_read calls (which are blocking wtf wtf wtf)
10 # keep spinning and scheduling jobs
11 # This results in an overall much smoother job-queue drainage, since
12 # the Harness blocks less
13 # (ideally this needs to be addressed in T::H, but a quick patchjob
14 # broke everything so tabling it for now)
16 # FIXME - there probably is some way to determine a harness run (T::H or
17 # prove) but I do not know it offhand, especially on older environments
18 # Go with the safer option
19 if ($INC{'Test/Builder.pm'}) {
26 use DBICTest::Util qw( local_umask await_flock dbg DEBUG_TEST_CONCURRENCY_LOCKS );
28 use DBICTest::Util::LeakTracer qw/populate_weakregistry assert_empty_weakregistry/;
29 use DBIx::Class::_Util qw( detected_reinvoked_destructor scope_guard );
31 use Path::Class::File ();
33 use Fcntl qw/:DEFAULT :flock/;
38 DBICTest - Library to be used by DBIx::Class test scripts
46 my $schema = DBICTest->init_schema();
50 This module provides the basic utilities to write tests against
55 The module does not export anything by default, nor provides individual
56 function exports in the conventional sense. Instead the following tags are
61 Same as C<use SQL::Abstract::Test
62 qw(L<is_same_sql_bind|SQL::Abstract::Test/is_same_sql_bind>
63 L<is_same_sql|SQL::Abstract::Test/is_same_sql>
64 L<is_same_bind|SQL::Abstract::Test/is_same_bind>)>
68 Some tests are very time sensitive and need to run on their own, without
69 being disturbed by anything else grabbing CPU or disk IO. Hence why everything
70 using C<DBICTest> grabs a shared lock, and the few tests that request a
71 C<:GlobalLock> will ask for an exclusive one and block until they can get it.
77 my $schema = DBICTest->init_schema(
80 storage_type=>'::DBI::Replicated',
82 balancer_type=>'DBIx::Class::Storage::DBI::Replicated::Balancer::Random'
86 This method removes the test SQLite database in t/var/DBIxClass.db
87 and then creates a new, empty database.
89 This method will call L<deploy_schema()|/deploy_schema> by default, unless the
90 C<no_deploy> flag is set.
92 Also, by default, this method will call L<populate_schema()|/populate_schema>
93 by default, unless the C<no_deploy> or C<no_populate> flags are set.
98 our ($global_lock_fh, $global_exclusive_lock);
102 my $lockpath = DBICTest::RunMode->tmpdir->file('_dbictest_global.lock');
105 my $u = local_umask(0); # so that the file opens as 666, and any user can lock
106 sysopen ($global_lock_fh, $lockpath, O_RDWR|O_CREAT)
107 or die "Unable to open $lockpath: $!";
111 if ($exp eq ':GlobalLock') {
112 DEBUG_TEST_CONCURRENCY_LOCKS > 1
113 and dbg "Waiting for EXCLUSIVE global lock...";
115 await_flock ($global_lock_fh, LOCK_EX) or die "Unable to lock $lockpath: $!";
117 DEBUG_TEST_CONCURRENCY_LOCKS > 1
118 and dbg "Got EXCLUSIVE global lock";
120 $global_exclusive_lock = 1;
122 elsif ($exp eq ':DiffSQL') {
123 require SQL::Abstract::Test;
124 my $into = caller(0);
125 for (qw(is_same_sql_bind is_same_sql is_same_bind)) {
127 *{"${into}::$_"} = \&{"SQL::Abstract::Test::$_"};
131 croak "Unknown export $exp requested from $self";
135 unless ($global_exclusive_lock) {
136 DEBUG_TEST_CONCURRENCY_LOCKS > 1
137 and dbg "Waiting for SHARED global lock...";
139 await_flock ($global_lock_fh, LOCK_SH) or die "Unable to lock $lockpath: $!";
141 DEBUG_TEST_CONCURRENCY_LOCKS > 1
142 and dbg "Got SHARED global lock";
147 # referencing here delays destruction even more
148 if ($global_lock_fh) {
149 DEBUG_TEST_CONCURRENCY_LOCKS > 1
150 and dbg "Release @{[ $global_exclusive_lock ? 'EXCLUSIVE' : 'SHARED' ]} global lock (END)";
156 my $dir = Path::Class::File->new(__FILE__)->dir->parent->subdir('var');
157 $dir->mkpath unless -d "$dir";
160 sub _sqlite_dbfilename {
161 my $holder = $ENV{DBICTEST_LOCK_HOLDER} || $$;
162 $holder = $$ if $holder == -1;
164 # useful for missing cleanup debugging
165 #if ( $holder == $$) {
171 return "$dir/DBIxClass-$holder.db";
179 $SIG{INT} = sub { _cleanup_dbfile(); exit 1 };
181 my $need_global_cleanup;
182 sub _cleanup_dbfile {
183 # cleanup if this is us
185 ! $ENV{DBICTEST_LOCK_HOLDER}
187 $ENV{DBICTEST_LOCK_HOLDER} == -1
189 $ENV{DBICTEST_LOCK_HOLDER} == $$
191 if ($need_global_cleanup and my $dbh = DBICTest->schema->storage->_dbh) {
195 my $db_file = _sqlite_dbfilename();
196 unlink $_ for ($db_file, "${db_file}-journal");
201 return $ENV{"DBICTEST_DSN"} ? 1:0;
207 return $self->_sqlite_dbfilename if (
208 defined $args{sqlite_use_file} ? $args{sqlite_use_file} : $ENV{'DBICTEST_SQLITE_USE_FILE'}
217 if ($ENV{DBICTEST_DSN}) {
219 (map { $ENV{"DBICTEST_${_}"} || '' } qw/DSN DBUSER DBPASS/),
220 { AutoCommit => 1, %args },
223 my $db_file = $self->_sqlite_dbname(%args);
225 for ($db_file, "${db_file}-journal") {
227 unlink ($_) or carp (
228 "Unable to unlink existing test database file $_ ($!), creation of fresh database / further tests may fail!"
232 return ("dbi:SQLite:${db_file}", '', '', {
235 # this is executed on every connect, and thus installs a disconnect/DESTROY
236 # guard for every new $dbh
237 on_connect_do => sub {
240 my $dbh = $storage->_get_dbh;
243 $dbh->do ('PRAGMA synchronous = OFF');
246 $ENV{DBICTEST_SQLITE_REVERSE_DEFAULT_ORDER}
248 # the pragma does not work correctly before libsqlite 3.7.9
249 $storage->_server_info->{normalized_dbms_version} >= 3.007009
251 $dbh->do ('PRAGMA reverse_unordered_selects = ON');
254 # set a *DBI* disconnect callback, to make sure the physical SQLite
255 # file is still there (i.e. the test does not attempt to delete
256 # an open database, which fails on Win32)
257 if (! $storage->{master} and my $guard_cb = __mk_disconnect_guard($db_file)) {
258 $dbh->{Callbacks} = {
259 connect => sub { $guard_cb->('connect') },
260 disconnect => sub { $guard_cb->('disconnect') },
261 DESTROY => sub { &detected_reinvoked_destructor; $guard_cb->('DESTROY') },
269 sub __mk_disconnect_guard {
274 # this perl leaks handles, delaying DESTROY, can't work right
275 DBIx::Class::_ENV_::PEEPEENESS
281 my $orig_inode = (stat($db_file))[1]
284 my $clan_connect_caller = '*UNKNOWN*';
286 while ( my ($pack, $file, $line) = caller(++$i) ) {
287 next if $file eq __FILE__;
288 next if $pack =~ /^DBIx::Class|^Try::Tiny/;
289 $clan_connect_caller = "$file line $line";
296 return if $failed_once;
299 if ($event eq 'connect') {
300 # this is necessary in case we are disconnected and connected again, all within the same $dbh object
304 elsif ($event eq 'disconnect') {
305 return unless $connected; # we already disconnected earlier
308 elsif ($event eq 'DESTROY' and ! $connected ) {
314 $fail_reason = 'is missing';
317 my $cur_inode = (stat($db_file))[1];
319 if ($orig_inode != $cur_inode) {
320 my @inodes = ($orig_inode, $cur_inode);
321 # unless this is a fixed perl (P5RT#84590) pack/unpack before display
322 # to match the unsigned longs returned by `stat`
323 @inodes = map { unpack ('L', pack ('l', $_) ) } @inodes
324 unless $Config{st_ino_size};
326 $fail_reason = sprintf
327 'was recreated (initially inode %s, now %s)',
336 require Test::Builder;
337 my $t = Test::Builder->new;
338 local $Test::Builder::Level = $Test::Builder::Level + 3;
340 "$db_file originally created at $clan_connect_caller $fail_reason before $event "
341 . 'of DBI handle - a strong indicator that the database file was tampered with while '
342 . 'still being open. This action would fail massively if running under Win32, hence '
343 . 'we make sure it fails on any OS :)'
347 return; # this empty return is a DBI requirement
351 my $weak_registry = {};
360 $ENV{DBICTEST_VIA_REPLICATED} &&=
361 ( !$args{storage_type} && !defined $args{sqlite_use_file} )
363 $args{storage_type} = ['::DBI::Replicated', { balancer_type => '::Random' }];
364 $args{sqlite_use_file} = 1;
367 my @dsn = $self->_database(%args);
369 if ($args{compose_connection}) {
370 $need_global_cleanup = 1;
371 $schema = DBICTest::Schema->compose_connection(
375 $schema = DBICTest::Schema->compose_namespace('DBICTest');
378 if( $args{storage_type}) {
379 $schema->storage_type($args{storage_type});
382 if ( !$args{no_connect} ) {
383 $schema->connection(@dsn);
385 $schema->storage->connect_replicants(\@dsn)
386 if $ENV{DBICTEST_VIA_REPLICATED};
389 if ( !$args{no_deploy} ) {
390 __PACKAGE__->deploy_schema( $schema, $args{deploy_args} );
391 __PACKAGE__->populate_schema( $schema )
392 if( !$args{no_populate} );
395 populate_weakregistry ( $weak_registry, $schema->storage )
396 if $INC{'Test/Builder.pm'} and $schema->storage;
402 # Make sure we run after any cleanup in other END blocks
403 push @{ B::end_av()->object_2svref }, sub {
404 assert_empty_weakregistry($weak_registry, 'quiet');
410 DBICTest->deploy_schema( $schema );
412 This method does one of two things to the schema. It can either call
413 the experimental $schema->deploy() if the DBICTEST_SQLT_DEPLOY environment
414 variable is set, otherwise the default is to read in the t/lib/sqlite.sql
415 file and execute the SQL within. Either way you end up with a fresh set
416 of tables for testing.
423 my $args = shift || {};
426 if ( ($ENV{TRAVIS}||'') eq 'true' and my $old_dbg = $schema->storage->debug ) {
427 $guard = scope_guard { $schema->storage->debug($old_dbg) };
428 $schema->storage->debug(0);
431 if ($ENV{"DBICTEST_SQLT_DEPLOY"}) {
432 $schema->deploy($args);
434 my $filename = Path::Class::File->new(__FILE__)->dir
435 ->file('sqlite.sql')->stringify;
436 my $sql = do { local (@ARGV, $/) = $filename ; <> };
437 for my $chunk ( split (/;\s*\n+/, $sql) ) {
438 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
439 $schema->storage->dbh_do(sub { $_[1]->do($chunk) }) or print "Error on SQL: $chunk\n";
446 =head2 populate_schema
448 DBICTest->populate_schema( $schema );
450 After you deploy your schema you can use this method to populate
451 the tables with test data.
455 sub populate_schema {
460 if ( ($ENV{TRAVIS}||'') eq 'true' and my $old_dbg = $schema->storage->debug ) {
461 $guard = scope_guard { $schema->storage->debug($old_dbg) };
462 $schema->storage->debug(0);
465 $schema->populate('Genre', [
470 $schema->populate('Artist', [
471 [ qw/artistid name/ ],
472 [ 1, 'Caterwauler McCrae' ],
473 [ 2, 'Random Boy Band' ],
474 [ 3, 'We Are Goth' ],
477 $schema->populate('CD', [
478 [ qw/cdid artist title year genreid/ ],
479 [ 1, 1, "Spoonful of bees", 1999, 1 ],
480 [ 2, 1, "Forkful of bees", 2001 ],
481 [ 3, 1, "Caterwaulin' Blues", 1997 ],
482 [ 4, 2, "Generic Manufactured Singles", 2001 ],
483 [ 5, 3, "Come Be Depressed With Us", 1998 ],
486 $schema->populate('LinerNotes', [
487 [ qw/liner_id notes/ ],
488 [ 2, "Buy Whiskey!" ],
490 [ 5, "Kill Yourself!" ],
493 $schema->populate('Tag', [
494 [ qw/tagid cd tag/ ],
506 $schema->populate('TwoKeys', [
513 $schema->populate('FourKeys', [
514 [ qw/foo bar hello goodbye sensors/ ],
515 [ 1, 2, 3, 4, 'online' ],
516 [ 5, 4, 3, 6, 'offline' ],
519 $schema->populate('OneKey', [
520 [ qw/id artist cd/ ],
526 $schema->populate('SelfRef', [
532 $schema->populate('SelfRefAlias', [
533 [ qw/self_ref alias/ ],
537 $schema->populate('ArtistUndirectedMap', [
542 $schema->populate('Producer', [
543 [ qw/producerid name/ ],
544 [ 1, 'Matt S Trout' ],
545 [ 2, 'Bob The Builder' ],
546 [ 3, 'Fred The Phenotype' ],
549 $schema->populate('CD_to_Producer', [
556 $schema->populate('TreeLike', [
557 [ qw/id parent name/ ],
558 [ 1, undef, 'root' ],
567 $schema->populate('Track', [
568 [ qw/trackid cd position title/ ],
569 [ 4, 2, 1, "Stung with Success"],
570 [ 5, 2, 2, "Stripy"],
571 [ 6, 2, 3, "Sticky Honey"],
572 [ 7, 3, 1, "Yowlin"],
573 [ 8, 3, 2, "Howlin"],
574 [ 9, 3, 3, "Fowlin"],
575 [ 10, 4, 1, "Boring Name"],
576 [ 11, 4, 2, "Boring Song"],
577 [ 12, 4, 3, "No More Ideas"],
579 [ 14, 5, 2, "Under The Weather"],
580 [ 15, 5, 3, "Suicidal"],
581 [ 16, 1, 1, "The Bees Knees"],
582 [ 17, 1, 2, "Apiary"],
583 [ 18, 1, 3, "Beehind You"],
586 $schema->populate('Event', [
587 [ qw/id starts_at created_on varchar_date varchar_datetime skip_inflation/ ],
588 [ 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'],
591 $schema->populate('Link', [
592 [ qw/id url title/ ],
596 $schema->populate('Bookmark', [
601 $schema->populate('Collection', [
602 [ qw/collectionid name/ ],
607 $schema->populate('TypedObject', [
608 [ qw/objectid type value/ ],
609 [ 1, "pointy", "Awl" ],
610 [ 2, "round", "Bearing" ],
611 [ 3, "pointy", "Knife" ],
612 [ 4, "pointy", "Tooth" ],
613 [ 5, "round", "Head" ],
615 $schema->populate('CollectionObject', [
616 [ qw/collection object/ ],
624 $schema->populate('Owners', [
630 $schema->populate('BooksInLibrary', [
631 [ qw/id owner title source price/ ],
632 [ 1, 1, "Programming Perl", "Library", 23 ],
633 [ 2, 1, "Dynamical Systems", "Library", 37 ],
634 [ 3, 2, "Best Recipe Cookbook", "Library", 65 ],