From: Peter Rabbitson Date: Wed, 17 Feb 2016 10:01:20 +0000 (+0100) Subject: Move tmpdir() to DBICTest::Util where it belongs X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=439a7283a981f27a56e745d99e456fc50a5a018f;p=dbsrgits%2FDBIx-Class-Historic.git Move tmpdir() to DBICTest::Util where it belongs This detangles things even more. Add some extra logic fixes to the hideous routine while we are at it... Some notes on the actual test pefrormed: there have been cases on smokers where a returned directory was not in fact writable [1]. Thus work harder making sure everything works. The check is expensive but not terribly so: about 14ms on cold caches ( echo 3 > /proc/sys/vm/drop_caches ) and ~6ms thereafter. This adds up to 2 seconds over the current 320 tests. Timed via: ~$ perl -It/lib -Ilib -MANFANG -MDBICTest::Util=tmpdir -MTime::HiRes=time -e ' my $t0 = time; sub delta_t { my $t = time; printf "%.06f\n", $t - $t0; $t0 = $t } delta_t(); print tmpdir . "\n"; delta_t(); print tmpdir . "\n"; delta_t(); print tmpdir . "\n"; delta_t(); ' [1] http://www.cpantesters.org/cpan/report/36d4436d-7888-1014-a278-e5322b825c07 --- diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm index 846920d..b5991fb 100644 --- a/lib/DBIx/Class/_Util.pm +++ b/lib/DBIx/Class/_Util.pm @@ -82,7 +82,7 @@ our @EXPORT_OK = qw( scope_guard detected_reinvoked_destructor is_exception dbic_internal_try quote_sub qsub perlstring serialize deep_clone - parent_dir + parent_dir mkdir_p UNRESOLVABLE_CONDITION ); @@ -451,6 +451,12 @@ sub parent_dir ($) { ; } +sub mkdir_p ($) { + require File::Path; + # do not ask for a recent version, use 1.x API calls + File::Path::mkpath([ "$_[0]" ]); # File::Path does not like objects +} + { my $list_ctx_ok_stack_marker; diff --git a/t/35exception_inaction.t b/t/35exception_inaction.t index ffbabc5..2a3023b 100644 --- a/t/35exception_inaction.t +++ b/t/35exception_inaction.t @@ -12,6 +12,7 @@ BEGIN { } } +use DBICTest::Util 'tmpdir'; use File::Temp (); use DBIx::Class::_Util 'scope_guard'; use DBIx::Class::Schema; @@ -49,7 +50,7 @@ $schema->connection('dbi:SQLite::memory:'); # demonstrate utter breakage of the reconnection/retry logic # open(my $stderr_copy, '>&', *STDERR) or die "Unable to dup STDERR: $!"; -my $tf = File::Temp->new( UNLINK => 1 ); +my $tf = File::Temp->new( UNLINK => 1, DIR => tmpdir() ); my $output; diff --git a/t/52leaks.t b/t/52leaks.t index b61856d..c7af701 100644 --- a/t/52leaks.t +++ b/t/52leaks.t @@ -443,6 +443,10 @@ for my $addr (keys %$weak_registry) { # T::B 2.0 has result objects and other fancyness delete $weak_registry->{$addr}; } + elsif ($names =~ /^Class::Struct/m) { + # remove this when Path::Class is gone, what a crock of shit + delete $weak_registry->{$addr}; + } elsif ($names =~ /^Hash::Merge/m) { # only clear one object of a specific behavior - more would indicate trouble delete $weak_registry->{$addr} diff --git a/t/inflate/file_column.t b/t/inflate/file_column.t index acbf46b..9c5203d 100644 --- a/t/inflate/file_column.t +++ b/t/inflate/file_column.t @@ -4,8 +4,10 @@ use strict; use warnings; use Test::More; + use DBICTest; use DBICTest::Schema; +use File::Temp (); use File::Compare; use Path::Class qw/file/; @@ -18,8 +20,6 @@ use Path::Class qw/file/; use warnings; use base qw/DBICTest::BaseResult/; - use File::Temp qw/tempdir/; - __PACKAGE__->load_components (qw/InflateColumn::File/); __PACKAGE__->table('file_columns'); @@ -28,7 +28,7 @@ use Path::Class qw/file/; file => { data_type => 'varchar', is_file_column => 1, - file_column_path => tempdir(CLEANUP => 1), + file_column_path => File::Temp->newdir( CLEANUP => 1, DIR => DBICTest::Util::tmpdir() ), size => 255 } ); diff --git a/t/lib/DBICTest.pm b/t/lib/DBICTest.pm index ad3bf3c..91a0c79 100644 --- a/t/lib/DBICTest.pm +++ b/t/lib/DBICTest.pm @@ -25,13 +25,12 @@ BEGIN { } -use DBICTest::Util qw( local_umask await_flock dbg DEBUG_TEST_CONCURRENCY_LOCKS ); +use DBICTest::Util qw( local_umask tmpdir await_flock dbg DEBUG_TEST_CONCURRENCY_LOCKS ); use DBICTest::Schema; use DBICTest::Util::LeakTracer qw/populate_weakregistry assert_empty_weakregistry/; use DBIx::Class::_Util qw( detected_reinvoked_destructor scope_guard ); use Carp; use Path::Class::File (); -use File::Spec; use Fcntl qw/:DEFAULT :flock/; use Config; @@ -104,7 +103,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 diff --git a/t/lib/DBICTest/BaseSchema.pm b/t/lib/DBICTest/BaseSchema.pm index f210c2d..328b950 100644 --- a/t/lib/DBICTest/BaseSchema.pm +++ b/t/lib/DBICTest/BaseSchema.pm @@ -9,7 +9,7 @@ use Fcntl qw(:DEFAULT :seek :flock); use Time::HiRes 'sleep'; use DBIx::Class::_Util 'scope_guard'; use DBICTest::Util::LeakTracer qw(populate_weakregistry assert_empty_weakregistry); -use DBICTest::Util qw( local_umask await_flock dbg DEBUG_TEST_CONCURRENCY_LOCKS ); +use DBICTest::Util qw( local_umask tmpdir await_flock dbg DEBUG_TEST_CONCURRENCY_LOCKS ); use namespace::clean; if( $ENV{DBICTEST_ASSERT_NO_SPURIOUS_EXCEPTION_ACTION} ) { @@ -243,7 +243,7 @@ sub connection { undef $locker; - my $lockpath = DBICTest::RunMode->tmpdir->file("_dbictest_$locktype.lock"); + my $lockpath = tmpdir . "_dbictest_$locktype.lock"; DEBUG_TEST_CONCURRENCY_LOCKS and dbg "Waiting for $locktype LOCK: $lockpath..."; diff --git a/t/lib/DBICTest/RunMode.pm b/t/lib/DBICTest/RunMode.pm index b151392..82da4df 100644 --- a/t/lib/DBICTest/RunMode.pm +++ b/t/lib/DBICTest/RunMode.pm @@ -4,86 +4,8 @@ package # hide from PAUSE use strict; use warnings; -use Path::Class qw/file dir/; -use Fcntl ':DEFAULT'; -use File::Spec (); -use File::Temp (); -use DBICTest::Util qw( local_umask find_co_root ); - -# Try to determine the root of a checkout/untar if possible -# return a Path::Class::Dir object or undef -sub _find_co_root { eval { dir( find_co_root() ) } } - -# PathTools has a bug where on MSWin32 it will often return / as a tmpdir. -# This is *really* stupid and the result of having our lockfiles all over -# the place is also rather obnoxious. So we use our own heuristics instead -# https://rt.cpan.org/Ticket/Display.html?id=76663 -my $tmpdir; -sub tmpdir { - dir ($tmpdir ||= do { - - # works but not always - my $dir = dir(File::Spec->tmpdir); - my $reason_dir_unusable; - - my @parts = File::Spec->splitdir($dir); - if (@parts == 2 and $parts[1] =~ /^ [\/\\]? $/x ) { - $reason_dir_unusable = - 'File::Spec->tmpdir returned a root directory instead of a designated ' - . 'tempdir (possibly https://rt.cpan.org/Ticket/Display.html?id=76663)'; - } - else { - # make sure we can actually create and sysopen a file in this dir - local $@; - my $u = local_umask(0); # match the umask we use in DBICTest(::Schema) - my $tempfile = ''; - eval { - $tempfile = File::Temp->new( - TEMPLATE => '_dbictest_writability_test_XXXXXX', - DIR => "$dir", - UNLINK => 1, - ); - close $tempfile or die "closing $tempfile failed: $!\n"; - - sysopen (my $tempfh2, "$tempfile", O_RDWR) or die "reopening $tempfile failed: $!\n"; - print $tempfh2 'deadbeef' x 1024 or die "printing to $tempfile failed: $!\n"; - close $tempfh2 or die "closing $tempfile failed: $!\n"; - 1; - } or do { - chomp( my $err = $@ ); - my @x_tests = map { (defined $_) ? ( $_ ? 1 : 0 ) : 'U' } map {(-e, -d, -f, -r, -w, -x, -o)} ("$dir", "$tempfile"); - $reason_dir_unusable = sprintf <<"EOE", "$tempfile"||'', $err, scalar $>, scalar $), umask(), (stat($dir))[4,5,2], @x_tests; -File::Spec->tmpdir returned a directory which appears to be non-writeable: -Error encountered while testing '%s': %s -Process EUID/EGID: %s / %s -Effective umask: %o -TmpDir UID/GID: %s / %s -TmpDir StatMode: %o -TmpDir X-tests: -e:%s -d:%s -f:%s -r:%s -w:%s -x:%s -o:%s -TmpFile X-tests: -e:%s -d:%s -f:%s -r:%s -w:%s -x:%s -o:%s -EOE - }; - } - - if ($reason_dir_unusable) { - # Replace with our local project tmpdir. This will make multiple runs - # from different runs conflict with each other, but is much better than - # polluting the root dir with random crap or failing outright - my $local_dir = _find_co_root()->subdir('t')->subdir('var'); - $local_dir->mkpath; - - warn "\n\nUsing '$local_dir' as test scratch-dir instead of '$dir': $reason_dir_unusable\n"; - $dir = $local_dir; - } - - $dir->stringify; - }); -} - - # Mimic $Module::Install::AUTHOR sub is_author { - return ( ! -d 'inc/Module' or diff --git a/t/lib/DBICTest/Util.pm b/t/lib/DBICTest/Util.pm index cbbce35..c8893c8 100644 --- a/t/lib/DBICTest/Util.pm +++ b/t/lib/DBICTest/Util.pm @@ -13,14 +13,14 @@ use constant DEBUG_TEST_CONCURRENCY_LOCKS => use Config; use Carp qw(cluck confess croak); -use Fcntl ':flock'; +use Fcntl qw( :DEFAULT :flock ); use Scalar::Util qw(blessed refaddr); -use DBIx::Class::_Util qw( scope_guard parent_dir ); +use DBIx::Class::_Util qw( scope_guard parent_dir mkdir_p ); use base 'Exporter'; our @EXPORT_OK = qw( dbg stacktrace - local_umask find_co_root + local_umask tmpdir find_co_root visit_namespaces check_customcond_args await_flock DEBUG_TEST_CONCURRENCY_LOCKS @@ -132,10 +132,103 @@ sub find_co_root () { unless -f "${root}Makefile.PL"; } - $root; + # at this point we are pretty sure this is the right thing - detaint + ($root =~ /(.+)/)[0]; } } +my $tempdir; +sub tmpdir () { + $tempdir ||= do { + + require File::Spec; + my $dir = File::Spec->tmpdir; + $dir .= '/' unless $dir =~ / [\/\\] $ /x; + + # the above works but not always, test it to bits + my $reason_dir_unusable; + + # PathTools has a bug where on MSWin32 it will often return / as a tmpdir. + # This is *really* stupid and the result of having our lockfiles all over + # the place is also rather obnoxious. So we use our own heuristics instead + # https://rt.cpan.org/Ticket/Display.html?id=76663 + my @parts = File::Spec->splitdir($dir); + + # deal with how 'C:\\\\\\\\\\\\\\' decomposes + pop @parts while @parts and ! length $parts[-1]; + + if ( + @parts < 2 + or + ( @parts == 2 and $parts[1] =~ /^ [\/\\] $/x ) + ) { + $reason_dir_unusable = + 'File::Spec->tmpdir returned a root directory instead of a designated ' + . 'tempdir (possibly https://rt.cpan.org/Ticket/Display.html?id=76663)'; + } + else { + # make sure we can actually create and sysopen a file in this dir + + my $fn = $dir . "_dbictest_writability_test_$$"; + + my $u = local_umask(0); # match the umask we use in DBICTest(::Schema) + my $g = scope_guard { unlink $fn }; + + eval { + + if (-e $fn) { + unlink $fn or die "Unable to unlink pre-existing $fn: $!\n"; + } + + sysopen (my $tmpfh, $fn, O_RDWR|O_CREAT) or die "Opening $fn failed: $!\n"; + + print $tmpfh 'deadbeef' x 1024 or die "Writing to $fn failed: $!\n"; + + close $tmpfh or die "Closing $fn failed: $!\n"; + + 1; + } + or + do { + chomp( my $err = $@ ); + + my @x_tests = map + { (defined $_) ? ( $_ ? 1 : 0 ) : 'U' } + map + { (-e, -d, -f, -r, -w, -x, -o)} + ($dir, $fn) + ; + + $reason_dir_unusable = sprintf <<"EOE", $fn, $err, scalar $>, scalar $), umask(), (stat($dir))[4,5,2], @x_tests; +File::Spec->tmpdir returned a directory which appears to be non-writeable: + +Error encountered while testing '%s': %s +Process EUID/EGID: %s / %s +Effective umask: %o +TmpDir UID/GID: %s / %s +TmpDir StatMode: %o +TmpDir X-tests: -e:%s -d:%s -f:%s -r:%s -w:%s -x:%s -o:%s +TmpFile X-tests: -e:%s -d:%s -f:%s -r:%s -w:%s -x:%s -o:%s +EOE + }; + } + + if ($reason_dir_unusable) { + # Replace with our local project tmpdir. This will make multiple tests + # from different runs conflict with each other, but is much better than + # polluting the root dir with random crap or failing outright + my $local_dir = find_co_root . 't/var/'; + + mkdir_p $local_dir; + + warn "\n\nUsing '$local_dir' as test scratch-dir instead of '$dir': $reason_dir_unusable\n\n"; + $dir = $local_dir; + } + + $dir; + }; +} + sub stacktrace { my $frame = shift;