1 package # hide from PAUSE
7 # this noop trick initializes the STDOUT, so that the TAP::Harness
8 # issued IO::Select->can_read calls (which are blocking wtf wtf wtf)
9 # keep spinning and scheduling jobs
10 # This results in an overall much smoother job-queue drainage, since
11 # the Harness blocks less
12 # (ideally this needs to be addressed in T::H, but a quick patchjob
13 # broke everything so tabling it for now)
15 if ($INC{'Test/Builder.pm'}) {
21 use Module::Runtime 'module_notional_filename';
23 for my $mod (qw( SQL::Abstract::Test SQL::Abstract )) {
24 if ( $INC{ module_notional_filename($mod) } ) {
25 # FIXME this does not seem to work in BEGIN - why?!
27 #$Carp::Internal{ (__PACKAGE__) }++;
28 #Carp::croak( __PACKAGE__ . " must be loaded before $mod" );
31 while (@frame = caller($fr++)) {
32 last if $frame[1] !~ m|^t/lib/DBICTest|;
35 die __PACKAGE__ . " must be loaded before $mod (or modules using $mod) at $frame[1] line $frame[2]\n";
41 use DBICTest::Util::LeakTracer qw/populate_weakregistry assert_empty_weakregistry/;
42 use DBICTest::Util 'local_umask';
44 use Path::Class::File ();
46 use Fcntl qw/:DEFAULT :flock/;
51 DBICTest - Library to be used by DBIx::Class test scripts
59 my $schema = DBICTest->init_schema();
63 This module provides the basic utilities to write tests against
68 The module does not export anything by default, nor provides individual
69 function exports in the conventional sense. Instead the following tags are
74 Same as C<use SQL::Abstract::Test
75 qw(L<is_same_sql_bind|SQL::Abstract::Test/is_same_sql_bind>
76 L<is_same_sql|SQL::Abstract::Test/is_same_sql>
77 L<is_same_bind|SQL::Abstract::Test/is_same_bind>)>
81 Some tests are very time sensitive and need to run on their own, without
82 being disturbed by anything else grabbing CPU or disk IO. Hence why everything
83 using C<DBICTest> grabs a shared lock, and the few tests that request a
84 C<:GlobalLock> will ask for an exclusive one and block until they can get it.
90 my $schema = DBICTest->init_schema(
93 storage_type=>'::DBI::Replicated',
95 balancer_type=>'DBIx::Class::Storage::DBI::Replicated::Balancer::Random'
99 This method removes the test SQLite database in t/var/DBIxClass.db
100 and then creates a new, empty database.
102 This method will call L<deploy_schema()|/deploy_schema> by default, unless the
103 C<no_deploy> flag is set.
105 Also, by default, this method will call L<populate_schema()|/populate_schema>
106 by default, unless the C<no_deploy> or C<no_populate> flags are set.
110 # see L</:GlobalLock>
111 our ($global_lock_fh, $global_exclusive_lock);
115 my $lockpath = DBICTest::RunMode->tmpdir->file('_dbictest_global.lock');
118 my $u = local_umask(0); # so that the file opens as 666, and any user can lock
119 sysopen ($global_lock_fh, $lockpath, O_RDWR|O_CREAT)
120 or die "Unable to open $lockpath: $!";
124 if ($exp eq ':GlobalLock') {
125 flock ($global_lock_fh, LOCK_EX) or die "Unable to lock $lockpath: $!";
126 $global_exclusive_lock = 1;
128 elsif ($exp eq ':DiffSQL') {
129 require SQL::Abstract::Test;
130 my $into = caller(0);
131 for (qw(is_same_sql_bind is_same_sql is_same_bind)) {
133 *{"${into}::$_"} = \&{"SQL::Abstract::Test::$_"};
137 croak "Unknown export $exp requested from $self";
141 unless ($global_exclusive_lock) {
142 flock ($global_lock_fh, LOCK_SH) or die "Unable to lock $lockpath: $!";
147 if ($global_lock_fh) {
148 # delay destruction even more
153 my $dir = Path::Class::File->new(__FILE__)->dir->parent->subdir('var');
154 $dir->mkpath unless -d "$dir";
157 sub _sqlite_dbfilename {
158 my $holder = $ENV{DBICTEST_LOCK_HOLDER} || $$;
159 $holder = $$ if $holder == -1;
161 # useful for missing cleanup debugging
162 #if ( $holder == $$) {
168 return "$dir/DBIxClass-$holder.db";
176 $SIG{INT} = sub { _cleanup_dbfile(); exit 1 };
178 sub _cleanup_dbfile {
179 # cleanup if this is us
181 ! $ENV{DBICTEST_LOCK_HOLDER}
183 $ENV{DBICTEST_LOCK_HOLDER} == -1
185 $ENV{DBICTEST_LOCK_HOLDER} == $$
187 my $db_file = _sqlite_dbfilename();
188 unlink $_ for ($db_file, "${db_file}-journal");
193 return $ENV{"DBICTEST_DSN"} ? 1:0;
199 return $self->_sqlite_dbfilename if (
200 defined $args{sqlite_use_file} ? $args{sqlite_use_file} : $ENV{'DBICTEST_SQLITE_USE_FILE'}
209 if ($ENV{DBICTEST_DSN}) {
211 (map { $ENV{"DBICTEST_${_}"} || '' } qw/DSN DBUSER DBPASS/),
212 { AutoCommit => 1, %args },
215 my $db_file = $self->_sqlite_dbname(%args);
217 for ($db_file, "${db_file}-journal") {
219 unlink ($_) or carp (
220 "Unable to unlink existing test database file $_ ($!), creation of fresh database / further tests may fail!"
224 return ("dbi:SQLite:${db_file}", '', '', {
227 # this is executed on every connect, and thus installs a disconnect/DESTROY
228 # guard for every new $dbh
229 on_connect_do => sub {
232 my $dbh = $storage->_get_dbh;
235 $dbh->do ('PRAGMA synchronous = OFF');
238 $ENV{DBICTEST_SQLITE_REVERSE_DEFAULT_ORDER}
240 # the pragma does not work correctly before libsqlite 3.7.9
241 $storage->_server_info->{normalized_dbms_version} >= 3.007009
243 $dbh->do ('PRAGMA reverse_unordered_selects = ON');
246 # set a *DBI* disconnect callback, to make sure the physical SQLite
247 # file is still there (i.e. the test does not attempt to delete
248 # an open database, which fails on Win32)
249 if (my $guard_cb = __mk_disconnect_guard($db_file)) {
250 $dbh->{Callbacks} = {
251 connect => sub { $guard_cb->('connect') },
252 disconnect => sub { $guard_cb->('disconnect') },
253 DESTROY => sub { $guard_cb->('DESTROY') },
261 sub __mk_disconnect_guard {
262 return if DBIx::Class::_ENV_::PEEPEENESS; # leaks handles, delaying DESTROY, can't work right
265 return unless -f $db_file;
267 my $orig_inode = (stat($db_file))[1]
270 my $clan_connect_caller = '*UNKNOWN*';
272 while ( my ($pack, $file, $line) = caller(++$i) ) {
273 next if $file eq __FILE__;
274 next if $pack =~ /^DBIx::Class|^Try::Tiny/;
275 $clan_connect_caller = "$file line $line";
282 return if $failed_once;
285 if ($event eq 'connect') {
286 # this is necessary in case we are disconnected and connected again, all within the same $dbh object
290 elsif ($event eq 'disconnect') {
293 elsif ($event eq 'DESTROY' and ! $connected ) {
299 $fail_reason = 'is missing';
302 my $cur_inode = (stat($db_file))[1];
304 if ($orig_inode != $cur_inode) {
305 my @inodes = ($orig_inode, $cur_inode);
306 # unless this is a fixed perl (P5RT#84590) pack/unpack before display
307 # to match the unsigned longs returned by `stat`
308 @inodes = map { unpack ('L', pack ('l', $_) ) } @inodes
309 unless $Config{st_ino_size};
311 $fail_reason = sprintf
312 'was recreated (initially inode %s, now %s)',
321 require Test::Builder;
322 my $t = Test::Builder->new;
323 local $Test::Builder::Level = $Test::Builder::Level + 3;
325 "$db_file originally created at $clan_connect_caller $fail_reason before $event "
326 . 'of DBI handle - a strong indicator that the database file was tampered with while '
327 . 'still being open. This action would fail massively if running under Win32, hence '
328 . 'we make sure it fails on any OS :)'
332 return; # this empty return is a DBI requirement
336 my $weak_registry = {};
344 if ($args{compose_connection}) {
345 $schema = DBICTest::Schema->compose_connection(
346 'DBICTest', $self->_database(%args)
349 $schema = DBICTest::Schema->compose_namespace('DBICTest');
352 if( $args{storage_type}) {
353 $schema->storage_type($args{storage_type});
356 if ( !$args{no_connect} ) {
357 $schema = $schema->connect($self->_database(%args));
360 if ( !$args{no_deploy} ) {
361 __PACKAGE__->deploy_schema( $schema, $args{deploy_args} );
362 __PACKAGE__->populate_schema( $schema )
363 if( !$args{no_populate} );
366 populate_weakregistry ( $weak_registry, $schema->storage )
367 if $INC{'Test/Builder.pm'} and $schema->storage;
373 assert_empty_weakregistry($weak_registry, 'quiet');
378 DBICTest->deploy_schema( $schema );
380 This method does one of two things to the schema. It can either call
381 the experimental $schema->deploy() if the DBICTEST_SQLT_DEPLOY environment
382 variable is set, otherwise the default is to read in the t/lib/sqlite.sql
383 file and execute the SQL within. Either way you end up with a fresh set
384 of tables for testing.
391 my $args = shift || {};
393 local $schema->storage->{debug}
394 if ($ENV{TRAVIS}||'') eq 'true';
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 {
424 local $schema->storage->{debug}
425 if ($ENV{TRAVIS}||'') eq 'true';
427 $schema->populate('Genre', [
432 $schema->populate('Artist', [
433 [ qw/artistid name/ ],
434 [ 1, 'Caterwauler McCrae' ],
435 [ 2, 'Random Boy Band' ],
436 [ 3, 'We Are Goth' ],
439 $schema->populate('CD', [
440 [ qw/cdid artist title year genreid/ ],
441 [ 1, 1, "Spoonful of bees", 1999, 1 ],
442 [ 2, 1, "Forkful of bees", 2001 ],
443 [ 3, 1, "Caterwaulin' Blues", 1997 ],
444 [ 4, 2, "Generic Manufactured Singles", 2001 ],
445 [ 5, 3, "Come Be Depressed With Us", 1998 ],
448 $schema->populate('LinerNotes', [
449 [ qw/liner_id notes/ ],
450 [ 2, "Buy Whiskey!" ],
452 [ 5, "Kill Yourself!" ],
455 $schema->populate('Tag', [
456 [ qw/tagid cd tag/ ],
468 $schema->populate('TwoKeys', [
475 $schema->populate('FourKeys', [
476 [ qw/foo bar hello goodbye sensors/ ],
477 [ 1, 2, 3, 4, 'online' ],
478 [ 5, 4, 3, 6, 'offline' ],
481 $schema->populate('OneKey', [
482 [ qw/id artist cd/ ],
488 $schema->populate('SelfRef', [
494 $schema->populate('SelfRefAlias', [
495 [ qw/self_ref alias/ ],
499 $schema->populate('ArtistUndirectedMap', [
504 $schema->populate('Producer', [
505 [ qw/producerid name/ ],
506 [ 1, 'Matt S Trout' ],
507 [ 2, 'Bob The Builder' ],
508 [ 3, 'Fred The Phenotype' ],
511 $schema->populate('CD_to_Producer', [
518 $schema->populate('TreeLike', [
519 [ qw/id parent name/ ],
520 [ 1, undef, 'root' ],
529 $schema->populate('Track', [
530 [ qw/trackid cd position title/ ],
531 [ 4, 2, 1, "Stung with Success"],
532 [ 5, 2, 2, "Stripy"],
533 [ 6, 2, 3, "Sticky Honey"],
534 [ 7, 3, 1, "Yowlin"],
535 [ 8, 3, 2, "Howlin"],
536 [ 9, 3, 3, "Fowlin"],
537 [ 10, 4, 1, "Boring Name"],
538 [ 11, 4, 2, "Boring Song"],
539 [ 12, 4, 3, "No More Ideas"],
541 [ 14, 5, 2, "Under The Weather"],
542 [ 15, 5, 3, "Suicidal"],
543 [ 16, 1, 1, "The Bees Knees"],
544 [ 17, 1, 2, "Apiary"],
545 [ 18, 1, 3, "Beehind You"],
548 $schema->populate('Event', [
549 [ qw/id starts_at created_on varchar_date varchar_datetime skip_inflation/ ],
550 [ 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'],
553 $schema->populate('Link', [
554 [ qw/id url title/ ],
558 $schema->populate('Bookmark', [
563 $schema->populate('Collection', [
564 [ qw/collectionid name/ ],
569 $schema->populate('TypedObject', [
570 [ qw/objectid type value/ ],
571 [ 1, "pointy", "Awl" ],
572 [ 2, "round", "Bearing" ],
573 [ 3, "pointy", "Knife" ],
574 [ 4, "pointy", "Tooth" ],
575 [ 5, "round", "Head" ],
577 $schema->populate('CollectionObject', [
578 [ qw/collection object/ ],
586 $schema->populate('Owners', [
592 $schema->populate('BooksInLibrary', [
593 [ qw/id owner title source price/ ],
594 [ 1, 1, "Programming Perl", "Library", 23 ],
595 [ 2, 1, "Dynamical Systems", "Library", 37 ],
596 [ 3, 2, "Best Recipe Cookbook", "Library", 65 ],