From: Peter Rabbitson Date: Fri, 3 Feb 2012 09:46:06 +0000 (+0100) Subject: Allow for tests to run in parallel (simultaneously from multiple checkouts) X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=8d6b1478d8fa6f7c76e313ee72a72d5eb4c24d03;p=dbsrgits%2FDBIx-Class-Historic.git Allow for tests to run in parallel (simultaneously from multiple checkouts) This is an interim solution and is by no means the final thing. It simply was possible to do in a short timeframe and cuts the test run time in half. If you have DSN envvars set, use at least -s -j8 for best results (the shuffling un-bunches similar tests, see discussion below) Two things are at play: First of all every SQLite database and every temp work directory is created separately using the pid of the *main* test process (there can be children) for disambiguation. Extra cleanup passes have been added to ensure t/var remains clean between runs. All other DSNs are reduced to their ->sqlt_type form and the result is used for a global lockfile. Said lockfile is kept in /tmp so that multiple testruns from multiple directories can be run against the same set of databases with no conflicts. Some of the tests are explicitly exempt from any locking and will run regardless of environment, for example t/storage/dbi_env.t The lockfiles are deliberately placed in File::Spec->tmpdir. This is done so that multiple dbic checkouts can run against the same set of DSNs without stepping on each other's toes. Some notes on why this is not a great idea, even though it works flawlessly under continuous test cycling: The problem is that our tests are not yet ordered in a spwecific way. This means that multiple tests competing for the same resource will inevitably lock all available test threads forming several bottlenecks along the path of execution. This issue will be adressed in a later patch, with the following considerations: - prove -l t/... must continue to work as is - test aggregation is something the test suite should try to avoid in general - after all DBIC is intended to be usable in CGI (yes, pure CGI) environments, so if the tests are getting heavy to run - this is an actual problem in need of fixing. Aggregation will instead sweep it under the rug - general reorganization of test groups / various path changes should only be attempted once we have a solid base for multi-db test runs --- diff --git a/Changes b/Changes index 57e2ab4..bdf6049 100644 --- a/Changes +++ b/Changes @@ -65,6 +65,8 @@ Revision history for DBIx::Class of storage capabilities - Fixed carp_once only emitting one single warning per package regardless of warning content + - Test suite now can be safely executed in parallel (prove -jN + or HARNESS_OPTIONS=jN) 0.08196 2011-11-29 05:35 (UTC) * Fixes diff --git a/Makefile.PL b/Makefile.PL index a88f64e..d4d11e3 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -119,27 +119,6 @@ if ($ENV{DBICTEST_SQLT_DEPLOY}) { } } -# Bail out on parallel testing -if ( - ($ENV{HARNESS_OPTIONS}||'') =~ / (?: ^ | \: ) j(\d+) /x - and - $1 > 1 -) { die < 4; +use lib 't/lib'; +use DBICTest; my $warnings; eval { @@ -21,3 +20,4 @@ isa_ok($source_a, 'DBIx::Class::ResultSource::Table'); my $rset_a = DBICTest::Schema->resultset('Artist'); isa_ok($rset_a, 'DBIx::Class::ResultSet'); +done_testing; diff --git a/t/103many_to_many_warning.t b/t/103many_to_many_warning.t index 0cd054b..f2944b4 100644 --- a/t/103many_to_many_warning.t +++ b/t/103many_to_many_warning.t @@ -3,6 +3,7 @@ use warnings; use Test::More; use lib qw(t/lib); +use DBICTest; plan tests => 4; my $exp_warn = qr/The many-to-many relationship 'bars' is trying to create/; diff --git a/t/20setuperrors.t b/t/20setuperrors.t index 769eaf3..ede7e29 100644 --- a/t/20setuperrors.t +++ b/t/20setuperrors.t @@ -4,6 +4,9 @@ use strict; use Test::More; use Test::Exception; +use lib 't/lib'; +use DBICTest; + throws_ok ( sub { package BuggyTable; diff --git a/t/40resultsetmanager.t b/t/40resultsetmanager.t index 45c6e3e..fad560d 100644 --- a/t/40resultsetmanager.t +++ b/t/40resultsetmanager.t @@ -4,6 +4,7 @@ use Test::More; use Test::Warn; use lib qw(t/lib); +use DBICTest; warnings_exist { require DBICTest::ResultSetManager } [ diff --git a/t/50fork.t b/t/50fork.t index 1d51605..3ddcaf3 100644 --- a/t/50fork.t +++ b/t/50fork.t @@ -1,8 +1,13 @@ use strict; use warnings; use Test::More; + +use lib qw(t/lib); +use DBICTest; use DBIx::Class::Optional::Dependencies (); +my $main_pid = $$; + plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('rdbms_pg') unless DBIx::Class::Optional::Dependencies->req_ok_for ('rdbms_pg'); @@ -18,12 +23,6 @@ if($num_children !~ /^[0-9]+$/ || $num_children < 10) { $num_children = 10; } -plan tests => ($num_children*2) + 6; - -use lib qw(t/lib); - -use_ok('DBICTest::Schema'); - my $schema = DBICTest::Schema->connect($dsn, $user, $pass, { AutoCommit => 1 }); my $parent_rs; @@ -117,4 +116,9 @@ while(@pids) { ok(1, "Made it to the end"); -$schema->storage->dbh->do("DROP TABLE cd"); +done_testing; + +END { + $schema->storage->dbh->do("DROP TABLE cd") if ($schema and $main_pid == $$); + undef $schema; +} diff --git a/t/51threads.t b/t/51threads.t index 7212dc9..be383e5 100644 --- a/t/51threads.t +++ b/t/51threads.t @@ -18,6 +18,7 @@ plan skip_all => 'DBIC does not actively support threads before perl 5.8.5' use DBIx::Class::Optional::Dependencies (); use lib qw(t/lib); +use DBICTest; plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('rdbms_pg') unless DBIx::Class::Optional::Dependencies->req_ok_for ('rdbms_pg'); diff --git a/t/51threadtxn.t b/t/51threadtxn.t index 1c8f7e6..e6cc3ac 100644 --- a/t/51threadtxn.t +++ b/t/51threadtxn.t @@ -21,6 +21,7 @@ plan skip_all => 'DBIC does not actively support threads before perl 5.8.5' use DBIx::Class::Optional::Dependencies (); use Scalar::Util 'weaken'; use lib qw(t/lib); +use DBICTest; my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_PG_${_}" } qw/DSN USER PASS/}; plan skip_all => 'Set $ENV{DBICTEST_PG_DSN}, _USER and _PASS to run this test' diff --git a/t/52leaks.t b/t/52leaks.t index 796453b..e36e3e9 100644 --- a/t/52leaks.t +++ b/t/52leaks.t @@ -79,6 +79,10 @@ unless (DBICTest::RunMode->is_plain) { } ); + # unicode is tricky, and now we happen to invoke it early via a + # regex in connection() + return $obj if (ref $obj) =~ /^utf8/; + # Test Builder is now making a new object for every pass/fail (que bloat?) # and as such we can't really store any of its objects (since it will # re-populate the registry while checking it, ewwww!) diff --git a/t/54taint.t b/t/54taint.t index 3ab675f..573e3c0 100644 --- a/t/54taint.t +++ b/t/54taint.t @@ -20,6 +20,7 @@ BEGIN { use Test::More; use Test::Exception; use lib qw(t/lib); +use DBICTest; throws_ok ( sub { $ENV{PATH} . (kill (0)) }, diff --git a/t/55namespaces_cleaned.t b/t/55namespaces_cleaned.t index 4caddf8..24cc22b 100644 --- a/t/55namespaces_cleaned.t +++ b/t/55namespaces_cleaned.t @@ -35,6 +35,9 @@ use warnings; use Test::More; +use lib 't/lib'; +use DBICTest; + use File::Find; use File::Spec; use B qw/svref_2object/; diff --git a/t/73oracle_hq.t b/t/73oracle_hq.t index 538fdf8..de4673b 100644 --- a/t/73oracle_hq.t +++ b/t/73oracle_hq.t @@ -5,6 +5,7 @@ use Test::Exception; use Test::More; use DBIx::Class::Optional::Dependencies (); use lib qw(t/lib); +use DBICTest::RunMode; use DBIC::SqlMakerTest; use DBIx::Class::SQLMaker::LimitDialects; @@ -38,6 +39,7 @@ BEGIN { ); } +use DBICTest; use DBICTest::Schema; my $schema = DBICTest::Schema->connect($dsn, $user, $pass); diff --git a/t/94versioning.t b/t/94versioning.t index 865ac26..7884cad 100644 --- a/t/94versioning.t +++ b/t/94versioning.t @@ -10,7 +10,7 @@ use File::Copy; use Time::HiRes qw/time sleep/; use lib qw(t/lib); -use DBICTest; # do not remove even though it is not used +use DBICTest; my ($dsn, $user, $pass); @@ -30,13 +30,18 @@ BEGIN { unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_rdbms_mysql'); } +# this is just to grab a lock +{ + my $s = DBICTest::Schema->connect($dsn, $user, $pass); +} + use_ok('DBICVersion_v1'); my $version_table_name = 'dbix_class_schema_versions'; my $old_table_name = 'SchemaVersions'; -my $ddl_dir = dir ('t', 'var'); -mkdir ($ddl_dir) unless -d $ddl_dir; +my $ddl_dir = dir(qw/t var/, "versioning_ddl-$$"); +$ddl_dir->mkpath unless -d $ddl_dir; my $fn = { v1 => $ddl_dir->file ('DBICVersion-Schema-1.0-MySQL.sql'), @@ -271,8 +276,10 @@ system( qq($^X -pi.bak -e "s/ALTER/-- this is a comment\nALTER/" $fn->{trans_v23 ok($get_db_version_run == 0, "attributes pulled from list connect_info"); } -unless ($ENV{DBICTEST_KEEP_VERSIONING_DDL}) { - unlink $_ for (values %$fn); +END { + unless ($ENV{DBICTEST_KEEP_VERSIONING_DDL}) { + $ddl_dir->rmtree; + } } done_testing; diff --git a/t/admin/01load.t b/t/admin/01load.t index 2089607..3bdaeb6 100644 --- a/t/admin/01load.t +++ b/t/admin/01load.t @@ -3,6 +3,9 @@ use warnings; use Test::More; +use lib 't/lib'; +use DBICTest; + BEGIN { require DBIx::Class; plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for('admin') diff --git a/t/admin/02ddl.t b/t/admin/02ddl.t index f1214b7..8b1c57f 100644 --- a/t/admin/02ddl.t +++ b/t/admin/02ddl.t @@ -21,22 +21,27 @@ BEGIN { use_ok 'DBIx::Class::Admin'; -my $sql_dir = dir(qw/t var/); -my @connect_info = DBICTest->_database( - no_deploy=>1, - no_populate=>1, - sqlite_use_file => 1, +# lock early +DBICTest->init_schema(no_deploy => 1, no_populate => 1); + +my $db_fn = DBICTest->_sqlite_dbfilename; +my @connect_info = ( + "dbi:SQLite:$db_fn", + undef, + undef, + { on_connect_do => 'PRAGMA synchronous = OFF' }, ); +my $ddl_dir = dir(qw/t var/, "admin_ddl-$$"); { # create the schema # make sure we are clean -clean_dir($sql_dir); +clean_dir($ddl_dir); my $admin = DBIx::Class::Admin->new( schema_class=> "DBICTest::Schema", - sql_dir=> $sql_dir, + sql_dir=> $ddl_dir, connect_info => \@connect_info, ); isa_ok ($admin, 'DBIx::Class::Admin', 'create the admin object'); @@ -50,12 +55,12 @@ lives_ok { { # upgrade schema -clean_dir($sql_dir); +clean_dir($ddl_dir); require DBICVersion_v1; my $admin = DBIx::Class::Admin->new( schema_class => 'DBICVersion::Schema', - sql_dir => $sql_dir, + sql_dir => $ddl_dir, connect_info => \@connect_info, ); @@ -71,11 +76,11 @@ is($schema->get_db_version, $DBICVersion::Schema::VERSION, 'Schema deployed and require DBICVersion_v2; -DBICVersion::Schema->upgrade_directory (undef); # so that we can test use of $sql_dir +DBICVersion::Schema->upgrade_directory (undef); # so that we can test use of $ddl_dir $admin = DBIx::Class::Admin->new( schema_class => 'DBICVersion::Schema', - sql_dir => $sql_dir, + sql_dir => $ddl_dir, connect_info => \@connect_info ); @@ -92,11 +97,11 @@ is($schema->get_db_version, $DBICVersion::Schema::VERSION, 'Schema and db versio { # install -clean_dir($sql_dir); +clean_dir($ddl_dir); my $admin = DBIx::Class::Admin->new( schema_class => 'DBICVersion::Schema', - sql_dir => $sql_dir, + sql_dir => $ddl_dir, _confirm => 1, connect_info => \@connect_info, ); @@ -111,20 +116,16 @@ warnings_exist ( sub { lives_ok { $admin->install("4.0") } 'can force install to allready existing version' }, qr/Forcing install may not be a good idea/, 'Force warning emitted' ); is($admin->schema->get_db_version, "4.0", 'db thinks its version 4.0'); -#clean_dir($sql_dir); } sub clean_dir { my ($dir) = @_; - $dir = $dir->resolve; - if ( ! -d $dir ) { - $dir->mkpath(); - } - foreach my $file ($dir->children) { - # skip any hidden files - next if ($file =~ /^\./); - unlink $file; - } + $dir->rmtree if -d $dir; + unlink $db_fn; +} + +END { + clean_dir($ddl_dir); } done_testing; diff --git a/t/admin/10script.t b/t/admin/10script.t index ce3d27e..4369971 100644 --- a/t/admin/10script.t +++ b/t/admin/10script.t @@ -79,9 +79,10 @@ sub test_dbicadmin { } sub default_args { + my $dbname = DBICTest->_sqlite_dbfilename; return ( qw|--quiet --schema=DBICTest::Schema --class=Employee|, - q|--connect=["dbi:SQLite:dbname=t/var/DBIxClass.db","","",{"AutoCommit":1}]|, + qq|--connect=["dbi:SQLite:dbname=$dbname","","",{"AutoCommit":1}]|, qw|--force -I testincludenoniterference|, ); } diff --git a/t/cdbi/DeepAbstractSearch/01_search.t b/t/cdbi/DeepAbstractSearch/01_search.t index 7346138..10f5f99 100644 --- a/t/cdbi/DeepAbstractSearch/01_search.t +++ b/t/cdbi/DeepAbstractSearch/01_search.t @@ -293,6 +293,3 @@ package main; } done_testing; - -END { unlink $DB if -e $DB } - diff --git a/t/cdbi/testlib/DBIC/Test/SQLite.pm b/t/cdbi/testlib/DBIC/Test/SQLite.pm index 88d61ef..5dc4a66 100644 --- a/t/cdbi/testlib/DBIC/Test/SQLite.pm +++ b/t/cdbi/testlib/DBIC/Test/SQLite.pm @@ -48,10 +48,7 @@ use base qw/DBIx::Class/; __PACKAGE__->load_components(qw/CDBICompat Core DB/); -use File::Temp qw/tempfile/; -my (undef, $DB) = tempfile(); -END { unlink $DB if -e $DB } - +my $DB = DBICTest->_sqlite_dbfilename; my @DSN = ("dbi:SQLite:dbname=$DB", '', '', { AutoCommit => 1, RaiseError => 1 }); __PACKAGE__->connection(@DSN); diff --git a/t/cdbi/testlib/MyBase.pm b/t/cdbi/testlib/MyBase.pm index 7885ed5..c06f179 100644 --- a/t/cdbi/testlib/MyBase.pm +++ b/t/cdbi/testlib/MyBase.pm @@ -2,10 +2,13 @@ package # hide from PAUSE MyBase; use strict; -use base qw(DBIx::Class::CDBICompat); - use DBI; +use lib 't/lib'; +use DBICTest; + +use base qw(DBIx::Class::CDBICompat); + our $dbh; my $err; @@ -27,6 +30,11 @@ if ($err) { } my @connect = (@ENV{map { "DBICTEST_MYSQL_${_}" } qw/DSN USER PASS/}, { PrintError => 0}); +# this is only so we grab a lock on mysql +{ + my $x = DBICTest::Schema->connect(@connect); +} + $dbh = DBI->connect(@connect) or die DBI->errstr; my @table; diff --git a/t/lib/DBICTest.pm b/t/lib/DBICTest.pm index 92c16f7..58f5cca 100644 --- a/t/lib/DBICTest.pm +++ b/t/lib/DBICTest.pm @@ -5,9 +5,11 @@ use strict; use warnings; use DBICTest::RunMode; use DBICTest::Schema; -use DBICTest::Util qw/populate_weakregistry assert_empty_weakregistry/; +use DBICTest::Util qw/populate_weakregistry assert_empty_weakregistry local_umask/; use Carp; use Path::Class::File (); +use File::Spec; +use Fcntl qw/:flock/; =head1 NAME @@ -50,14 +52,85 @@ default, unless the no_deploy or no_populate flags are set. =cut -sub has_custom_dsn { - return $ENV{"DBICTEST_DSN"} ? 1:0; +# some tests are very time sensitive and need to run on their own, without +# being disturbed by anything else grabbing CPU or disk IO. Hence why everything +# using DBICTest grabs a shared lock, and the few tests that request a :GlobalLock +# will ask for an exclusive one and block until they can get it +our ($global_lock_fh, $global_exclusive_lock); +sub import { + my $self = shift; + + my $lockpath = File::Spec->tmpdir . '/.dbictest_global.lock'; + + { + my $u = local_umask(0); # so that the file opens as 666, and any user can lock + open ($global_lock_fh, '>', $lockpath) + or die "Unable to open $lockpath: $!"; + } + + for (@_) { + if ($_ eq ':GlobalLock') { + flock ($global_lock_fh, LOCK_EX) or die "Unable to lock $lockpath: $!"; + $global_exclusive_lock = 1; + } + else { + croak "Unknown export $_ requested from $self"; + } + } + + unless ($global_exclusive_lock) { + flock ($global_lock_fh, LOCK_SH) or die "Unable to lock $lockpath: $!"; + } } -sub _sqlite_dbfilename { +END { + if ($global_lock_fh) { + # delay destruction even more + } +} + +{ my $dir = Path::Class::File->new(__FILE__)->dir->parent->subdir('var'); $dir->mkpath unless -d "$dir"; - return $dir->file('DBIxClass.db')->stringify; + $dir = "$dir"; + + sub _sqlite_dbfilename { + my $holder = $ENV{DBICTEST_LOCK_HOLDER} || $$; + $holder = $$ if $holder == -1; + + # useful for missing cleanup debugging + #if ( $holder == $$) { + # my $x = $0; + # $x =~ s/\//#/g; + # $holder .= "-$x"; + #} + + return "$dir/DBIxClass-$holder.db"; + } + + END { + _cleanup_dbfile(); + } +} + +$SIG{INT} = sub { _cleanup_dbfile(); exit 1 }; + +sub _cleanup_dbfile { + # cleanup if this is us + if ( + ! $ENV{DBICTEST_LOCK_HOLDER} + or + $ENV{DBICTEST_LOCK_HOLDER} == -1 + or + $ENV{DBICTEST_LOCK_HOLDER} == $$ + ) { + my $db_file = _sqlite_dbfilename(); + unlink $_ for ($db_file, "${db_file}-journal"); + } +} + +sub has_custom_dsn { + return $ENV{"DBICTEST_DSN"} ? 1:0; } sub _sqlite_dbname { diff --git a/t/lib/DBICTest/Schema.pm b/t/lib/DBICTest/Schema.pm index 5d2518a..be36371 100644 --- a/t/lib/DBICTest/Schema.pm +++ b/t/lib/DBICTest/Schema.pm @@ -7,7 +7,11 @@ no warnings 'qw'; use base 'DBIx::Class::Schema'; -use DBICTest::Util qw/populate_weakregistry assert_empty_weakregistry/; +use Fcntl qw/:DEFAULT :seek :flock/; +use Time::HiRes 'sleep'; +use Path::Class::File; +use File::Spec; +use DBICTest::Util qw/populate_weakregistry assert_empty_weakregistry local_umask/; use namespace::clean; __PACKAGE__->mk_group_accessors(simple => 'custom_attr'); @@ -65,18 +69,125 @@ sub sqlt_deploy_hook { $sqlt_schema->drop_table('dummy'); } -my $weak_registry = {}; -sub clone { - my $self = shift->next::method(@_); - populate_weakregistry ( $weak_registry, $self ) - if $INC{'Test/Builder.pm'}; - $self; +our $locker; +END { + # we need the $locker to be referenced here for delayed destruction + if ($locker->{lock_name} and ($ENV{DBICTEST_LOCK_HOLDER}||0) == $$) { + #warn "$$ $0 $locktype LOCK RELEASED"; + } } +my $weak_registry = {}; + sub connection { my $self = shift->next::method(@_); +# MASSIVE FIXME +# we can't really lock based on DSN, as we do not yet have a way to tell that e.g. +# DBICTEST_MSSQL_DSN=dbi:Sybase:server=192.168.0.11:1433;database=dbtst +# and +# DBICTEST_MSSQL_ODBC_DSN=dbi:ODBC:server=192.168.0.11;port=1433;database=dbtst;driver=FreeTDS;tds_version=8.0 +# are the same server +# hence we lock everything based on sqlt_type or just globally if not available +# just pretend we are python you know? :) + + + # when we get a proper DSN resolution sanitize to produce a portable lockfile name + # this may look weird and unnecessary, but consider running tests from + # windows over a samba share >.> + #utf8::encode($dsn); + #$dsn =~ s/([^A-Za-z0-9_\-\.\=])/ sprintf '~%02X', ord($1) /ge; + #$dsn =~ s/^dbi/dbi/i; + + # provide locking for physical (non-memory) DSNs, so that tests can + # safely run in parallel. While the harness (make -jN test) does set + # an envvar, we can not detect when a user invokes prove -jN. Hence + # perform the locking at all times, it shouldn't hurt. + # the lock fh *should* inherit across forks/subprocesses + # + # File locking is hard. Really hard. By far the best lock implementation + # I've seen is part of the guts of File::Temp. However it is sadly not + # reusable. Since I am not aware of folks doing NFS parallel testing, + # nor are we known to work on VMS, I am just going to punt this and + # use the portable-ish flock() provided by perl itself. If this does + # not work for you - patches more than welcome. + if ( + ! $DBICTest::global_exclusive_lock + and + ( ! $ENV{DBICTEST_LOCK_HOLDER} or $ENV{DBICTEST_LOCK_HOLDER} == $$ ) + and + ref($_[0]) ne 'CODE' + and + ($_[0]||'') !~ /^ (?i:dbi) \: SQLite \: (?: dbname\= )? (?: \:memory\: | t [\/\\] var [\/\\] DBIxClass\-) /x + ) { + + my $locktype = do { + # guard against infinite recursion + local $ENV{DBICTEST_LOCK_HOLDER} = -1; + + # we need to connect a forced fresh clone so that we do not upset any state + # of the main $schema (some tests examine it quite closely) + local $@; + my $storage = eval { + my $st = ref($self)->connect(@{$self->storage->connect_info})->storage; + $st->ensure_connected; # do connect here, to catch a possible throw + $st; + }; + $storage + ? do { + my $t = $storage->sqlt_type || 'generic'; + eval { $storage->disconnect }; + $t; + } + : undef + ; + }; + + + # Never hold more than one lock. This solves the "lock in order" issues + # unrelated tests may have + # Also if there is no connection - there is no lock to be had + if ($locktype and (!$locker or $locker->{type} ne $locktype)) { + + warn "$$ $0 $locktype" if $locktype eq 'generic' or $locktype eq 'SQLite'; + + my $lockpath = File::Spec->tmpdir . "/.dbictest_$locktype.lock"; + + my $lock_fh; + { + my $u = local_umask(0); # so that the file opens as 666, and any user can lock + sysopen ($lock_fh, $lockpath, O_RDWR|O_CREAT) or die "Unable to open $lockpath: $!"; + } + flock ($lock_fh, LOCK_EX) or die "Unable to lock $lockpath: $!"; + #warn "$$ $0 $locktype LOCK GRABBED"; + + # see if anyone was holding a lock before us, and wait up to 5 seconds for them to terminate + # if we do not do this we may end up trampling over some long-running END or somesuch + seek ($lock_fh, 0, SEEK_SET) or die "seek failed $!"; + if (read ($lock_fh, my $old_pid, 100) ) { + for (1..50) { + kill (0, $old_pid) or last; + sleep 0.1; + } + } + #warn "$$ $0 $locktype POST GRAB WAIT"; + + truncate $lock_fh, 0; + seek ($lock_fh, 0, SEEK_SET) or die "seek failed $!"; + $lock_fh->autoflush(1); + print $lock_fh $$; + + $ENV{DBICTEST_LOCK_HOLDER} ||= $$; + + $locker = { + type => $locktype, + fh => $lock_fh, + lock_name => "$lockpath", + }; + } + } + if ($INC{'Test/Builder.pm'}) { populate_weakregistry ( $weak_registry, $self->storage ); @@ -93,6 +204,13 @@ sub connection { ]); } + return $self; +} + +sub clone { + my $self = shift->next::method(@_); + populate_weakregistry ( $weak_registry, $self ) + if $INC{'Test/Builder.pm'}; $self; } diff --git a/t/lib/DBICTest/Util.pm b/t/lib/DBICTest/Util.pm index 9f5e985..3f489c2 100644 --- a/t/lib/DBICTest/Util.pm +++ b/t/lib/DBICTest/Util.pm @@ -5,9 +5,32 @@ use strict; use Carp; use Scalar::Util qw/isweak weaken blessed reftype refaddr/; +use Config; use base 'Exporter'; -our @EXPORT_OK = qw/stacktrace populate_weakregistry assert_empty_weakregistry/; +our @EXPORT_OK = qw/local_umask stacktrace populate_weakregistry assert_empty_weakregistry/; + +sub local_umask { + return unless defined $Config{d_umask}; + + die 'Calling local_umask() in void context makes no sense' + if ! defined wantarray; + + my $old_umask = umask(shift()); + die "Setting umask failed: $!" unless defined $old_umask; + + return bless \$old_umask, 'DBICTest::Util::UmaskGuard'; +} +{ + package DBICTest::Util::UmaskGuard; + sub DESTROY { + local ($@, $!); + eval { defined (umask ${$_[0]}) or die }; + warn ( "Unable to reset old umask ${$_[0]}: " . ($!||'Unknown error') ) + if ($@ || $!); + } +} + sub stacktrace { my $frame = shift; diff --git a/t/lib/DBICVersion_v1.pm b/t/lib/DBICVersion_v1.pm index ee34628..d2e6325 100644 --- a/t/lib/DBICVersion_v1.pm +++ b/t/lib/DBICVersion_v1.pm @@ -36,7 +36,7 @@ our $VERSION = '1.0'; __PACKAGE__->register_class('Table', 'DBICVersion::Table'); __PACKAGE__->load_components('+DBIx::Class::Schema::Versioned'); -__PACKAGE__->upgrade_directory('t/var/'); +__PACKAGE__->upgrade_directory("t/var/versioning_ddl-$$"); sub ordered_schema_versions { return('1.0','2.0','3.0'); diff --git a/t/lib/DBICVersion_v2.pm b/t/lib/DBICVersion_v2.pm index 3c5624b..6f152f1 100644 --- a/t/lib/DBICVersion_v2.pm +++ b/t/lib/DBICVersion_v2.pm @@ -44,7 +44,7 @@ our $VERSION = '2.0'; __PACKAGE__->register_class('Table', 'DBICVersion::Table'); __PACKAGE__->load_components('+DBIx::Class::Schema::Versioned'); -__PACKAGE__->upgrade_directory('t/var/'); -__PACKAGE__->backup_directory('t/var/backup/'); +__PACKAGE__->upgrade_directory("t/var/versioning_ddl-$$"); +__PACKAGE__->backup_directory("t/var/versioning_backup-$$"); 1; diff --git a/t/lib/DBICVersion_v3.pm b/t/lib/DBICVersion_v3.pm index 29caaae..d66b897 100644 --- a/t/lib/DBICVersion_v3.pm +++ b/t/lib/DBICVersion_v3.pm @@ -52,7 +52,7 @@ our $VERSION = '3.0'; __PACKAGE__->register_class('Table', 'DBICVersion::Table'); __PACKAGE__->load_components('+DBIx::Class::Schema::Versioned'); -__PACKAGE__->upgrade_directory('t/var/'); -__PACKAGE__->backup_directory('t/var/backup/'); +__PACKAGE__->upgrade_directory("t/var/versioning_ddl-$$"); +__PACKAGE__->backup_directory("t/var/versioning_backup-$$"); 1; diff --git a/t/row/inflate_result.t b/t/row/inflate_result.t index ecdd68c..b020ab5 100644 --- a/t/row/inflate_result.t +++ b/t/row/inflate_result.t @@ -78,7 +78,7 @@ my $admin_data = { admin => 1 }; -ok( my $schema = My::Schema->connection(DBICTest->_database) ); +ok( my $schema = My::Schema->connect(DBICTest->_database) ); ok( $schema->storage->dbh->do( diff --git a/t/sqlmaker/oracle.t b/t/sqlmaker/oracle.t index 350ad35..69234f9 100644 --- a/t/sqlmaker/oracle.t +++ b/t/sqlmaker/oracle.t @@ -11,6 +11,7 @@ BEGIN { use Test::Exception; use Data::Dumper::Concise; use lib qw(t/lib); +use DBICTest; use DBIC::SqlMakerTest; use DBIx::Class::SQLMaker::Oracle; diff --git a/t/storage/dbi_env.t b/t/storage/dbi_env.t index a22b91c..fd5f1d6 100644 --- a/t/storage/dbi_env.t +++ b/t/storage/dbi_env.t @@ -7,9 +7,10 @@ use Test::Exception; BEGIN { delete @ENV{qw(DBI_DSN DBI_DRIVER)} } -my $schema; +$ENV{DBICTEST_LOCK_HOLDER} = -1; -DBICTest->init_schema(sqlite_use_file => 1); +# pre-populate +my $schema = DBICTest->init_schema(sqlite_use_file => 1); my $dbname = DBICTest->_sqlite_dbname(sqlite_use_file => 1); diff --git a/t/storage/debug.t b/t/storage/debug.t index 632f370..6d8e94c 100644 --- a/t/storage/debug.t +++ b/t/storage/debug.t @@ -14,7 +14,7 @@ BEGIN { delete @ENV{qw(DBIC_TRACE DBIC_TRACE_PROFILE DBICTEST_SQLITE_USE_FILE)} my $schema = DBICTest->init_schema(); -my $lfn = file('t/var/sql.log'); +my $lfn = file("t/var/sql-$$.log"); unlink $lfn or die $! if -e $lfn; @@ -49,6 +49,10 @@ $schema->storage->debugfh(undef); $schema->storage->debugobj->debugfh(undef) } +END { + unlink $lfn; +} + open(STDERRCOPY, '>&STDERR'); close(STDERR); dies_ok { diff --git a/t/storage/deploy.t b/t/storage/deploy.t index 3b9435b..444bf26 100644 --- a/t/storage/deploy.t +++ b/t/storage/deploy.t @@ -16,7 +16,6 @@ BEGIN { use File::Spec; use Path::Class qw/dir/; -use File::Path qw/make_path remove_tree/; lives_ok( sub { my $parse_schema = DBICTest->init_schema(no_deploy => 1); @@ -26,13 +25,11 @@ lives_ok( sub { my $schema = DBICTest->init_schema(); -my $var = dir (qw| t var create_ddl_dir |); --d $var - or make_path( "$var" ) - or die "can't create $var: $!"; +my $var = dir ("t/var/ddl_dir-$$"); +$var->mkpath unless -d $var; my $test_dir_1 = $var->subdir ('test1', 'foo', 'bar' ); -remove_tree( "$test_dir_1" ) if -d $test_dir_1; +$test_dir_1->rmtree if -d $test_dir_1; $schema->create_ddl_dir( undef, undef, $test_dir_1 ); ok( -d $test_dir_1, 'create_ddl_dir did a make_path on its target dir' ); @@ -43,4 +40,8 @@ TODO: { ok( 0 ); } +END { + $var->rmtree; +} + done_testing; diff --git a/t/storage/on_connect_do.t b/t/storage/on_connect_do.t index fd0ab49..2874a9d 100644 --- a/t/storage/on_connect_do.t +++ b/t/storage/on_connect_do.t @@ -9,7 +9,7 @@ use Test::Warn; use Test::Exception; use lib qw(t/lib); -use base 'DBICTest'; +use DBICTest; require DBI; diff --git a/t/storage/quote_names.t b/t/storage/quote_names.t index cbf572a..87517e9 100644 --- a/t/storage/quote_names.t +++ b/t/storage/quote_names.t @@ -88,6 +88,9 @@ my %dbs = ( MSSQL_ODBC => 'DBIx::Class::Storage::DBI::MSSQL', ); +# lie that we already locked stuff - the tests below do not touch anything +$ENV{DBICTEST_LOCK_HOLDER} = -1; + # Make sure oracle is tried last - some clients (e.g. 10.2) have symbol # clashes with libssl, and will segfault everything coming after them for my $db (sort { diff --git a/t/storage/reconnect.t b/t/storage/reconnect.t index d8ddbbc..b28734b 100644 --- a/t/storage/reconnect.t +++ b/t/storage/reconnect.t @@ -8,7 +8,7 @@ use Test::Exception; use lib qw(t/lib); use DBICTest; -my $db_orig = "$FindBin::Bin/../var/DBIxClass.db"; +my $db_orig = DBICTest->_sqlite_dbfilename; my $db_tmp = "$db_orig.tmp"; # Set up the "usual" sqlite for DBICTest diff --git a/t/zzzzzzz_perl_perf_bug.t b/t/zzzzzzz_perl_perf_bug.t index e0aad96..c0a96d8 100644 --- a/t/zzzzzzz_perl_perf_bug.t +++ b/t/zzzzzzz_perl_perf_bug.t @@ -3,7 +3,7 @@ use warnings; use Test::More; use Benchmark; use lib qw(t/lib); -use DBICTest; # do not remove even though it is not used +use DBICTest ':GlobalLock'; # This is a rather unusual test. # It does not test any aspect of DBIx::Class, but instead tests the diff --git a/t/zzzzzzz_sqlite_deadlock.t b/t/zzzzzzz_sqlite_deadlock.t index c967c25..6a38d2c 100644 --- a/t/zzzzzzz_sqlite_deadlock.t +++ b/t/zzzzzzz_sqlite_deadlock.t @@ -2,26 +2,31 @@ use strict; use warnings; use Test::More; -use Test::Exception; -use lib 't/lib'; -use File::Temp (); -use DBICTest; -use DBICTest::Schema; +use lib 't/lib'; +use DBICTest::RunMode; if ( DBICTest::RunMode->is_plain ) { plan( skip_all => "Skipping test on plain module install" ); } +use Test::Exception; +use DBICTest; +use File::Temp (); + plan tests => 2; my $wait_for = 120; # how many seconds to wait +# don't lock anything - this is a tempfile anyway +$ENV{DBICTEST_LOCK_HOLDER} = -1; + for my $close (0,1) { my $tmp = File::Temp->new( UNLINK => 1, - TMPDIR => 1, - SUFFIX => '.sqlite', + DIR => 't/var', + SUFFIX => '.db', + TEMPLATE => 'DBIxClass-XXXXXX', EXLOCK => 0, # important for BSD and derivatives ); @@ -37,8 +42,9 @@ for my $close (0,1) { lives_ok (sub { my $schema = DBICTest::Schema->connect ("DBI:SQLite:$tmp_fn"); + $schema->storage->dbh_do(sub { $_[1]->do('PRAGMA synchronous = OFF') }); DBICTest->deploy_schema ($schema); - #DBICTest->populate_schema ($schema); + DBICTest->populate_schema ($schema); }); alarm 0;