From: Peter Rabbitson Date: Tue, 27 May 2014 08:09:43 +0000 (+0200) Subject: Move the DSN-lock machinery from 8d6b1478d into DBICTest::BaseSchema X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=e952df766c89f1fd6e7e2e1289162b5c6773e65c;p=dbsrgits%2FDBIx-Class-Historic.git Move the DSN-lock machinery from 8d6b1478d into DBICTest::BaseSchema This is just a c/p job, expecting zero functional changes The t/admin/02ddl.t are cosmetic changes fixing a nested &cref leak never before encountered on <= 5.8.7 --- diff --git a/t/admin/02ddl.t b/t/admin/02ddl.t index 1d9ce88..d17d677 100644 --- a/t/admin/02ddl.t +++ b/t/admin/02ddl.t @@ -108,13 +108,15 @@ my $admin = DBIx::Class::Admin->new( ); $admin->version("3.0"); -lives_ok { $admin->install(); } 'install schema version 3.0'; +$admin->install; is($admin->schema->get_db_version, "3.0", 'db thinks its version 3.0'); -dies_ok { $admin->install("4.0"); } 'cannot install to allready existing version'; +throws_ok { + $admin->install("4.0") +} qr/Schema already has a version. Try upgrade instead/, 'cannot install to allready existing version'; $admin->force(1); warnings_exist ( sub { - lives_ok { $admin->install("4.0") } 'can force install to allready existing version' + $admin->install("4.0") }, 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'); } diff --git a/t/lib/DBICTest/BaseSchema.pm b/t/lib/DBICTest/BaseSchema.pm index ea7088a..0e1e5e2 100644 --- a/t/lib/DBICTest/BaseSchema.pm +++ b/t/lib/DBICTest/BaseSchema.pm @@ -6,5 +6,166 @@ use warnings; use base qw(DBICTest::Base DBIx::Class::Schema); +use Fcntl qw(:DEFAULT :seek :flock); +use Time::HiRes 'sleep'; +use DBICTest::Util::LeakTracer qw(populate_weakregistry assert_empty_weakregistry); +use DBICTest::Util 'local_umask'; +use namespace::clean; + +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 $locker->{type} 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 $SIG{__WARN__} = sub {}; + 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)) { + + # this will release whatever lock we may currently be holding + # which is fine since the type does not match as checked above + undef $locker; + + my $lockpath = DBICTest::RunMode->tmpdir->file("_dbictest_$locktype.lock"); + + #warn "$$ $0 $locktype GRABBING 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 $!"; + my $old_pid; + if ( + read ($lock_fh, $old_pid, 100) + and + ($old_pid) = $old_pid =~ /^(\d+)$/ + ) { + 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 ); + + my $cur_connect_call = $self->storage->on_connect_call; + + $self->storage->on_connect_call([ + (ref $cur_connect_call eq 'ARRAY' + ? @$cur_connect_call + : ($cur_connect_call || ()) + ), + [sub { + populate_weakregistry( $weak_registry, shift->_dbh ) + }], + ]); + } + + return $self; +} + +sub clone { + my $self = shift->next::method(@_); + populate_weakregistry ( $weak_registry, $self ) + if $INC{'Test/Builder.pm'}; + $self; +} + +END { + assert_empty_weakregistry($weak_registry, 'quiet'); +} 1; diff --git a/t/lib/DBICTest/Schema.pm b/t/lib/DBICTest/Schema.pm index b39ecbc..52906c7 100644 --- a/t/lib/DBICTest/Schema.pm +++ b/t/lib/DBICTest/Schema.pm @@ -7,13 +7,6 @@ no warnings 'qw'; use base 'DBICTest::BaseSchema'; -use Fcntl qw/:DEFAULT :seek :flock/; -use Time::HiRes 'sleep'; -use DBICTest::RunMode; -use DBICTest::Util::LeakTracer qw/populate_weakregistry assert_empty_weakregistry/; -use DBICTest::Util 'local_umask'; -use namespace::clean; - __PACKAGE__->mk_group_accessors(simple => 'custom_attr'); __PACKAGE__->load_classes(qw/ @@ -69,160 +62,4 @@ sub sqlt_deploy_hook { $sqlt_schema->drop_table('dummy'); } - -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 $locker->{type} 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)) { - - # this will release whatever lock we may currently be holding - # which is fine since the type does not match as checked above - undef $locker; - - my $lockpath = DBICTest::RunMode->tmpdir->file("_dbictest_$locktype.lock"); - - #warn "$$ $0 $locktype GRABBING 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 $!"; - my $old_pid; - if ( - read ($lock_fh, $old_pid, 100) - and - ($old_pid) = $old_pid =~ /^(\d+)$/ - ) { - 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 ); - - my $cur_connect_call = $self->storage->on_connect_call; - - $self->storage->on_connect_call([ - (ref $cur_connect_call eq 'ARRAY' - ? @$cur_connect_call - : ($cur_connect_call || ()) - ), - [sub { - populate_weakregistry( $weak_registry, shift->_dbh ) - }], - ]); - } - - return $self; -} - -sub clone { - my $self = shift->next::method(@_); - populate_weakregistry ( $weak_registry, $self ) - if $INC{'Test/Builder.pm'}; - $self; -} - -END { - assert_empty_weakregistry($weak_registry, 'quiet'); -} - 1;