From: Peter Rabbitson <ribasushi@cpan.org>
Date: Mon, 6 Apr 2015 11:38:40 +0000 (+0200)
Subject: Further enhance 00describe_environment.t:
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=3cd1b1723f82f37c7db3b0c60f7f981e9b3fac5a;p=dbsrgits%2FDBIx-Class-Historic.git

Further enhance 00describe_environment.t:

- Explicitly report expected but failed-to-load modules
- Add knowledge of './t' => T, under same rules as LIB
- 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
---

diff --git a/t/00describe_environment.t b/t/00describe_environment.t
index 7f7d108..64b2d8e 100644
--- a/t/00describe_environment.t
+++ b/t/00describe_environment.t
@@ -3,7 +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
@@ -21,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 {
@@ -35,18 +44,14 @@ 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 Digest::MD5 ();
+use Cwd 'abs_path';
 use List::Util qw(max min);
 use ExtUtils::MakeMaker;
 use DBICTest::Util 'visit_namespaces';
@@ -55,7 +60,6 @@ use DBICTest::Util 'visit_namespaces';
 use DBICTest;
 use DBICTest::Schema;
 
-
 my $known_libpaths = {
   SA => {
     config_key => 'sitearch',
@@ -81,6 +85,9 @@ my $known_libpaths = {
   LIB => {
     relpath => './lib',
   },
+  T => {
+    relpath => './t',
+  },
   HOME => {
     relpath => '~',
     full_path => full_path (
@@ -98,7 +105,7 @@ for my $k (keys %$known_libpaths) {
 
   # never use home as a found-in-dir marker - it is too broad
   # HOME is only used by the shortener
-  $v->{abbrev} = $k unless $k eq 'HOME';
+  $v->{marker} = $k unless $k eq 'HOME';
 
   unless ( $v->{full_path} ) {
     if ( $v->{relpath} ) {
@@ -113,7 +120,7 @@ for my $k (keys %$known_libpaths) {
 
   delete $known_libpaths->{$k} unless $v->{full_path} and -d $v->{full_path};
 }
-
+my $seen_known_markers;
 
 # first run through lib/ and *try* to load anything we can find
 # within our own project
@@ -143,7 +150,8 @@ my $load_weights = {
   # clashes with libssl, and will segfault everything coming after them
   "DBD::Oracle" => -999,
 };
-try_module_require($_) for sort
+
+my @known_modules = sort
   { ($load_weights->{$b}||0) <=> ($load_weights->{$a}||0) }
   keys %{
     DBIx::Class::Optional::Dependencies->req_list_for([
@@ -157,14 +165,52 @@ try_module_require($_) for sort
   }
 ;
 
+try_module_require($_) for @known_modules;
 
-# at this point we've loaded everything we ever could, let's drill through
-# the *ENTIRE* symtable and build a map of versions
 my $has_versionpm = eval { require version };
-my $versioned_modules = {
-  perl => { version => $], full_path => $^X }
+
+
+# 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} = full_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(full_path($1) )
+#  !ex;
+#
+#  $perl .= " $conf_arg";
+#}
+
+my $interesting_modules = {
+  # pseudo module
+  $perl => {
+    version => $],
+    full_path => $^X,
+  }
 };
-my $seen_known_libs;
+
+
+# drill through the *ENTIRE* symtable and build a map of intereseting modules
 visit_namespaces( action => sub {
   no strict 'refs';
   my $pkg = shift;
@@ -175,180 +221,204 @@ 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 $full_path;
-
-  my $eumm_ver = (
-    $fn
-      and
-    -f $fn
+  my $full_path = (
+    $INC{$inc_key}
       and
-    -r $fn
+    -f $INC{$inc_key}
       and
-    $full_path = full_path($fn)
+    -r $INC{$inc_key}
       and
-    eval { MM->parse_version( $fn ) }
-  ) || undef;
+    full_path($INC{$inc_key})
+  );
 
+  # handle versions first (not interested in synthetic classes)
   if (
-    $has_versionpm
-      and
-    defined $eumm_ver
-      and
-    defined $mod_ver
+    defined ${"${pkg}::VERSION"}
       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 @{[ shorten_fn( $full_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."
-    );
-  }
 
-  if( defined $eumm_ver ) {
-    $versioned_modules->{$pkg} = { version => $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 (
+      $full_path
+        and
+      defined ( my $eumm_ver = eval { MM->parse_version( $full_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( $full_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 ) {
-    $versioned_modules->{$pkg} = { version => $mod_ver };
+  elsif ( $full_path = $known_failed_loads->{$pkg} ) {
+    $interesting_modules->{$pkg}{version} = '!! LOAD FAILED !!';
   }
 
-  # add the path and a "where-from" marker if any
-  if ( $full_path and my $slot = $versioned_modules->{$pkg} ) {
-    $slot->{full_path} = $full_path;
+  if ($full_path) {
+    my $marker;
+    if (my $m = ( matching_known_lib( $full_path ) || {} )->{marker} ) {
+      $marker = $m;
+    }
+    elsif (defined ( my $idx = module_found_at_inc_index($pkg, \@initial_INC) ) ) {
+      $marker = sprintf '$INC[%d]', $idx;
+    }
 
-    if ( my $abbr = ( matching_known_lib( $full_path ) || {} )->{abbrev} ) {
-      $slot->{from_known_lib} = $abbr;
-      $seen_known_libs->{$abbr} = 1;
+    # we are only interested if there was a declared version already above
+    # OR if the module came from somewhere other than T or LIB
+    if (
+      $marker
+        and
+      (
+        $interesting_modules->{$pkg}
+          or
+        $marker !~ /^ (?: T | LIB ) $/x
+      )
+    ) {
+      $interesting_modules->{$pkg}{source_marker} = $marker;
+      $seen_known_markers->{$marker} = 1
+        if $known_libpaths->{$marker};
     }
+
+    # at this point only fill in the path (md5 calc) IFF it is interesting
+    # in any respect
+    $interesting_modules->{$pkg}{full_path} = $full_path
+      if $interesting_modules->{$pkg};
   }
 
   1;
 });
 
-# compress identical versions sourced from ./lib as close to the root as we can
-for my $mod ( sort { length($b) <=> length($a) } keys %$versioned_modules ) {
-  ($versioned_modules->{$mod}{from_known_lib}||'') eq 'LIB'
-    or next;
-
-  my $parent = $mod;
-
-  while ( $parent =~ s/ :: (?: . (?! :: ) )+ $ //x ) {
-    $versioned_modules->{$parent}
-      and
-    $versioned_modules->{$parent}{version} eq $versioned_modules->{$mod}{version}
-      and
-    ($versioned_modules->{$parent}{from_known_lib}||'') eq 'LIB'
-      and
-    delete $versioned_modules->{$mod}
-      and
-    last
-  }
-}
+# compress identical versions sourced from ./lib and ./t as close to the root
+# of a namespace as we can
+purge_identically_versioned_submodules_with_markers([qw( LIB T )]);
 
-ok 1, (scalar keys %$versioned_modules) . " distinctly versioned modules found";
+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 %$versioned_modules )
+  ( 'xxx.yyyzzz_bbb', map { $_->{version} || '' } values %$interesting_modules )
 ;
-my $max_mod_len = max map { length $_ } keys %$versioned_modules;
-my $max_marker_len = max map { length $_ } keys %{ $seen_known_libs || {} };
+my $max_mod_len = max map { length $_ } keys %$interesting_modules;
+my $max_marker_len = max map { length $_ } ( '$INC[99]', keys %{ $seen_known_markers || {} } );
 
 my $discl = <<'EOD';
 
-List of loadable modules specifying a version within both the core and *OPTIONAL* dependency chains present on this system
+List of 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
-(modules sourced from ./lib with versions identical to their parent namespace were omitted for brevity)
+(modules sourced from ./lib and ./t with versions identical to their parent namespace were omitted for brevity)
 EOD
 
-diag "\n$discl\n";
+# 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";
 
-if ($seen_known_libs) {
-  diag "Sourcing markers:\n";
 
-  diag $_ for
-    map
+if ($seen_known_markers) {
+
+  $final_out .= join "\n", 'Sourcing markers:', (map
+    {
+      sprintf "%*s: %s",
+        $max_marker_len => $_->{marker},
+        ($_->{config_key} ? "\$Config{$_->{config_key}}" : "$_->{relpath}/*" )
+    }
+    sort
       {
-        sprintf "  %*s: %s",
-          $max_marker_len => $_->{abbrev},
-          ($_->{config_key} ? "\$Config{$_->{config_key}}" : $_->{relpath} )
+        !!$b->{config_key} cmp !!$a->{config_key}
+          or
+        ( $a->{marker}||'') cmp ($b->{marker}||'')
       }
-      @{$known_libpaths}{ sort keys %$seen_known_libs }
-  ;
+      @{$known_libpaths}{keys %$seen_known_markers}
+  ), '', '';
 
-  diag "\n";
 }
 
-diag "=============================\n";
+$final_out .= "=============================\n";
 
-diag sprintf (
-  "%*s  %*s  %*s%s\n",
-  $max_marker_len+2 => $versioned_modules->{$_}{from_known_lib} || '',
-  $max_ver_len => $versioned_modules->{$_}{version},
-  -$max_mod_len => $_,
-  ($versioned_modules->{$_}{full_path}
-    ? ' ' x (80 - min(78, $max_mod_len)) . "[ MD5: @{[ get_md5( $versioned_modules->{$_}{full_path} ) ]} ]"
-    : ''
-  ),
-) for sort { lc($a) cmp lc($b) } keys %$versioned_modules;
+$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}
+      : ''
+    ),
+    $_,
+    ($interesting_modules->{$_}{full_path}
+      ? ' ' x (80 - min( 78, length($_) )) . "[ MD5: @{[ get_md5( $interesting_modules->{$_}{full_path} ) ]} ]"
+      : ''
+    ),
+  ) }
+  sort { lc($a) cmp lc($b) } keys %$interesting_modules
+), '';
+
+$final_out .= "=============================\n$discl\n\n";
 
-diag "=============================\n$discl\n";
+diag $final_out;
 
 exit 0;
 
 
 
-sub say_err { print STDERR "\n", @_, "\n" };
+sub say_err { print STDERR @_, "\n\n" };
 
 # do !!!NOT!!! use Module::Runtime's require_module - it breaks CORE::require
 sub try_module_require {
@@ -361,7 +431,9 @@ sub try_module_require {
 sub full_path {
   return '' unless ( defined $_[0] and -e $_[0] );
 
-  my $fn = Cwd::abs_path($_[0]);
+  # File::Spec's rel2abs does not resolve symlinks
+  # we *need* to look at the filesystem to be sure
+  my $fn = abs_path($_[0]);
 
   if ( $^O eq 'MSWin32' and $fn ) {
 
@@ -382,10 +454,12 @@ sub shorten_fn {
     or return $fn;
 
   if ($l->{relpath}) {
-    $fn =~ s/\Q$l->{full_path}\E/$l->{relpath}/;
+    $fn =~ s!\Q$l->{full_path}!$l->{relpath}!;
   }
   elsif ($l->{config_key}) {
-    $fn =~ s/\Q$l->{full_path}\E/<<$l->{config_key}>>/;
+    $fn =~ s!\Q$l->{full_path}!<<$l->{marker}>>!
+      and
+    $seen_known_markers->{$l->{marker}} = 1;
   }
 
   $fn;
@@ -399,13 +473,75 @@ sub matching_known_lib {
     sort { length( $b->{full_path} ) <=> length( $a->{full_path} ) }
     values %$known_libpaths
   ) {
-    return { %$l } if 0 == index( $fn, $l->{full_path} );
+    # run through the matcher twice - first always append a /
+    # then try without
+    # important to avoid false positives
+    for my $suff ( '/', '' ) {
+      return { %$l } if 0 == index( $fn, "$l->{full_path}$suff" );
+    }
   }
 }
 
+sub module_found_at_inc_index {
+  my ($mod, $dirs) = @_;
+
+  my $fn = module_notional_filename($mod);
+
+  for my $i ( 0 .. $#$dirs ) {
+    # searching from here on out won't mean anything
+    return undef if length ref $dirs->[$i];
+
+    if (
+      -d $dirs->[$i]
+        and
+      -f "$dirs->[$i]/$fn"
+        and
+      -r "$dirs->[$i]/$fn"
+    ) {
+      return $i;
+    }
+  }
+
+  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
+    }
+  }
+}
+
+sub module_notional_filename {
+  (my $fn = $_[0] . '.pm') =~ s|::|/|g;
+  $fn;
+}
+
 sub get_md5 {
   # 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;
 }