X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=t%2Flib%2FDBICTest.pm;h=cfc18df9798ab02c2b5d78a87809e737ed96144e;hb=e570488ade8f327f47dd3318db3443a348d561d6;hp=229859dd70005220c1bddad5fb83533278da3529;hpb=1864ab54ac1abe5f520678b1a6f9b4cc24004d86;p=dbsrgits%2FDBIx-Class.git diff --git a/t/lib/DBICTest.pm b/t/lib/DBICTest.pm index 229859d..cfc18df 100644 --- a/t/lib/DBICTest.pm +++ b/t/lib/DBICTest.pm @@ -1,19 +1,56 @@ package # hide from PAUSE DBICTest; +# load early so that `perl -It/lib -MDBICTest` keeps working +use ANFANG; + use strict; use warnings; -use DBICTest::Util 'local_umask'; -use DBICTest::Schema; + +# this noop trick initializes the STDOUT, so that the TAP::Harness +# issued IO::Select->can_read calls (which are blocking wtf wtf wtf) +# keep spinning and scheduling jobs +# This results in an overall much smoother job-queue drainage, since +# the Harness blocks less +# (ideally this needs to be addressed in T::H, but a quick patchjob +# broke everything so tabling it for now) +BEGIN { + # FIXME - there probably is some way to determine a harness run (T::H or + # prove) but I do not know it offhand, especially on older environments + # Go with the safer option + if ($INC{'Test/Builder.pm'}) { + select( ( select(\*STDOUT), $|=1 )[0] ); + print STDOUT "#\n"; + } +} + + +use DBICTest::Util qw( + local_umask slurp_bytes tmpdir await_flock + dbg DEBUG_TEST_CONCURRENCY_LOCKS PEEPEENESS +); use DBICTest::Util::LeakTracer qw/populate_weakregistry assert_empty_weakregistry/; -use DBIx::Class::_Util 'detected_reinvoked_destructor'; + +# The actual ASSERT logic is in BaseSchema for pesky load-order reasons +# Hence run this through once, *before* DBICTest::Schema and friends load +BEGIN { + if ( + DBIx::Class::_ENV_::ASSERT_NO_ERRONEOUS_METAINSTANCE_USE + or + DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS + ) { + require DBIx::Class::Row; + require DBICTest::BaseSchema; + DBICTest::BaseSchema->connect( sub {} ); + } +} + +use DBICTest::Schema; +use DBIx::Class::_Util qw( detected_reinvoked_destructor scope_guard modver_gt_or_eq ); use Carp; -use Path::Class::File (); -use File::Spec; use Fcntl qw/:DEFAULT :flock/; use Config; -use Scope::Guard (); =head1 NAME @@ -21,9 +58,12 @@ DBICTest - Library to be used by DBIx::Class test scripts =head1 SYNOPSIS - use lib qw(t/lib); - use DBICTest; + BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + + use warnings; + use strict; use Test::More; + use DBICTest; my $schema = DBICTest->init_schema(); @@ -81,7 +121,7 @@ our ($global_lock_fh, $global_exclusive_lock); sub import { my $self = shift; - my $lockpath = DBICTest::RunMode->tmpdir->file('_dbictest_global.lock'); + my $lockpath = tmpdir . '_dbictest_global.lock'; { my $u = local_umask(0); # so that the file opens as 666, and any user can lock @@ -91,7 +131,14 @@ sub import { for my $exp (@_) { if ($exp eq ':GlobalLock') { - flock ($global_lock_fh, LOCK_EX) or die "Unable to lock $lockpath: $!"; + DEBUG_TEST_CONCURRENCY_LOCKS > 1 + and dbg "Waiting for EXCLUSIVE global lock..."; + + await_flock ($global_lock_fh, LOCK_EX) or die "Unable to lock $lockpath: $!"; + + DEBUG_TEST_CONCURRENCY_LOCKS > 1 + and dbg "Got EXCLUSIVE global lock"; + $global_exclusive_lock = 1; } elsif ($exp eq ':DiffSQL') { @@ -108,38 +155,32 @@ sub import { } unless ($global_exclusive_lock) { - flock ($global_lock_fh, LOCK_SH) or die "Unable to lock $lockpath: $!"; - } -} + DEBUG_TEST_CONCURRENCY_LOCKS > 1 + and dbg "Waiting for SHARED global lock..."; -END { - if ($global_lock_fh) { - # delay destruction even more + await_flock ($global_lock_fh, LOCK_SH) or die "Unable to lock $lockpath: $!"; + + DEBUG_TEST_CONCURRENCY_LOCKS > 1 + and dbg "Got SHARED global lock"; } } -{ - my $dir = Path::Class::File->new(__FILE__)->dir->parent->subdir('var'); - $dir->mkpath unless -d "$dir"; - $dir = "$dir"; - - sub _sqlite_dbfilename { - my $holder = $ENV{DBICTEST_LOCK_HOLDER} || $$; - $holder = $$ if $holder == -1; +END { + # referencing here delays destruction even more + if ($global_lock_fh) { + DEBUG_TEST_CONCURRENCY_LOCKS > 1 + and dbg "Release @{[ $global_exclusive_lock ? 'EXCLUSIVE' : 'SHARED' ]} global lock (END)"; + 1; + } - # useful for missing cleanup debugging - #if ( $holder == $$) { - # my $x = $0; - # $x =~ s/\//#/g; - # $holder .= "-$x"; - #} + _cleanup_dbfile(); +} - return "$dir/DBIxClass-$holder.db"; - } +sub _sqlite_dbfilename { + my $holder = $ENV{DBICTEST_LOCK_HOLDER} || $$; + $holder = $$ if $holder == -1; - END { - _cleanup_dbfile(); - } + return "t/var/DBIxClass-$holder.db"; } $SIG{INT} = sub { _cleanup_dbfile(); exit 1 }; @@ -238,7 +279,7 @@ sub __mk_disconnect_guard { return if ( # this perl leaks handles, delaying DESTROY, can't work right - DBIx::Class::_ENV_::PEEPEENESS + PEEPEENESS or ! -f $db_file ); @@ -249,7 +290,7 @@ sub __mk_disconnect_guard { my $clan_connect_caller = '*UNKNOWN*'; my $i; - while ( my ($pack, $file, $line) = caller(++$i) ) { + while ( my ($pack, $file, $line) = CORE::caller(++$i) ) { next if $file eq __FILE__; next if $pack =~ /^DBIx::Class|^Try::Tiny/; $clan_connect_caller = "$file line $line"; @@ -268,6 +309,7 @@ sub __mk_disconnect_guard { return; } elsif ($event eq 'disconnect') { + return unless $connected; # we already disconnected earlier $connected = 0; } elsif ($event eq 'DESTROY' and ! $connected ) { @@ -322,8 +364,11 @@ sub init_schema { my $schema; if ( - $ENV{DBICTEST_VIA_REPLICATED} &&= - ( !$args{storage_type} && !defined $args{sqlite_use_file} ) + $ENV{DBICTEST_VIA_REPLICATED} &&= ( + !$args{storage_type} + && + ( ! defined $args{sqlite_use_file} or $args{sqlite_use_file} ) + ) ) { $args{storage_type} = ['::DBI::Replicated', { balancer_type => '::Random' }]; $args{sqlite_use_file} = 1; @@ -347,8 +392,19 @@ sub init_schema { if ( !$args{no_connect} ) { $schema->connection(@dsn); - $schema->storage->connect_replicants(\@dsn) - if $ENV{DBICTEST_VIA_REPLICATED}; + if( $ENV{DBICTEST_VIA_REPLICATED} ) { + + # add explicit ReadOnly=1 if we can support it + $dsn[0] =~ /^dbi:SQLite:/i + and + require DBD::SQLite + and + modver_gt_or_eq('DBD::SQLite', '1.49_05') + and + $dsn[0] =~ s/^dbi:SQLite:/dbi:SQLite(ReadOnly=1):/i; + + $schema->storage->connect_replicants(\@dsn); + } } if ( !$args{no_deploy} ) { @@ -389,16 +445,14 @@ sub deploy_schema { my $guard; if ( ($ENV{TRAVIS}||'') eq 'true' and my $old_dbg = $schema->storage->debug ) { - $guard = Scope::Guard->new(sub { $schema->storage->debug($old_dbg) }); + $guard = scope_guard { $schema->storage->debug($old_dbg) }; $schema->storage->debug(0); } if ($ENV{"DBICTEST_SQLT_DEPLOY"}) { $schema->deploy($args); } else { - my $filename = Path::Class::File->new(__FILE__)->dir - ->file('sqlite.sql')->stringify; - my $sql = do { local (@ARGV, $/) = $filename ; <> }; + my $sql = slurp_bytes( 't/lib/sqlite.sql' ); for my $chunk ( split (/;\s*\n+/, $sql) ) { 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 $schema->storage->dbh_do(sub { $_[1]->do($chunk) }) or print "Error on SQL: $chunk\n"; @@ -423,7 +477,7 @@ sub populate_schema { my $guard; if ( ($ENV{TRAVIS}||'') eq 'true' and my $old_dbg = $schema->storage->debug ) { - $guard = Scope::Guard->new(sub { $schema->storage->debug($old_dbg) }); + $guard = scope_guard { $schema->storage->debug($old_dbg) }; $schema->storage->debug(0); }