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/;
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 flock ($global_lock_fh, LOCK_EX) or die "Unable to lock $lockpath: $!";
94 $global_exclusive_lock = 1;
96 elsif ($exp eq ':DiffSQL') {
97 require SQL::Abstract::Test;
99 for (qw(is_same_sql_bind is_same_sql is_same_bind)) {
101 *{"${into}::$_"} = \&{"SQL::Abstract::Test::$_"};
105 croak "Unknown export $exp requested from $self";
109 unless ($global_exclusive_lock) {
110 flock ($global_lock_fh, LOCK_SH) or die "Unable to lock $lockpath: $!";
115 if ($global_lock_fh) {
116 # delay destruction even more
121 my $dir = Path::Class::File->new(__FILE__)->dir->parent->subdir('var');
122 $dir->mkpath unless -d "$dir";
125 sub _sqlite_dbfilename {
126 my $holder = $ENV{DBICTEST_LOCK_HOLDER} || $$;
127 $holder = $$ if $holder == -1;
129 # useful for missing cleanup debugging
130 #if ( $holder == $$) {
136 return "$dir/DBIxClass-$holder.db";
144 $SIG{INT} = sub { _cleanup_dbfile(); exit 1 };
146 my $need_global_cleanup;
147 sub _cleanup_dbfile {
148 # cleanup if this is us
150 ! $ENV{DBICTEST_LOCK_HOLDER}
152 $ENV{DBICTEST_LOCK_HOLDER} == -1
154 $ENV{DBICTEST_LOCK_HOLDER} == $$
156 if ($need_global_cleanup and my $dbh = DBICTest->schema->storage->_dbh) {
160 my $db_file = _sqlite_dbfilename();
161 unlink $_ for ($db_file, "${db_file}-journal");
166 return $ENV{"DBICTEST_DSN"} ? 1:0;
172 return $self->_sqlite_dbfilename if (
173 defined $args{sqlite_use_file} ? $args{sqlite_use_file} : $ENV{'DBICTEST_SQLITE_USE_FILE'}
182 if ($ENV{DBICTEST_DSN}) {
184 (map { $ENV{"DBICTEST_${_}"} || '' } qw/DSN DBUSER DBPASS/),
185 { AutoCommit => 1, %args },
188 my $db_file = $self->_sqlite_dbname(%args);
190 for ($db_file, "${db_file}-journal") {
192 unlink ($_) or carp (
193 "Unable to unlink existing test database file $_ ($!), creation of fresh database / further tests may fail!"
197 return ("dbi:SQLite:${db_file}", '', '', {
200 # this is executed on every connect, and thus installs a disconnect/DESTROY
201 # guard for every new $dbh
202 on_connect_do => sub {
205 my $dbh = $storage->_get_dbh;
208 $dbh->do ('PRAGMA synchronous = OFF');
211 $ENV{DBICTEST_SQLITE_REVERSE_DEFAULT_ORDER}
213 # the pragma does not work correctly before libsqlite 3.7.9
214 $storage->_server_info->{normalized_dbms_version} >= 3.007009
216 $dbh->do ('PRAGMA reverse_unordered_selects = ON');
219 # set a *DBI* disconnect callback, to make sure the physical SQLite
220 # file is still there (i.e. the test does not attempt to delete
221 # an open database, which fails on Win32)
222 if (! $storage->{master} and my $guard_cb = __mk_disconnect_guard($db_file)) {
223 $dbh->{Callbacks} = {
224 connect => sub { $guard_cb->('connect') },
225 disconnect => sub { $guard_cb->('disconnect') },
226 DESTROY => sub { &detected_reinvoked_destructor; $guard_cb->('DESTROY') },
234 sub __mk_disconnect_guard {
239 # this perl leaks handles, delaying DESTROY, can't work right
240 DBIx::Class::_ENV_::PEEPEENESS
246 my $orig_inode = (stat($db_file))[1]
249 my $clan_connect_caller = '*UNKNOWN*';
251 while ( my ($pack, $file, $line) = caller(++$i) ) {
252 next if $file eq __FILE__;
253 next if $pack =~ /^DBIx::Class|^Try::Tiny/;
254 $clan_connect_caller = "$file line $line";
261 return if $failed_once;
264 if ($event eq 'connect') {
265 # this is necessary in case we are disconnected and connected again, all within the same $dbh object
269 elsif ($event eq 'disconnect') {
272 elsif ($event eq 'DESTROY' and ! $connected ) {
278 $fail_reason = 'is missing';
281 my $cur_inode = (stat($db_file))[1];
283 if ($orig_inode != $cur_inode) {
284 my @inodes = ($orig_inode, $cur_inode);
285 # unless this is a fixed perl (P5RT#84590) pack/unpack before display
286 # to match the unsigned longs returned by `stat`
287 @inodes = map { unpack ('L', pack ('l', $_) ) } @inodes
288 unless $Config{st_ino_size};
290 $fail_reason = sprintf
291 'was recreated (initially inode %s, now %s)',
300 require Test::Builder;
301 my $t = Test::Builder->new;
302 local $Test::Builder::Level = $Test::Builder::Level + 3;
304 "$db_file originally created at $clan_connect_caller $fail_reason before $event "
305 . 'of DBI handle - a strong indicator that the database file was tampered with while '
306 . 'still being open. This action would fail massively if running under Win32, hence '
307 . 'we make sure it fails on any OS :)'
311 return; # this empty return is a DBI requirement
315 my $weak_registry = {};
324 $ENV{DBICTEST_VIA_REPLICATED} &&=
325 ( !$args{storage_type} && !defined $args{sqlite_use_file} )
327 $args{storage_type} = ['::DBI::Replicated', { balancer_type => '::Random' }];
328 $args{sqlite_use_file} = 1;
331 my @dsn = $self->_database(%args);
333 if ($args{compose_connection}) {
334 $need_global_cleanup = 1;
335 $schema = DBICTest::Schema->compose_connection(
339 $schema = DBICTest::Schema->compose_namespace('DBICTest');
342 if( $args{storage_type}) {
343 $schema->storage_type($args{storage_type});
346 if ( !$args{no_connect} ) {
347 $schema->connection(@dsn);
349 $schema->storage->connect_replicants(\@dsn)
350 if $ENV{DBICTEST_VIA_REPLICATED};
353 if ( !$args{no_deploy} ) {
354 __PACKAGE__->deploy_schema( $schema, $args{deploy_args} );
355 __PACKAGE__->populate_schema( $schema )
356 if( !$args{no_populate} );
359 populate_weakregistry ( $weak_registry, $schema->storage )
360 if $INC{'Test/Builder.pm'} and $schema->storage;
366 # Make sure we run after any cleanup in other END blocks
367 push @{ B::end_av()->object_2svref }, sub {
368 assert_empty_weakregistry($weak_registry, 'quiet');
374 DBICTest->deploy_schema( $schema );
376 This method does one of two things to the schema. It can either call
377 the experimental $schema->deploy() if the DBICTEST_SQLT_DEPLOY environment
378 variable is set, otherwise the default is to read in the t/lib/sqlite.sql
379 file and execute the SQL within. Either way you end up with a fresh set
380 of tables for testing.
387 my $args = shift || {};
389 local $schema->storage->{debug}
390 if ($ENV{TRAVIS}||'') eq 'true';
392 if ($ENV{"DBICTEST_SQLT_DEPLOY"}) {
393 $schema->deploy($args);
395 my $filename = Path::Class::File->new(__FILE__)->dir
396 ->file('sqlite.sql')->stringify;
397 my $sql = do { local (@ARGV, $/) = $filename ; <> };
398 for my $chunk ( split (/;\s*\n+/, $sql) ) {
399 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
400 $schema->storage->dbh_do(sub { $_[1]->do($chunk) }) or print "Error on SQL: $chunk\n";
407 =head2 populate_schema
409 DBICTest->populate_schema( $schema );
411 After you deploy your schema you can use this method to populate
412 the tables with test data.
416 sub populate_schema {
420 local $schema->storage->{debug}
421 if ($ENV{TRAVIS}||'') eq 'true';
423 $schema->populate('Genre', [
428 $schema->populate('Artist', [
429 [ qw/artistid name/ ],
430 [ 1, 'Caterwauler McCrae' ],
431 [ 2, 'Random Boy Band' ],
432 [ 3, 'We Are Goth' ],
435 $schema->populate('CD', [
436 [ qw/cdid artist title year genreid/ ],
437 [ 1, 1, "Spoonful of bees", 1999, 1 ],
438 [ 2, 1, "Forkful of bees", 2001 ],
439 [ 3, 1, "Caterwaulin' Blues", 1997 ],
440 [ 4, 2, "Generic Manufactured Singles", 2001 ],
441 [ 5, 3, "Come Be Depressed With Us", 1998 ],
444 $schema->populate('LinerNotes', [
445 [ qw/liner_id notes/ ],
446 [ 2, "Buy Whiskey!" ],
448 [ 5, "Kill Yourself!" ],
451 $schema->populate('Tag', [
452 [ qw/tagid cd tag/ ],
464 $schema->populate('TwoKeys', [
471 $schema->populate('FourKeys', [
472 [ qw/foo bar hello goodbye sensors/ ],
473 [ 1, 2, 3, 4, 'online' ],
474 [ 5, 4, 3, 6, 'offline' ],
477 $schema->populate('OneKey', [
478 [ qw/id artist cd/ ],
484 $schema->populate('SelfRef', [
490 $schema->populate('SelfRefAlias', [
491 [ qw/self_ref alias/ ],
495 $schema->populate('ArtistUndirectedMap', [
500 $schema->populate('Producer', [
501 [ qw/producerid name/ ],
502 [ 1, 'Matt S Trout' ],
503 [ 2, 'Bob The Builder' ],
504 [ 3, 'Fred The Phenotype' ],
507 $schema->populate('CD_to_Producer', [
514 $schema->populate('TreeLike', [
515 [ qw/id parent name/ ],
516 [ 1, undef, 'root' ],
525 $schema->populate('Track', [
526 [ qw/trackid cd position title/ ],
527 [ 4, 2, 1, "Stung with Success"],
528 [ 5, 2, 2, "Stripy"],
529 [ 6, 2, 3, "Sticky Honey"],
530 [ 7, 3, 1, "Yowlin"],
531 [ 8, 3, 2, "Howlin"],
532 [ 9, 3, 3, "Fowlin"],
533 [ 10, 4, 1, "Boring Name"],
534 [ 11, 4, 2, "Boring Song"],
535 [ 12, 4, 3, "No More Ideas"],
537 [ 14, 5, 2, "Under The Weather"],
538 [ 15, 5, 3, "Suicidal"],
539 [ 16, 1, 1, "The Bees Knees"],
540 [ 17, 1, 2, "Apiary"],
541 [ 18, 1, 3, "Beehind You"],
544 $schema->populate('Event', [
545 [ qw/id starts_at created_on varchar_date varchar_datetime skip_inflation/ ],
546 [ 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'],
549 $schema->populate('Link', [
550 [ qw/id url title/ ],
554 $schema->populate('Bookmark', [
559 $schema->populate('Collection', [
560 [ qw/collectionid name/ ],
565 $schema->populate('TypedObject', [
566 [ qw/objectid type value/ ],
567 [ 1, "pointy", "Awl" ],
568 [ 2, "round", "Bearing" ],
569 [ 3, "pointy", "Knife" ],
570 [ 4, "pointy", "Tooth" ],
571 [ 5, "round", "Head" ],
573 $schema->populate('CollectionObject', [
574 [ qw/collection object/ ],
582 $schema->populate('Owners', [
588 $schema->populate('BooksInLibrary', [
589 [ qw/id owner title source price/ ],
590 [ 1, 1, "Programming Perl", "Library", 23 ],
591 [ 2, 1, "Dynamical Systems", "Library", 37 ],
592 [ 3, 2, "Best Recipe Cookbook", "Library", 65 ],