1 package # hide from PAUSE
7 use DBICTest::Util qw( local_umask await_flock dbg DEBUG_TEST_CONCURRENCY_LOCKS );
9 use DBICTest::Util::LeakTracer qw/populate_weakregistry assert_empty_weakregistry/;
10 use DBIx::Class::_Util qw( detected_reinvoked_destructor scope_guard );
12 use Path::Class::File ();
14 use Fcntl qw/:DEFAULT :flock/;
19 DBICTest - Library to be used by DBIx::Class test scripts
27 my $schema = DBICTest->init_schema();
31 This module provides the basic utilities to write tests against
36 The module does not export anything by default, nor provides individual
37 function exports in the conventional sense. Instead the following tags are
42 Same as C<use SQL::Abstract::Test
43 qw(L<is_same_sql_bind|SQL::Abstract::Test/is_same_sql_bind>
44 L<is_same_sql|SQL::Abstract::Test/is_same_sql>
45 L<is_same_bind|SQL::Abstract::Test/is_same_bind>)>
49 Some tests are very time sensitive and need to run on their own, without
50 being disturbed by anything else grabbing CPU or disk IO. Hence why everything
51 using C<DBICTest> grabs a shared lock, and the few tests that request a
52 C<:GlobalLock> will ask for an exclusive one and block until they can get it.
58 my $schema = DBICTest->init_schema(
61 storage_type=>'::DBI::Replicated',
63 balancer_type=>'DBIx::Class::Storage::DBI::Replicated::Balancer::Random'
67 This method removes the test SQLite database in t/var/DBIxClass.db
68 and then creates a new, empty database.
70 This method will call L<deploy_schema()|/deploy_schema> by default, unless the
71 C<no_deploy> flag is set.
73 Also, by default, this method will call L<populate_schema()|/populate_schema>
74 by default, unless the C<no_deploy> or C<no_populate> flags are set.
79 our ($global_lock_fh, $global_exclusive_lock);
83 my $lockpath = DBICTest::RunMode->tmpdir->file('_dbictest_global.lock');
86 my $u = local_umask(0); # so that the file opens as 666, and any user can lock
87 sysopen ($global_lock_fh, $lockpath, O_RDWR|O_CREAT)
88 or die "Unable to open $lockpath: $!";
92 if ($exp eq ':GlobalLock') {
93 DEBUG_TEST_CONCURRENCY_LOCKS > 1
94 and dbg "Waiting for EXCLUSIVE global lock...";
96 await_flock ($global_lock_fh, LOCK_EX) or die "Unable to lock $lockpath: $!";
98 DEBUG_TEST_CONCURRENCY_LOCKS > 1
99 and dbg "Got EXCLUSIVE global lock";
101 $global_exclusive_lock = 1;
103 elsif ($exp eq ':DiffSQL') {
104 require SQL::Abstract::Test;
105 my $into = caller(0);
106 for (qw(is_same_sql_bind is_same_sql is_same_bind)) {
108 *{"${into}::$_"} = \&{"SQL::Abstract::Test::$_"};
112 croak "Unknown export $exp requested from $self";
116 unless ($global_exclusive_lock) {
117 DEBUG_TEST_CONCURRENCY_LOCKS > 1
118 and dbg "Waiting for SHARED global lock...";
120 await_flock ($global_lock_fh, LOCK_SH) or die "Unable to lock $lockpath: $!";
122 DEBUG_TEST_CONCURRENCY_LOCKS > 1
123 and dbg "Got SHARED global lock";
128 # referencing here delays destruction even more
129 if ($global_lock_fh) {
130 DEBUG_TEST_CONCURRENCY_LOCKS > 1
131 and dbg "Release @{[ $global_exclusive_lock ? 'EXCLUSIVE' : 'SHARED' ]} global lock (END)";
137 my $dir = Path::Class::File->new(__FILE__)->dir->parent->subdir('var');
138 $dir->mkpath unless -d "$dir";
141 sub _sqlite_dbfilename {
142 my $holder = $ENV{DBICTEST_LOCK_HOLDER} || $$;
143 $holder = $$ if $holder == -1;
145 # useful for missing cleanup debugging
146 #if ( $holder == $$) {
152 return "$dir/DBIxClass-$holder.db";
160 $SIG{INT} = sub { _cleanup_dbfile(); exit 1 };
162 my $need_global_cleanup;
163 sub _cleanup_dbfile {
164 # cleanup if this is us
166 ! $ENV{DBICTEST_LOCK_HOLDER}
168 $ENV{DBICTEST_LOCK_HOLDER} == -1
170 $ENV{DBICTEST_LOCK_HOLDER} == $$
172 if ($need_global_cleanup and my $dbh = DBICTest->schema->storage->_dbh) {
176 my $db_file = _sqlite_dbfilename();
177 unlink $_ for ($db_file, "${db_file}-journal");
182 return $ENV{"DBICTEST_DSN"} ? 1:0;
188 return $self->_sqlite_dbfilename if (
189 defined $args{sqlite_use_file} ? $args{sqlite_use_file} : $ENV{'DBICTEST_SQLITE_USE_FILE'}
198 if ($ENV{DBICTEST_DSN}) {
200 (map { $ENV{"DBICTEST_${_}"} || '' } qw/DSN DBUSER DBPASS/),
201 { AutoCommit => 1, %args },
204 my $db_file = $self->_sqlite_dbname(%args);
206 for ($db_file, "${db_file}-journal") {
208 unlink ($_) or carp (
209 "Unable to unlink existing test database file $_ ($!), creation of fresh database / further tests may fail!"
213 return ("dbi:SQLite:${db_file}", '', '', {
216 # this is executed on every connect, and thus installs a disconnect/DESTROY
217 # guard for every new $dbh
218 on_connect_do => sub {
221 my $dbh = $storage->_get_dbh;
224 $dbh->do ('PRAGMA synchronous = OFF');
227 $ENV{DBICTEST_SQLITE_REVERSE_DEFAULT_ORDER}
229 # the pragma does not work correctly before libsqlite 3.7.9
230 $storage->_server_info->{normalized_dbms_version} >= 3.007009
232 $dbh->do ('PRAGMA reverse_unordered_selects = ON');
235 # set a *DBI* disconnect callback, to make sure the physical SQLite
236 # file is still there (i.e. the test does not attempt to delete
237 # an open database, which fails on Win32)
238 if (! $storage->{master} and my $guard_cb = __mk_disconnect_guard($db_file)) {
239 $dbh->{Callbacks} = {
240 connect => sub { $guard_cb->('connect') },
241 disconnect => sub { $guard_cb->('disconnect') },
242 DESTROY => sub { &detected_reinvoked_destructor; $guard_cb->('DESTROY') },
250 sub __mk_disconnect_guard {
255 # this perl leaks handles, delaying DESTROY, can't work right
256 DBIx::Class::_ENV_::PEEPEENESS
262 my $orig_inode = (stat($db_file))[1]
265 my $clan_connect_caller = '*UNKNOWN*';
267 while ( my ($pack, $file, $line) = caller(++$i) ) {
268 next if $file eq __FILE__;
269 next if $pack =~ /^DBIx::Class|^Try::Tiny/;
270 $clan_connect_caller = "$file line $line";
277 return if $failed_once;
280 if ($event eq 'connect') {
281 # this is necessary in case we are disconnected and connected again, all within the same $dbh object
285 elsif ($event eq 'disconnect') {
286 return unless $connected; # we already disconnected earlier
289 elsif ($event eq 'DESTROY' and ! $connected ) {
295 $fail_reason = 'is missing';
298 my $cur_inode = (stat($db_file))[1];
300 if ($orig_inode != $cur_inode) {
301 my @inodes = ($orig_inode, $cur_inode);
302 # unless this is a fixed perl (P5RT#84590) pack/unpack before display
303 # to match the unsigned longs returned by `stat`
304 @inodes = map { unpack ('L', pack ('l', $_) ) } @inodes
305 unless $Config{st_ino_size};
307 $fail_reason = sprintf
308 'was recreated (initially inode %s, now %s)',
317 require Test::Builder;
318 my $t = Test::Builder->new;
319 local $Test::Builder::Level = $Test::Builder::Level + 3;
321 "$db_file originally created at $clan_connect_caller $fail_reason before $event "
322 . 'of DBI handle - a strong indicator that the database file was tampered with while '
323 . 'still being open. This action would fail massively if running under Win32, hence '
324 . 'we make sure it fails on any OS :)'
328 return; # this empty return is a DBI requirement
332 my $weak_registry = {};
341 $ENV{DBICTEST_VIA_REPLICATED} &&=
342 ( !$args{storage_type} && !defined $args{sqlite_use_file} )
344 $args{storage_type} = ['::DBI::Replicated', { balancer_type => '::Random' }];
345 $args{sqlite_use_file} = 1;
348 my @dsn = $self->_database(%args);
350 if ($args{compose_connection}) {
351 $need_global_cleanup = 1;
352 $schema = DBICTest::Schema->compose_connection(
356 $schema = DBICTest::Schema->compose_namespace('DBICTest');
359 if( $args{storage_type}) {
360 $schema->storage_type($args{storage_type});
363 if ( !$args{no_connect} ) {
364 $schema->connection(@dsn);
366 $schema->storage->connect_replicants(\@dsn)
367 if $ENV{DBICTEST_VIA_REPLICATED};
370 if ( !$args{no_deploy} ) {
371 __PACKAGE__->deploy_schema( $schema, $args{deploy_args} );
372 __PACKAGE__->populate_schema( $schema )
373 if( !$args{no_populate} );
376 populate_weakregistry ( $weak_registry, $schema->storage )
377 if $INC{'Test/Builder.pm'} and $schema->storage;
383 # Make sure we run after any cleanup in other END blocks
384 push @{ B::end_av()->object_2svref }, sub {
385 assert_empty_weakregistry($weak_registry, 'quiet');
391 DBICTest->deploy_schema( $schema );
393 This method does one of two things to the schema. It can either call
394 the experimental $schema->deploy() if the DBICTEST_SQLT_DEPLOY environment
395 variable is set, otherwise the default is to read in the t/lib/sqlite.sql
396 file and execute the SQL within. Either way you end up with a fresh set
397 of tables for testing.
404 my $args = shift || {};
407 if ( ($ENV{TRAVIS}||'') eq 'true' and my $old_dbg = $schema->storage->debug ) {
408 $guard = scope_guard { $schema->storage->debug($old_dbg) };
409 $schema->storage->debug(0);
412 if ($ENV{"DBICTEST_SQLT_DEPLOY"}) {
413 $schema->deploy($args);
415 my $filename = Path::Class::File->new(__FILE__)->dir
416 ->file('sqlite.sql')->stringify;
417 my $sql = do { local (@ARGV, $/) = $filename ; <> };
418 for my $chunk ( split (/;\s*\n+/, $sql) ) {
419 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
420 $schema->storage->dbh_do(sub { $_[1]->do($chunk) }) or print "Error on SQL: $chunk\n";
427 =head2 populate_schema
429 DBICTest->populate_schema( $schema );
431 After you deploy your schema you can use this method to populate
432 the tables with test data.
436 sub populate_schema {
441 if ( ($ENV{TRAVIS}||'') eq 'true' and my $old_dbg = $schema->storage->debug ) {
442 $guard = scope_guard { $schema->storage->debug($old_dbg) };
443 $schema->storage->debug(0);
446 $schema->populate('Genre', [
451 $schema->populate('Artist', [
452 [ qw/artistid name/ ],
453 [ 1, 'Caterwauler McCrae' ],
454 [ 2, 'Random Boy Band' ],
455 [ 3, 'We Are Goth' ],
458 $schema->populate('CD', [
459 [ qw/cdid artist title year genreid/ ],
460 [ 1, 1, "Spoonful of bees", 1999, 1 ],
461 [ 2, 1, "Forkful of bees", 2001 ],
462 [ 3, 1, "Caterwaulin' Blues", 1997 ],
463 [ 4, 2, "Generic Manufactured Singles", 2001 ],
464 [ 5, 3, "Come Be Depressed With Us", 1998 ],
467 $schema->populate('LinerNotes', [
468 [ qw/liner_id notes/ ],
469 [ 2, "Buy Whiskey!" ],
471 [ 5, "Kill Yourself!" ],
474 $schema->populate('Tag', [
475 [ qw/tagid cd tag/ ],
487 $schema->populate('TwoKeys', [
494 $schema->populate('FourKeys', [
495 [ qw/foo bar hello goodbye sensors/ ],
496 [ 1, 2, 3, 4, 'online' ],
497 [ 5, 4, 3, 6, 'offline' ],
500 $schema->populate('OneKey', [
501 [ qw/id artist cd/ ],
507 $schema->populate('SelfRef', [
513 $schema->populate('SelfRefAlias', [
514 [ qw/self_ref alias/ ],
518 $schema->populate('ArtistUndirectedMap', [
523 $schema->populate('Producer', [
524 [ qw/producerid name/ ],
525 [ 1, 'Matt S Trout' ],
526 [ 2, 'Bob The Builder' ],
527 [ 3, 'Fred The Phenotype' ],
530 $schema->populate('CD_to_Producer', [
537 $schema->populate('TreeLike', [
538 [ qw/id parent name/ ],
539 [ 1, undef, 'root' ],
548 $schema->populate('Track', [
549 [ qw/trackid cd position title/ ],
550 [ 4, 2, 1, "Stung with Success"],
551 [ 5, 2, 2, "Stripy"],
552 [ 6, 2, 3, "Sticky Honey"],
553 [ 7, 3, 1, "Yowlin"],
554 [ 8, 3, 2, "Howlin"],
555 [ 9, 3, 3, "Fowlin"],
556 [ 10, 4, 1, "Boring Name"],
557 [ 11, 4, 2, "Boring Song"],
558 [ 12, 4, 3, "No More Ideas"],
560 [ 14, 5, 2, "Under The Weather"],
561 [ 15, 5, 3, "Suicidal"],
562 [ 16, 1, 1, "The Bees Knees"],
563 [ 17, 1, 2, "Apiary"],
564 [ 18, 1, 3, "Beehind You"],
567 $schema->populate('Event', [
568 [ qw/id starts_at created_on varchar_date varchar_datetime skip_inflation/ ],
569 [ 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'],
572 $schema->populate('Link', [
573 [ qw/id url title/ ],
577 $schema->populate('Bookmark', [
582 $schema->populate('Collection', [
583 [ qw/collectionid name/ ],
588 $schema->populate('TypedObject', [
589 [ qw/objectid type value/ ],
590 [ 1, "pointy", "Awl" ],
591 [ 2, "round", "Bearing" ],
592 [ 3, "pointy", "Knife" ],
593 [ 4, "pointy", "Tooth" ],
594 [ 5, "round", "Head" ],
596 $schema->populate('CollectionObject', [
597 [ qw/collection object/ ],
605 $schema->populate('Owners', [
611 $schema->populate('BooksInLibrary', [
612 [ qw/id owner title source price/ ],
613 [ 1, 1, "Programming Perl", "Library", 23 ],
614 [ 2, 1, "Dynamical Systems", "Library", 37 ],
615 [ 3, 2, "Best Recipe Cookbook", "Library", 65 ],