From: Peter Rabbitson <ribasushi@cpan.org>
Date: Sun, 5 Apr 2015 11:52:11 +0000 (+0200)
Subject: Rewrite dependency lister - now produces *much* easier to read output
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=83361151a7b2378ce3b7926a69f36d28fd937cb1;p=dbsrgits%2FDBIx-Class.git

Rewrite dependency lister - now produces *much* easier to read output

Knowing where a module came from is quite valuable, but the segmentation done
in cebc0cc8 makes it rather hard finding a particular module. Instead add
an extra prefix with shorthand "dirs of interest" names, and putput the entire
list in ci-alphabetical order.

Additionally make sure we explicitly print out our versions under CI (a silly
omission from earlier), and explicitly omit loading dist_* optdeps

The rough list of changes:
  - Explicitly report expected but failed-to-load modules
  - Add knowledge of './t' => T, under same rules as LIB
  - Add support for (site|vendor)lib_stem (whatever that is)
  - Add support for (site|vendor)prefix
  - Add support for ./blib/(lib|arch)
  - Add support for an explicit CWD marker
  - When no sourcing is found - report the @INC index if possible
  - If a module came from {SVP}{AL}, list it even if no version is defined
  - Explain missing checksums
  - Display the contents of @INC, making it even easier to follow sourcing

While the diff is massive, the actual logic did not change in any significant
way.
---

diff --git a/lib/DBIx/Class.pm b/lib/DBIx/Class.pm
index 6f0cb12..863cb19 100644
--- a/lib/DBIx/Class.pm
+++ b/lib/DBIx/Class.pm
@@ -11,7 +11,7 @@ our $VERSION;
 # $VERSION declaration must stay up here, ahead of any other package
 # declarations, as to not confuse various modules attempting to determine
 # this ones version, whether that be s.c.o. or Module::Metadata, etc
-$VERSION = '0.082899_01';
+$VERSION = '0.082899_15';
 
 $VERSION = eval $VERSION if $VERSION =~ /_/; # numify for warning-free dev releases
 
diff --git a/maint/travis-ci_scripts/30_before_script.bash b/maint/travis-ci_scripts/30_before_script.bash
index 2f61720..c4f0f62 100755
--- a/maint/travis-ci_scripts/30_before_script.bash
+++ b/maint/travis-ci_scripts/30_before_script.bash
@@ -144,8 +144,8 @@ else
 fi
 
 echo_err "$(tstamp) Dependency installation finished"
-# this will display list of available versions
-perl Makefile.PL
+
+run_or_err "Re-configure" "perl Makefile.PL"
 
 # make sure we got everything we need
 if [[ -n "$(make listdeps)" ]] ; then
diff --git a/maint/travis-ci_scripts/40_script.bash b/maint/travis-ci_scripts/40_script.bash
index 21a1d84..2daea0a 100755
--- a/maint/travis-ci_scripts/40_script.bash
+++ b/maint/travis-ci_scripts/40_script.bash
@@ -10,6 +10,9 @@ run_harness_tests() {
   make test 2> >(tee "$TEST_STDERR_LOG")
 }
 
+# announce everything we have on this box
+TRAVIS="" perl -Ilib t/00describe_environment.t >/dev/null
+
 TEST_T0=$SECONDS
 if [[ "$CLEANTEST" = "true" ]] ; then
   echo_err "$(tstamp) Running tests with plain \`make test\`"
diff --git a/t/00describe_environment.t b/t/00describe_environment.t
index fa3df9c..82f2fdb 100644
--- a/t/00describe_environment.t
+++ b/t/00describe_environment.t
@@ -3,8 +3,17 @@
 ### It certainly can be rewritten to degrade well on 5.6
 ###
 
+# Very important to grab the snapshot early, as we will be reporting
+# the INC indices from the POV of whoever ran the script, *NOT* from
+# the POV of the internals
+my @initial_INC;
+BEGIN {
+  @initial_INC = @INC;
+}
 
 BEGIN {
+  unshift @INC, 't/lib';
+
   if ($] < 5.010) {
 
     # Pre-5.10 perls pollute %INC on unsuccesfull module
@@ -22,7 +31,6 @@ BEGIN {
     # we want to do this here, in the very beginning, before even
     # warnings/strict are loaded
 
-    unshift @INC, 't/lib';
     require DBICTest::Util::OverrideRequire;
 
     DBICTest::Util::OverrideRequire::override_global_require( sub {
@@ -36,93 +44,120 @@ BEGIN {
   }
 }
 
-# Explicitly add 'lib' to the front of INC - this way we will
-# know without ambiguity what was loaded from the local untar
-# and what came from elsewhere
-use lib qw(lib t/lib);
-
 use strict;
 use warnings;
 
 use Test::More 'no_plan';
 use Config;
 use File::Find 'find';
-use Module::Runtime 'module_notional_filename';
-use List::Util qw(max min);
+use Digest::MD5 ();
+use Cwd 'abs_path';
+use File::Spec;
+use List::Util 'max';
 use ExtUtils::MakeMaker;
-use DBICTest::Util 'visit_namespaces';
-
-# load these two to pull in the t/lib armada
-use DBICTest;
-use DBICTest::Schema;
-
-# do !!!NOT!!! use Module::Runtime's require_module - it breaks CORE::require
-sub req_mod ($) {
-  # trap deprecation warnings and whatnot
-  local $SIG{__WARN__} = sub {};
-  local $@;
-  eval "require $_[0]";
-}
 
-sub say_err {
-  print STDERR "\n", @_, "\n";
-}
-
-# needed for WeirdOS
-sub fixup_path ($) {
-  return $_[0] unless ( $^O eq 'MSWin32' and $_[0] );
-
-  # sometimes we can get a short/longname mix, normalize everything to longnames
-  my $fn = Win32::GetLongPathName($_[0]);
-
-  # Fixup (native) slashes in Config not matching (unixy) slashes in INC
-  $fn =~ s|\\|/|g;
-
-  $fn;
-}
-
-my @lib_display_order = qw(
-  sitearch
-  sitelib
-  vendorarch
-  vendorlib
-  archlib
-  privlib
-);
-my $lib_paths = {
-  (map
-    { $Config{$_}
-      ? ( $_ => fixup_path( $Config{"${_}exp"} || $Config{$_} ) )
-      : ()
-    }
-    @lib_display_order
-  ),
+use DBICTest::RunMode;
+use DBICTest::Util 'visit_namespaces';
+use DBIx::Class::Optional::Dependencies;
 
-  # synthetic, for display
-  './lib' => 'lib',
+my $known_paths = {
+  SA => {
+    config_key => 'sitearch',
+  },
+  SL => {
+    config_key => 'sitelib',
+  },
+  SS => {
+    config_key => 'sitelib_stem',
+    match_order => 1,
+  },
+  SP => {
+    config_key => 'siteprefix',
+    match_order => 2,
+  },
+  VA => {
+    config_key => 'vendorarch',
+  },
+  VL => {
+    config_key => 'vendorlib',
+  },
+  VS => {
+    config_key => 'vendorlib_stem',
+    match_order => 3,
+  },
+  VP => {
+    config_key => 'vendorprefix',
+    match_order => 4,
+  },
+  PA => {
+    config_key => 'archlib',
+  },
+  PL => {
+    config_key => 'privlib',
+  },
+  PP => {
+    config_key => 'prefix',
+    match_order => 5,
+  },
+  BLA => {
+    rel_path => './blib/arch',
+    skip_unversioned_modules => 1,
+  },
+  BLL => {
+    rel_path => './blib/lib',
+    skip_unversioned_modules => 1,
+  },
+  INC => {
+    rel_path => './inc',
+  },
+  LIB => {
+    rel_path => './lib',
+    skip_unversioned_modules => 1,
+  },
+  T => {
+    rel_path => './t',
+    skip_unversioned_modules => 1,
+  },
+  CWD => {
+    rel_path => '.',
+  },
+  HOME => {
+    rel_path => '~',
+    abs_unix_path => abs_unix_path (
+      eval { require File::HomeDir and File::HomeDir->my_home }
+        ||
+      $ENV{USERPROFILE}
+        ||
+      $ENV{HOME}
+        ||
+      glob('~')
+    ),
+  },
 };
 
-sub describe_fn {
-  my $fn = shift;
+for my $k (keys %$known_paths) {
+  my $v = $known_paths->{$k};
 
-  return '' if !defined $fn;
+  # never use home as a found-in-dir marker - it is too broad
+  # HOME is only used by the shortener
+  $v->{marker} = $k unless $k eq 'HOME';
 
-  $fn = fixup_path( $fn );
-
-  $lib_paths->{$_} and $fn =~ s/^\Q$lib_paths->{$_}/<<$_>>/ and last
-    for @lib_display_order;
-
-  $fn;
-}
+  unless ( $v->{abs_unix_path} ) {
+    if ( $v->{rel_path} ) {
+      $v->{abs_unix_path} = abs_unix_path( $v->{rel_path} );
+    }
+    elsif ( $Config{ $v->{config_key} || '' } ) {
+      $v->{abs_unix_path} = abs_unix_path (
+        $Config{"$v->{config_key}exp"} || $Config{$v->{config_key}}
+      );
+    }
+  }
 
-sub md5_of_fn {
-  # we already checked for -r/-f, just bail if can't open
-  open my $fh, '<:raw', $_[0] or return '';
-  require Digest::MD5;
-  Digest::MD5->new->addfile($fh)->hexdigest;
+  delete $known_paths->{$k} unless $v->{abs_unix_path} and -d $v->{abs_unix_path};
 }
+my $seen_markers = {};
 
-# first run through lib and *try* to load anything we can find
+# first run through lib/ and *try* to load anything we can find
 # within our own project
 find({
   wanted => sub {
@@ -133,11 +168,13 @@ find({
     my ($mod) = $_ =~ /^ lib [\/\\] (.+) \.pm $/x
       or return;
 
-    req_mod join ('::', File::Spec->splitdir($mod));
+    try_module_require(join ('::', File::Spec->splitdir($mod)) )
   },
   no_chdir => 1,
 }, 'lib' );
 
+
+
 # now run through OptDeps and attempt loading everything else
 #
 # some things needs to be sorted before other things
@@ -148,7 +185,8 @@ my $load_weights = {
   # clashes with libssl, and will segfault everything coming after them
   "DBD::Oracle" => -999,
 };
-req_mod $_ for sort
+
+my @known_modules = sort
   { ($load_weights->{$b}||0) <=> ($load_weights->{$a}||0) }
   keys %{
     DBIx::Class::Optional::Dependencies->req_list_for([
@@ -156,17 +194,58 @@ req_mod $_ for sort
         # some DBDs are notoriously problematic to load
         # hence only show stuff based on test_rdbms which will
         # take into account necessary ENVs
-        { $_ !~ /^rdbms_/ }
+        { $_ !~ /^ (?: rdbms | dist )_ /x }
         keys %{DBIx::Class::Optional::Dependencies->req_group_list}
     ])
   }
 ;
 
+try_module_require($_) for @known_modules;
+
 my $has_versionpm = eval { require version };
 
-# at this point we've loaded everything we ever could, let's drill through
-# the *ENTIRE* symtable and build a map of versions
-my $version_list = { perl => $] };
+
+# At this point we've loaded everything we ever could, but some modules
+# (understandably) crapped out. For an even more thorough report, note
+# everthing present in @INC we excplicitly know about (via OptDeps)
+# *even though* it didn't load
+my $known_failed_loads;
+
+for my $mod (@known_modules) {
+  my $inc_key = module_notional_filename($mod);
+  next if defined $INC{$inc_key};
+
+  if (defined( my $idx = module_found_at_inc_index( $mod, \@INC ) ) ) {
+    $known_failed_loads->{$mod} = abs_unix_path( "$INC[$idx]/$inc_key" );
+  }
+
+}
+
+my $perl = 'perl';
+
+# This is a cool idea, but the line is too long even with shortening :(
+#
+#for my $i ( 1 .. $Config{config_argc} ) {
+#  my $conf_arg = $Config{"config_arg$i"};
+#  $conf_arg =~ s!
+#    \= (.+)
+#  !
+#    '=' . shorten_fn($1)
+#  !ex;
+#
+#  $perl .= " $conf_arg";
+#}
+
+my $interesting_modules = {
+  # pseudo module
+  $perl => {
+    version => $],
+    abs_unix_path => $^X,
+  }
+};
+
+
+# drill through the *ENTIRE* symtable and build a map of intereseting modules
 visit_namespaces( action => sub {
   no strict 'refs';
   my $pkg = shift;
@@ -177,181 +256,396 @@ visit_namespaces( action => sub {
   # private - not interested, including no further descent
   return 0 if $pkg =~ / (?: ^ | :: ) _ /x;
 
-  # not interested in no-VERSION-containing modules, nor synthetic classes
-  return 1 if (
-    ! defined ${"${pkg}::VERSION"}
-      or
-    ${"${pkg}::VERSION"} =~ /\Qset by base.pm/
-  );
-
-  # make sure a version can be extracted, be noisy when it doesn't work
-  # do this even if we are throwing away the result below in lieu of EUMM
-  my $mod_ver = eval { $pkg->VERSION };
-  if (my $err = $@) {
-    $err =~ s/^/  /mg;
-    say_err
-      "Calling `$pkg->VERSION` resulted in an exception, which should never "
-    . "happen - please file a bug with the distribution containing $pkg. "
-    . "Complete exception text below:\n\n$err"
-    ;
-  }
-  elsif( ! defined $mod_ver or ! length $mod_ver ) {
-    my $ret = defined $mod_ver
-      ? "the empty string ''"
-      : "'undef'"
-    ;
-
-    say_err
-      "Calling `$pkg->VERSION` returned $ret, even though \$${pkg}::VERSION "
-    . "is defined, which should never happen - please file a bug with the "
-    . "distribution containing $pkg."
-    ;
-
-    undef $mod_ver;
-  }
-
-  # if this is a real file - extract the version via EUMM whenever possible
-  my $fn = $INC{module_notional_filename($pkg)};
+  my $inc_key = module_notional_filename($pkg);
 
-  my $eumm_ver = (
-    $fn
+  my $abs_unix_path = (
+    $INC{$inc_key}
       and
-    -f $fn
+    -f $INC{$inc_key}
       and
-    -r $fn
+    -r $INC{$inc_key}
       and
-    eval { MM->parse_version( $fn ) }
-  ) || undef;
+    abs_unix_path($INC{$inc_key})
+  );
 
+  # handle versions first (not interested in synthetic classes)
   if (
-    $has_versionpm
+    defined ${"${pkg}::VERSION"}
       and
-    defined $eumm_ver
-      and
-    defined $mod_ver
-      and
-    $eumm_ver ne $mod_ver
-      and
-    (
-      ( eval { version->parse( do { (my $v = $eumm_ver) =~ s/_//g; $v } ) } || 0 )
-        !=
-      ( eval { version->parse( do { (my $v = $mod_ver) =~ s/_//g; $v } ) } || 0 )
-    )
+    ${"${pkg}::VERSION"} !~ /\Qset by base.pm/
   ) {
-    say_err
-      "Mismatch of versions '$mod_ver' and '$eumm_ver', obtained respectively "
-    . "via `$pkg->VERSION` and parsing the version out of @{[ describe_fn $fn ]} "
-    . "with ExtUtils::MakeMaker\@@{[ ExtUtils::MakeMaker->VERSION ]}. "
-    . "This should never happen - please check whether this is still present "
-    . "in the latest version, and then file a bug with the distribution "
-    . "containing $pkg."
-    ;
-  }
 
-  if( defined $eumm_ver ) {
-    $version_list->{$pkg} = $eumm_ver;
+    # make sure a version can be extracted, be noisy when it doesn't work
+    # do this even if we are throwing away the result below in lieu of EUMM
+    my $mod_ver = eval { $pkg->VERSION };
+
+    if (my $err = $@) {
+      $err =~ s/^/  /mg;
+      say_err (
+        "Calling `$pkg->VERSION` resulted in an exception, which should never "
+      . "happen - please file a bug with the distribution containing $pkg. "
+      . "Complete exception text below:\n\n$err"
+      );
+    }
+    elsif( ! defined $mod_ver or ! length $mod_ver ) {
+      my $ret = defined $mod_ver
+        ? "the empty string ''"
+        : "'undef'"
+      ;
+
+      say_err (
+        "Calling `$pkg->VERSION` returned $ret, even though \$${pkg}::VERSION "
+      . "is defined, which should never happen - please file a bug with the "
+      . "distribution containing $pkg."
+      );
+
+      undef $mod_ver;
+    }
+
+    if (
+      $abs_unix_path
+        and
+      defined ( my $eumm_ver = eval { MM->parse_version( $abs_unix_path ) } )
+    ) {
+
+      # can only run the check reliably if v.pm is there
+      if (
+        $has_versionpm
+          and
+        defined $mod_ver
+          and
+        $eumm_ver ne $mod_ver
+          and
+        (
+          ( eval { version->parse( do { (my $v = $eumm_ver) =~ s/_//g; $v } ) } || 0 )
+            !=
+          ( eval { version->parse( do { (my $v = $mod_ver) =~ s/_//g; $v } ) } || 0 )
+        )
+      ) {
+        say_err (
+          "Mismatch of versions '$mod_ver' and '$eumm_ver', obtained respectively "
+        . "via `$pkg->VERSION` and parsing the version out of @{[ shorten_fn( $abs_unix_path ) ]} "
+        . "with ExtUtils::MakeMaker\@@{[ ExtUtils::MakeMaker->VERSION ]}. "
+        . "This should never happen - please check whether this is still present "
+        . "in the latest version, and then file a bug with the distribution "
+        . "containing $pkg."
+        );
+      }
+
+      $interesting_modules->{$pkg}{version} = $eumm_ver;
+    }
+    elsif( defined $mod_ver ) {
+
+      $interesting_modules->{$pkg}{version} = $mod_ver;
+    }
   }
-  elsif( defined $mod_ver ) {
-    $version_list->{$pkg} = $mod_ver;
+  elsif ( $abs_unix_path = $known_failed_loads->{$pkg} ) {
+    $interesting_modules->{$pkg}{version} = '!! LOAD FAIL !!';
   }
 
-  1;
-});
+  if ($abs_unix_path) {
+    my ($marker, $initial_inc_idx);
 
-# In retrospect it makes little sense to omit this information - just
-# show everything at all times.
-# Nevertheless leave the dead code, in case it turns out to be a bad idea...
-my $show_all = 1;
-#my $show_all = $ENV{PERL_DESCRIBE_ALL_DEPS} || !DBICTest::RunMode->is_plain;
-
-# compress identical versions as close to the root as we can
-# unless we are dealing with a smoker - in which case we want
-# to see every MD5 there is
-unless ($show_all) {
-  for my $mod ( sort { length($b) <=> length($a) } keys %$version_list ) {
-    my $parent = $mod;
+    my $current_inc_idx = module_found_at_inc_index($pkg, \@INC);
+    my $p = subpath_of_known_path( $abs_unix_path );
 
-    while ( $parent =~ s/ :: (?: . (?! :: ) )+ $ //x ) {
-      $version_list->{$parent}
+    if (
+      defined $current_inc_idx
         and
-      $version_list->{$parent} eq $version_list->{$mod}
+      $p->{marker}
         and
-      ( ( delete $version_list->{$mod} ) or 1 )
+      abs_unix_path($INC[$current_inc_idx]) eq $p->{abs_unix_path}
+    ) {
+      $marker = $p->{marker};
+    }
+    elsif (defined ( $initial_inc_idx = module_found_at_inc_index($pkg, \@initial_INC) ) ) {
+      $marker = "\$INC[$initial_inc_idx]";
+    }
+
+    # we are only interested if there was a declared version already above
+    # OR if the module came from somewhere other than skip_unversioned_modules
+    if (
+      $marker
         and
-      last
+      (
+        $interesting_modules->{$pkg}
+          or
+        !$p->{skip_unversioned_modules}
+      )
+    ) {
+      $interesting_modules->{$pkg}{source_marker} = $marker;
+      $seen_markers->{$marker} = 1;
     }
+
+    # at this point only fill in the path (md5 calc) IFF it is interesting
+    # in any respect
+    $interesting_modules->{$pkg}{abs_unix_path} = $abs_unix_path
+      if $interesting_modules->{$pkg};
   }
-}
 
-ok 1, (scalar keys %$version_list) . " distinctly versioned modules";
+  1;
+});
+
+# compress identical versions sourced from ./blib, ./lib and ./t as close to the root
+# of a namespace as we can
+purge_identically_versioned_submodules_with_markers([ map {
+  ( $_->{skip_unversioned_modules} && $_->{marker} ) || ()
+} values %$known_paths ]);
+
+ok 1, (scalar keys %$interesting_modules) . " distinctly versioned modules found";
 
 # do not announce anything under ci - we are watching for STDERR silence
-exit if DBICTest::RunMode->is_ci;
+exit 0 if DBICTest::RunMode->is_ci;
+
+
+# diag the result out
+my $max_ver_len = max map
+  { length "$_" }
+  ( 'xxx.yyyzzz_bbb', map { $_->{version} || '' } values %$interesting_modules )
+;
+my $max_marker_len = max map { length $_ } ( '$INC[999]', keys %$seen_markers );
+
+my $discl = <<'EOD';
+
+List of loadable modules within both the core and *OPTIONAL* dependency
+chains present on this system (modules sourced from ./blib, ./lib and ./t
+with versions identical to their parent namespace were omitted for brevity)
+
+    *** Note that *MANY* of these modules will *NEVER* be loaded ***
+            *** during normal operation of DBIx::Class ***
+EOD
+
+# pre-assemble everything and print it in one shot
+# makes it less likely for parallel test execution to insert bogus lines
+my $final_out = "\n$discl\n";
+
+$final_out .= "\@INC at startup (does not reflect manipulation at runtime):\n";
 
-# sort stuff into @INC segments
-my $segments;
+my $in_inc_skip;
+for (0.. $#initial_INC) {
 
-MODULE:
-for my $mod ( sort { lc($a) cmp lc($b) } keys %$version_list ) {
-  my $fn = $INC{module_notional_filename($mod)};
+  my $path = shorten_fn( $initial_INC[$_] );
 
-  my $tuple = [ $mod ];
+  # when *to* print
+  if (
+    ! $ENV{AUTOMATED_TESTING}
+      or
+    @initial_INC < 11
+      or
+    $seen_markers->{"\$INC[$_]"}
+      or
+    ! -e $path
+      or
+    ! File::Spec->file_name_is_absolute($path)
+  ) {
+    $in_inc_skip = 0;
+    $final_out .= sprintf ( "% 3s: %s\n",
+      $_,
+      $path
+    );
+  }
+  elsif(! $in_inc_skip++) {
+    $final_out .= "  ...\n";
+  }
+}
+
+$final_out .= "\n";
 
-  if ( defined $fn && -f $fn && -r $fn ) {
-    push @$tuple, ( $fn = fixup_path($fn) );
+if (my @seen_known_paths = grep { $known_paths->{$_} } keys %$seen_markers) {
 
-    for my $lib (@lib_display_order, './lib') {
-      if ( $lib_paths->{$lib} and index($fn, $lib_paths->{$lib}) == 0 ) {
-        push @{$segments->{$lib}}, $tuple;
-        next MODULE;
+  $final_out .= join "\n", 'Sourcing markers:', (map
+    {
+      sprintf "%*s: %s",
+        $max_marker_len => $_->{marker},
+        ($_->{config_key} ? "\$Config{$_->{config_key}}" : "$_->{rel_path}/" )
+    }
+    sort
+      {
+        !!$b->{config_key} cmp !!$a->{config_key}
+          or
+        ( $a->{marker}||'') cmp ($b->{marker}||'')
       }
+      @{$known_paths}{@seen_known_paths}
+  ), '', '';
+
+}
+
+$final_out .= "=============================\n";
+
+$final_out .= join "\n", (map
+  { sprintf (
+    "%*s  %*s  %*s%s",
+    $max_marker_len => $interesting_modules->{$_}{source_marker} || '',
+    $max_ver_len => ( defined $interesting_modules->{$_}{version}
+      ? $interesting_modules->{$_}{version}
+      : ''
+    ),
+    -78 => $_,
+    ($interesting_modules->{$_}{abs_unix_path}
+      ? "  [ MD5: @{[ get_md5( $interesting_modules->{$_}{abs_unix_path} ) ]} ]"
+      : "! -f \$INC{'@{[ module_notional_filename($_) ]}'}"
+    ),
+  ) }
+  sort { lc($a) cmp lc($b) } keys %$interesting_modules
+), '';
+
+$final_out .= "=============================\n$discl\n\n";
+
+diag $final_out;
+
+exit 0;
+
+
+
+sub say_err { print STDERR "\n", @_, "\n\n" };
+
+# do !!!NOT!!! use Module::Runtime's require_module - it breaks CORE::require
+sub try_module_require {
+  # trap deprecation warnings and whatnot
+  local $SIG{__WARN__} = sub {};
+  local $@;
+  eval "require $_[0]";
+}
+
+sub abs_unix_path {
+  return '' unless (
+    defined $_[0]
+      and
+    ( -e $_[0] or File::Spec->file_name_is_absolute($_[0]) )
+  );
+
+  # File::Spec's rel2abs does not resolve symlinks
+  # we *need* to look at the filesystem to be sure
+  my $abs_fn = abs_path($_[0]);
+
+  if ( $^O eq 'MSWin32' and $abs_fn ) {
+
+    # sometimes we can get a short/longname mix, normalize everything to longnames
+    $abs_fn = Win32::GetLongPathName($abs_fn);
+
+    # Fixup (native) slashes in Config not matching (unixy) slashes in INC
+    $abs_fn =~ s|\\|/|g;
+  }
+
+  $abs_fn;
+}
+
+sub shorten_fn {
+  my $fn = shift;
+
+  my $abs_fn = abs_unix_path($fn);
+
+  if (my $p = subpath_of_known_path( $fn ) ) {
+    $abs_fn =~ s| (?<! / ) $|/|x
+      if -d $abs_fn;
+
+    if ($p->{rel_path}) {
+      $abs_fn =~ s!\Q$p->{abs_unix_path}!$p->{rel_path}!
+        and return $abs_fn;
+    }
+    elsif ($p->{config_key}) {
+      $abs_fn =~ s!\Q$p->{abs_unix_path}!<<$p->{marker}>>!
+        and
+      $seen_markers->{$p->{marker}} = 1
+        and
+      return $abs_fn;
     }
   }
 
-  # fallthrough for anything without a physical filename, or unknown lib
-  push @{$segments->{''}}, $tuple;
+  # we got so far - not a known path
+  # return the unixified version it if was absolute, leave as-is otherwise
+  return ( $abs_fn and File::Spec->file_name_is_absolute( $fn ) )
+    ? $abs_fn
+    : $fn
+  ;
 }
 
-# diag the result out
-my $max_ver_len = max map
-  { length $_ }
-  ( values %$version_list, 'xxx.yyyzzz_bbb' )
-;
-my $max_mod_len = max map { length $_ } keys %$version_list;
+sub subpath_of_known_path {
+  my $abs_fn = abs_unix_path( $_[0] )
+    or return '';
 
-my $discl = <<'EOD';
+  for my $p (
+    sort {
+      length( $b->{abs_unix_path} ) <=> length( $a->{abs_unix_path} )
+        or
+      ( $a->{match_order} || 0 ) <=> ( $b->{match_order} || 0 )
+    }
+    values %$known_paths
+  ) {
+    # run through the matcher twice - first always append a /
+    # then try without
+    # important to avoid false positives
+    for my $suff ( '/', '' ) {
+      return { %$p } if 0 == index( $abs_fn, "$p->{abs_unix_path}$suff" );
+    }
+  }
+}
 
-Versions of all loadable modules within both the core and *OPTIONAL* dependency chains present on this system
-Note that *MANY* of these modules will *NEVER* be loaded during normal operation of DBIx::Class
-EOD
+sub module_found_at_inc_index {
+  my ($mod, $inc_dirs) = @_;
 
-$discl .= "(modules with versions identical to their parent namespace were omitted - set PERL_DESCRIBE_ALL_DEPS to see them)\n"
-  unless $show_all;
+  return undef unless @$inc_dirs;
 
-diag $discl;
+  my $fn = module_notional_filename($mod);
 
-diag "\n";
+  for my $i ( 0 .. $#$inc_dirs ) {
 
-for my $seg ( '', @lib_display_order, './lib' ) {
-  next unless $segments->{$seg};
+    # searching from here on out won't mean anything
+    # FIXME - there is actually a way to interrogate this safely, but
+    # that's a fight for another day
+    return undef if length ref $inc_dirs->[$i];
 
-  diag sprintf "=== %s ===\n\n",
-    $seg
-      ? "Modules found in " . ( $Config{$seg} ? "\$Config{$seg}" : $seg )
-      : 'Misc versions'
-  ;
+    if (
+      -d $inc_dirs->[$i]
+        and
+      -f "$inc_dirs->[$i]/$fn"
+        and
+      -r "$inc_dirs->[$i]/$fn"
+    ) {
+      return $i;
+    }
+  }
 
-  diag sprintf (
-    "%*s  %*s%s\n",
-    $max_ver_len => $version_list->{$_->[0]},
-    -$max_mod_len => $_->[0],
-    ($_->[1]
-      ? ' ' x (80 - min(78, $max_mod_len)) . "[ MD5: @{[ md5_of_fn( $_->[1] ) ]} ]"
-      : ''
-    ),
-  ) for @{$segments->{$seg}};
+  return undef;
+}
+
+sub purge_identically_versioned_submodules_with_markers {
+  my $markers = shift;
+
+  return unless @$markers;
+
+  for my $mod ( sort { length($b) <=> length($a) } keys %$interesting_modules ) {
+
+    next unless defined $interesting_modules->{$mod}{version};
+
+    my $marker = $interesting_modules->{$mod}{source_marker}
+      or next;
+
+    next unless grep { $marker eq $_ } @$markers;
+
+    my $parent = $mod;
+
+    while ( $parent =~ s/ :: (?: . (?! :: ) )+ $ //x ) {
+      $interesting_modules->{$parent}
+        and
+      ($interesting_modules->{$parent}{version}||'') eq $interesting_modules->{$mod}{version}
+        and
+      ($interesting_modules->{$parent}{source_marker}||'') eq $interesting_modules->{$mod}{source_marker}
+        and
+    delete $interesting_modules->{$mod}
+        and
+      last
+    }
+  }
+}
 
-  diag "\n\n"
+sub module_notional_filename {
+  (my $fn = $_[0] . '.pm') =~ s|::|/|g;
+  $fn;
 }
 
-diag "$discl\n";
+sub get_md5 {
+  # we already checked for -r/-f, just bail if can't open
+  open my $fh, '<:raw', $_[0] or return '';
+  Digest::MD5->new->addfile($fh)->hexdigest;
+}