1 package # hide from PAUSE
7 use DBICTest::Util 'local_umask';
9 use DBICTest::Util::LeakTracer qw/populate_weakregistry assert_empty_weakregistry/;
10 use DBIx::Class::_Util 'detected_reinvoked_destructor';
12 use Path::Class::File ();
14 use Fcntl qw/:DEFAULT :flock/;
20 DBICTest - Library to be used by DBIx::Class test scripts
28 my $schema = DBICTest->init_schema();
32 This module provides the basic utilities to write tests against
37 The module does not export anything by default, nor provides individual
38 function exports in the conventional sense. Instead the following tags are
43 Same as C<use SQL::Abstract::Test
44 qw(L<is_same_sql_bind|SQL::Abstract::Test/is_same_sql_bind>
45 L<is_same_sql|SQL::Abstract::Test/is_same_sql>
46 L<is_same_bind|SQL::Abstract::Test/is_same_bind>)>
50 Some tests are very time sensitive and need to run on their own, without
51 being disturbed by anything else grabbing CPU or disk IO. Hence why everything
52 using C<DBICTest> grabs a shared lock, and the few tests that request a
53 C<:GlobalLock> will ask for an exclusive one and block until they can get it.
59 my $schema = DBICTest->init_schema(
62 storage_type=>'::DBI::Replicated',
64 balancer_type=>'DBIx::Class::Storage::DBI::Replicated::Balancer::Random'
68 This method removes the test SQLite database in t/var/DBIxClass.db
69 and then creates a new, empty database.
71 This method will call L<deploy_schema()|/deploy_schema> by default, unless the
72 C<no_deploy> flag is set.
74 Also, by default, this method will call L<populate_schema()|/populate_schema>
75 by default, unless the C<no_deploy> or C<no_populate> flags are set.
80 our ($global_lock_fh, $global_exclusive_lock);
84 my $lockpath = DBICTest::RunMode->tmpdir->file('_dbictest_global.lock');
87 my $u = local_umask(0); # so that the file opens as 666, and any user can lock
88 sysopen ($global_lock_fh, $lockpath, O_RDWR|O_CREAT)
89 or die "Unable to open $lockpath: $!";
93 if ($exp eq ':GlobalLock') {
94 flock ($global_lock_fh, LOCK_EX) or die "Unable to lock $lockpath: $!";
95 $global_exclusive_lock = 1;
97 elsif ($exp eq ':DiffSQL') {
98 require SQL::Abstract::Test;
100 for (qw(is_same_sql_bind is_same_sql is_same_bind)) {
102 *{"${into}::$_"} = \&{"SQL::Abstract::Test::$_"};
106 croak "Unknown export $exp requested from $self";
110 unless ($global_exclusive_lock) {
111 flock ($global_lock_fh, LOCK_SH) or die "Unable to lock $lockpath: $!";
116 if ($global_lock_fh) {
117 # delay destruction even more
122 my $dir = Path::Class::File->new(__FILE__)->dir->parent->subdir('var');
123 $dir->mkpath unless -d "$dir";
126 sub _sqlite_dbfilename {
127 my $holder = $ENV{DBICTEST_LOCK_HOLDER} || $$;
128 $holder = $$ if $holder == -1;
130 # useful for missing cleanup debugging
131 #if ( $holder == $$) {
137 return "$dir/DBIxClass-$holder.db";
145 $SIG{INT} = sub { _cleanup_dbfile(); exit 1 };
147 my $need_global_cleanup;
148 sub _cleanup_dbfile {
149 # cleanup if this is us
151 ! $ENV{DBICTEST_LOCK_HOLDER}
153 $ENV{DBICTEST_LOCK_HOLDER} == -1
155 $ENV{DBICTEST_LOCK_HOLDER} == $$
157 if ($need_global_cleanup and my $dbh = DBICTest->schema->storage->_dbh) {
161 my $db_file = _sqlite_dbfilename();
162 unlink $_ for ($db_file, "${db_file}-journal");
167 return $ENV{"DBICTEST_DSN"} ? 1:0;
173 return $self->_sqlite_dbfilename if (
174 defined $args{sqlite_use_file} ? $args{sqlite_use_file} : $ENV{'DBICTEST_SQLITE_USE_FILE'}
183 if ($ENV{DBICTEST_DSN}) {
185 (map { $ENV{"DBICTEST_${_}"} || '' } qw/DSN DBUSER DBPASS/),
186 { AutoCommit => 1, %args },
189 my $db_file = $self->_sqlite_dbname(%args);
191 for ($db_file, "${db_file}-journal") {
193 unlink ($_) or carp (
194 "Unable to unlink existing test database file $_ ($!), creation of fresh database / further tests may fail!"
198 return ("dbi:SQLite:${db_file}", '', '', {
201 # this is executed on every connect, and thus installs a disconnect/DESTROY
202 # guard for every new $dbh
203 on_connect_do => sub {
206 my $dbh = $storage->_get_dbh;
209 $dbh->do ('PRAGMA synchronous = OFF');
212 $ENV{DBICTEST_SQLITE_REVERSE_DEFAULT_ORDER}
214 # the pragma does not work correctly before libsqlite 3.7.9
215 $storage->_server_info->{normalized_dbms_version} >= 3.007009
217 $dbh->do ('PRAGMA reverse_unordered_selects = ON');
220 # set a *DBI* disconnect callback, to make sure the physical SQLite
221 # file is still there (i.e. the test does not attempt to delete
222 # an open database, which fails on Win32)
223 if (! $storage->{master} and my $guard_cb = __mk_disconnect_guard($db_file)) {
224 $dbh->{Callbacks} = {
225 connect => sub { $guard_cb->('connect') },
226 disconnect => sub { $guard_cb->('disconnect') },
227 DESTROY => sub { &detected_reinvoked_destructor; $guard_cb->('DESTROY') },
235 sub __mk_disconnect_guard {
240 # this perl leaks handles, delaying DESTROY, can't work right
241 DBIx::Class::_ENV_::PEEPEENESS
247 my $orig_inode = (stat($db_file))[1]
250 my $clan_connect_caller = '*UNKNOWN*';
252 while ( my ($pack, $file, $line) = caller(++$i) ) {
253 next if $file eq __FILE__;
254 next if $pack =~ /^DBIx::Class|^Try::Tiny/;
255 $clan_connect_caller = "$file line $line";
262 return if $failed_once;
265 if ($event eq 'connect') {
266 # this is necessary in case we are disconnected and connected again, all within the same $dbh object
270 elsif ($event eq 'disconnect') {
273 elsif ($event eq 'DESTROY' and ! $connected ) {
279 $fail_reason = 'is missing';
282 my $cur_inode = (stat($db_file))[1];
284 if ($orig_inode != $cur_inode) {
285 my @inodes = ($orig_inode, $cur_inode);
286 # unless this is a fixed perl (P5RT#84590) pack/unpack before display
287 # to match the unsigned longs returned by `stat`
288 @inodes = map { unpack ('L', pack ('l', $_) ) } @inodes
289 unless $Config{st_ino_size};
291 $fail_reason = sprintf
292 'was recreated (initially inode %s, now %s)',
301 require Test::Builder;
302 my $t = Test::Builder->new;
303 local $Test::Builder::Level = $Test::Builder::Level + 3;
305 "$db_file originally created at $clan_connect_caller $fail_reason before $event "
306 . 'of DBI handle - a strong indicator that the database file was tampered with while '
307 . 'still being open. This action would fail massively if running under Win32, hence '
308 . 'we make sure it fails on any OS :)'
312 return; # this empty return is a DBI requirement
316 my $weak_registry = {};
325 $ENV{DBICTEST_VIA_REPLICATED} &&=
326 ( !$args{storage_type} && !defined $args{sqlite_use_file} )
328 $args{storage_type} = ['::DBI::Replicated', { balancer_type => '::Random' }];
329 $args{sqlite_use_file} = 1;
332 my @dsn = $self->_database(%args);
334 if ($args{compose_connection}) {
335 $need_global_cleanup = 1;
336 $schema = DBICTest::Schema->compose_connection(
340 $schema = DBICTest::Schema->compose_namespace('DBICTest');
343 if( $args{storage_type}) {
344 $schema->storage_type($args{storage_type});
347 if ( !$args{no_connect} ) {
348 $schema->connection(@dsn);
350 $schema->storage->connect_replicants(\@dsn)
351 if $ENV{DBICTEST_VIA_REPLICATED};
354 if ( !$args{no_deploy} ) {
355 __PACKAGE__->deploy_schema( $schema, $args{deploy_args} );
356 __PACKAGE__->populate_schema( $schema )
357 if( !$args{no_populate} );
360 populate_weakregistry ( $weak_registry, $schema->storage )
361 if $INC{'Test/Builder.pm'} and $schema->storage;
367 # Make sure we run after any cleanup in other END blocks
368 push @{ B::end_av()->object_2svref }, sub {
369 assert_empty_weakregistry($weak_registry, 'quiet');
375 DBICTest->deploy_schema( $schema );
377 This method does one of two things to the schema. It can either call
378 the experimental $schema->deploy() if the DBICTEST_SQLT_DEPLOY environment
379 variable is set, otherwise the default is to read in the t/lib/sqlite.sql
380 file and execute the SQL within. Either way you end up with a fresh set
381 of tables for testing.
388 my $args = shift || {};
391 if ( ($ENV{TRAVIS}||'') eq 'true' and my $old_dbg = $schema->storage->debug ) {
392 $guard = Scope::Guard->new(sub { $schema->storage->debug($old_dbg) });
393 $schema->storage->debug(0);
396 if ($ENV{"DBICTEST_SQLT_DEPLOY"}) {
397 $schema->deploy($args);
399 my $filename = Path::Class::File->new(__FILE__)->dir
400 ->file('sqlite.sql')->stringify;
401 my $sql = do { local (@ARGV, $/) = $filename ; <> };
402 for my $chunk ( split (/;\s*\n+/, $sql) ) {
403 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
404 $schema->storage->dbh_do(sub { $_[1]->do($chunk) }) or print "Error on SQL: $chunk\n";
411 =head2 populate_schema
413 DBICTest->populate_schema( $schema );
415 After you deploy your schema you can use this method to populate
416 the tables with test data.
420 sub populate_schema {
425 if ( ($ENV{TRAVIS}||'') eq 'true' and my $old_dbg = $schema->storage->debug ) {
426 $guard = Scope::Guard->new(sub { $schema->storage->debug($old_dbg) });
427 $schema->storage->debug(0);
430 $schema->populate('Genre', [
435 $schema->populate('Artist', [
436 [ qw/artistid name/ ],
437 [ 1, 'Caterwauler McCrae' ],
438 [ 2, 'Random Boy Band' ],
439 [ 3, 'We Are Goth' ],
442 $schema->populate('CD', [
443 [ qw/cdid artist title year genreid/ ],
444 [ 1, 1, "Spoonful of bees", 1999, 1 ],
445 [ 2, 1, "Forkful of bees", 2001 ],
446 [ 3, 1, "Caterwaulin' Blues", 1997 ],
447 [ 4, 2, "Generic Manufactured Singles", 2001 ],
448 [ 5, 3, "Come Be Depressed With Us", 1998 ],
451 $schema->populate('LinerNotes', [
452 [ qw/liner_id notes/ ],
453 [ 2, "Buy Whiskey!" ],
455 [ 5, "Kill Yourself!" ],
458 $schema->populate('Tag', [
459 [ qw/tagid cd tag/ ],
471 $schema->populate('TwoKeys', [
478 $schema->populate('FourKeys', [
479 [ qw/foo bar hello goodbye sensors/ ],
480 [ 1, 2, 3, 4, 'online' ],
481 [ 5, 4, 3, 6, 'offline' ],
484 $schema->populate('OneKey', [
485 [ qw/id artist cd/ ],
491 $schema->populate('SelfRef', [
497 $schema->populate('SelfRefAlias', [
498 [ qw/self_ref alias/ ],
502 $schema->populate('ArtistUndirectedMap', [
507 $schema->populate('Producer', [
508 [ qw/producerid name/ ],
509 [ 1, 'Matt S Trout' ],
510 [ 2, 'Bob The Builder' ],
511 [ 3, 'Fred The Phenotype' ],
514 $schema->populate('CD_to_Producer', [
521 $schema->populate('TreeLike', [
522 [ qw/id parent name/ ],
523 [ 1, undef, 'root' ],
532 $schema->populate('Track', [
533 [ qw/trackid cd position title/ ],
534 [ 4, 2, 1, "Stung with Success"],
535 [ 5, 2, 2, "Stripy"],
536 [ 6, 2, 3, "Sticky Honey"],
537 [ 7, 3, 1, "Yowlin"],
538 [ 8, 3, 2, "Howlin"],
539 [ 9, 3, 3, "Fowlin"],
540 [ 10, 4, 1, "Boring Name"],
541 [ 11, 4, 2, "Boring Song"],
542 [ 12, 4, 3, "No More Ideas"],
544 [ 14, 5, 2, "Under The Weather"],
545 [ 15, 5, 3, "Suicidal"],
546 [ 16, 1, 1, "The Bees Knees"],
547 [ 17, 1, 2, "Apiary"],
548 [ 18, 1, 3, "Beehind You"],
551 $schema->populate('Event', [
552 [ qw/id starts_at created_on varchar_date varchar_datetime skip_inflation/ ],
553 [ 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'],
556 $schema->populate('Link', [
557 [ qw/id url title/ ],
561 $schema->populate('Bookmark', [
566 $schema->populate('Collection', [
567 [ qw/collectionid name/ ],
572 $schema->populate('TypedObject', [
573 [ qw/objectid type value/ ],
574 [ 1, "pointy", "Awl" ],
575 [ 2, "round", "Bearing" ],
576 [ 3, "pointy", "Knife" ],
577 [ 4, "pointy", "Tooth" ],
578 [ 5, "round", "Head" ],
580 $schema->populate('CollectionObject', [
581 [ qw/collection object/ ],
589 $schema->populate('Owners', [
595 $schema->populate('BooksInLibrary', [
596 [ qw/id owner title source price/ ],
597 [ 1, 1, "Programming Perl", "Library", 23 ],
598 [ 2, 1, "Dynamical Systems", "Library", 37 ],
599 [ 3, 2, "Best Recipe Cookbook", "Library", 65 ],