From: Peter Rabbitson Date: Sun, 28 Feb 2016 12:37:46 +0000 (+0100) Subject: Move find_co_root into DBICTest::Util X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=e3be2b6ff05d6794ccd8807af8cb494403690639;p=dbsrgits%2FDBIx-Class-Historic.git Move find_co_root into DBICTest::Util This is the first step of rearranging the utility pieces, removing reliance on Path::Class in general No visible functional changes, the old sub _find_co_root left as-is for the time being, with an eval wrapped around it to retain the old "best effort" behavior. Will be revisited in subsequent commits. --- diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm index 4afa4c2..846920d 100644 --- a/lib/DBIx/Class/_Util.pm +++ b/lib/DBIx/Class/_Util.pm @@ -82,6 +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 UNRESOLVABLE_CONDITION ); @@ -409,6 +410,48 @@ sub modver_gt_or_eq_and_lt ($$$) { ) ? 1 : 0; } + +# +# Why not just use some higher-level module or at least File::Spec here? +# Because: +# 1) This is a *very* rarely used function, and the deptree is large +# enough already as it is +# +# 2) (more importantly) Our tooling is utter shit in this area. There +# is no comprehensive support for UNC paths in PathTools and there +# are also various small bugs in representation across different +# path-manipulation CPAN offerings. +# +# Since this routine is strictly used for logical path processing (it +# *must* be able to work with not-yet-existing paths), use this seemingly +# simple but I *think* complete implementation to feed to other consumers +# +# If bugs are ever uncovered in this routine, *YOU ARE URGED TO RESIST* +# the impulse to bring in an external dependency. During runtime there +# is exactly one spot that could potentially maybe once in a blue moon +# use this function. Keep it lean. +# +sub parent_dir ($) { + ( $_[0] =~ m{ [\/\\] ( \.{0,2} ) ( [\/\\]* ) \z }x ) + ? ( + $_[0] + . + ( ( length($1) and ! length($2) ) ? '/' : '' ) + . + '../' + ) + : ( + require File::Spec + and + File::Spec->catpath ( + ( File::Spec->splitpath( "$_[0]" ) )[0,1], + '/', + ) + ) + ; +} + + { my $list_ctx_ok_stack_marker; diff --git a/t/lib/DBICTest/RunMode.pm b/t/lib/DBICTest/RunMode.pm index 93f917c..590abde 100644 --- a/t/lib/DBICTest/RunMode.pm +++ b/t/lib/DBICTest/RunMode.pm @@ -66,7 +66,11 @@ use Path::Class qw/file dir/; use Fcntl ':DEFAULT'; use File::Spec (); use File::Temp (); -use DBICTest::Util 'local_umask'; +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() ) } } _check_author_makefile() unless $ENV{DBICTEST_NO_MAKEFILE_VERIFICATION}; @@ -271,28 +275,4 @@ sub is_plain { ) } -# Try to determine the root of a checkout/untar if possible -# or return undef -sub _find_co_root { - - my @mod_parts = split /::/, (__PACKAGE__ . '.pm'); - my $rel_path = join ('/', @mod_parts); # %INC stores paths with / regardless of OS - - return undef unless ($INC{$rel_path}); - - # a bit convoluted, but what we do here essentially is: - # - get the file name of this particular module - # - do 'cd ..' as many times as necessary to get to t/lib/../.. - - my $root = dir ($INC{$rel_path}); - for (1 .. @mod_parts + 2) { - $root = $root->parent; - } - - return (-f $root->file ('Makefile.PL') ) - ? $root - : undef - ; -} - 1; diff --git a/t/lib/DBICTest/Util.pm b/t/lib/DBICTest/Util.pm index 37c7916..27f7527 100644 --- a/t/lib/DBICTest/Util.pm +++ b/t/lib/DBICTest/Util.pm @@ -13,12 +13,12 @@ use Config; use Carp qw(cluck confess croak); use Fcntl ':flock'; use Scalar::Util qw(blessed refaddr); -use DBIx::Class::_Util 'scope_guard'; +use DBIx::Class::_Util qw( scope_guard parent_dir ); use base 'Exporter'; our @EXPORT_OK = qw( dbg stacktrace - local_umask + local_umask find_co_root visit_namespaces check_customcond_args await_flock DEBUG_TEST_CONCURRENCY_LOCKS @@ -98,6 +98,43 @@ sub local_umask ($) { }); } +# Try to determine the root of a checkout/untar if possible +# OR throws an exception +my $co_root; +sub find_co_root () { + + $co_root ||= do { + + my @mod_parts = split /::/, (__PACKAGE__ . '.pm'); + my $inc_key = join ('/', @mod_parts); # %INC stores paths with / regardless of OS + + # a bit convoluted, but what we do here essentially is: + # - get the file name of this particular module + # - do 'cd ..' as many times as necessary to get to t/lib/../.. + + my $root = $INC{$inc_key} + or croak "\$INC{'$inc_key'} seems to be missing, this can't happen..."; + + $root = parent_dir $root + for 1 .. @mod_parts + 2; + + # do the check twice so that the exception is more informative in the + # very unlikely case of realpath returning garbage + # (Paththools are in really bad shape - handholding all the way down) + for my $call_realpath (0,1) { + + require Cwd and $root = ( Cwd::realpath($root) . '/' ) + if $call_realpath; + + croak "Unable to find root of DBIC checkout/untar: '${root}Makefile.PL' does not exist" + unless -f "${root}Makefile.PL"; + } + + $root; + } +} + + sub stacktrace { my $frame = shift; $frame++; diff --git a/xt/extra/lean_startup.t b/xt/extra/lean_startup.t index 8c220dd..2a5c8d5 100644 --- a/xt/extra/lean_startup.t +++ b/xt/extra/lean_startup.t @@ -110,6 +110,7 @@ BEGIN { Sub::Defer Sub::Quote + File::Spec Scalar::Util List::Util Storable