From: Peter Rabbitson <ribasushi@cpan.org>
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?p=dbsrgits%2FDBIx-Class.git;a=commitdiff_plain;h=e3be2b6ff05d6794ccd8807af8cb494403690639

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