t/00describe_environment.t

   1 ###
   2 ### This version is rather 5.8-centric, because DBIC itself is 5.8
   3 ### It certainly can be rewritten to degrade well on 5.6
   4 ###
   5
   6
   7 BEGIN {
   8   if ($] < 5.010) {
   9
  10     # Pre-5.10 perls pollute %INC on unsuccesfull module
  11     # require, making it appear as if the module is already
  12     # loaded on subsequent require()s
  13     # Can't seem to find the exact RT/perldelta entry
  14     #
  15     # The reason we can't just use a sane, clean loader, is because
  16     # if a Module require()s another module the %INC will still
  17     # get filled with crap and we are back to square one. A global
  18     # fix is really the only way for this test, as we try to load
  19     # each available module separately, and have no control (nor
  20     # knowledge) over their common dependencies.
  21     #
  22     # we want to do this here, in the very beginning, before even
  23     # warnings/strict are loaded
  24
  25     unshift @INC, 't/lib';
  26     require DBICTest::Util::OverrideRequire;
  27
  28     DBICTest::Util::OverrideRequire::override_global_require( sub {
  29       my $res = eval { $_[0]->() };
  30       if ($@ ne '') {
  31         delete $INC{$_[1]};
  32         die $@;
  33       }
  34       return $res;
  35     } );
  36   }
  37 }
  38
  39 # Explicitly add 'lib' to the front of INC - this way we will
  40 # know without ambiguity what was loaded from the local untar
  41 # and what came from elsewhere
  42 use lib qw(lib t/lib);
  43
  44 use strict;
  45 use warnings;
  46
  47 use Test::More 'no_plan';
  48 use Config;
  49 use File::Find 'find';
  50 use Module::Runtime 'module_notional_filename';
  51 use List::Util 'max';
  52 use ExtUtils::MakeMaker;
  53 use DBICTest::Util 'visit_namespaces';
  54
  55 # load these two to pull in the t/lib armada
  56 use DBICTest;
  57 use DBICTest::Schema;
  58 DBICTest->init_schema;
  59
  60 # do !!!NOT!!! use Module::Runtime's require_module - it breaks CORE::require
  61 sub req_mod ($) {
  62   # trap deprecation warnings and whatnot
  63   local $SIG{__WARN__} = sub {};
  64   local $@;
  65   eval "require $_[0]";
  66 }
  67
  68 sub say_err {
  69   print STDERR "\n", @_, "\n";
  70 }
  71
  72 my @lib_display_order = qw(
  73   sitearch
  74   sitelib
  75   vendorarch
  76   vendorlib
  77   archlib
  78   privlib
  79 );
  80 my $lib_paths = {
  81   (map
  82     { $Config{$_} ? ( $_ => $Config{"${_}exp"} || $Config{$_} ) : () }
  83     @lib_display_order
  84   ),
  85
  86   # synthetic, for display
  87   './lib' => 'lib',
  88 };
  89
  90 sub describe_fn {
  91   my $fn = shift;
  92
  93   $lib_paths->{$_} and $fn =~ s/^\Q$lib_paths->{$_}/<<$_>>/ and last
  94     for @lib_display_order;
  95
  96   $fn;
  97 }
  98
  99 sub md5_of_fn {
 100   # we already checked for -r/-f, just bail if can't open
 101   open my $fh, '<:raw', $_[0] or return '';
 102   require Digest::MD5;
 103   Digest::MD5->new->addfile($fh)->hexdigest;
 104 }
 105
 106 # first run through lib and *try* to load anything we can find
 107 # within our own project
 108 find({
 109   wanted => sub {
 110     -f $_ or return;
 111
 112     # can't just `require $fn`, as we need %INC to be
 113     # populated properly
 114     my ($mod) = $_ =~ /^ lib [\/\\] (.+) \.pm $/x
 115       or return;
 116
 117     req_mod join ('::', File::Spec->splitdir($mod));
 118   },
 119   no_chdir => 1,
 120 }, 'lib' );
 121
 122 # now run through OptDeps and attempt loading everything else
 123 #
 124 # some things needs to be sorted before other things
 125 # positive - load first
 126 # negative - load last
 127 my $load_weights = {
 128   # Make sure oracle is tried last - some clients (e.g. 10.2) have symbol
 129   # clashes with libssl, and will segfault everything coming after them
 130   "DBD::Oracle" => -999,
 131 };
 132
 133 my $optdeps = {
 134   map
 135     { $_ => 1 }
 136     map
 137       { keys %{DBIx::Class::Optional::Dependencies->req_list_for($_)} }
 138       grep
 139         { $_ !~ /rdbms/ }
 140         keys %{DBIx::Class::Optional::Dependencies->req_group_list}
 141 };
 142 req_mod $_ for sort
 143   { ($load_weights->{$b}||0) <=> ($load_weights->{$a}||0) }
 144   keys %$optdeps
 145 ;
 146
 147 my $has_versionpm = eval { require version };
 148
 149 # at this point we've loaded everything we ever could, let's drill through
 150 # the *ENTIRE* symtable and build a map of versions
 151 my $version_list = { perl => $] };
 152 visit_namespaces( action => sub {
 153   my $pkg = shift;
 154
 155   # keep going, but nothing to see here
 156   return 1 if $pkg eq 'main';
 157
 158   # private - not interested
 159   return 0 if $pkg =~ / (?: ^ | :: ) _ /x;
 160
 161   no strict 'refs';
 162   # that would be some synthetic class, or a custom sub VERSION
 163   return 1 if (
 164     ! defined ${"${pkg}::VERSION"}
 165       or
 166     ${"${pkg}::VERSION"} =~ /\Qset by base.pm/
 167   );
 168
 169   # make sure a version can be extracted, be noisy when it doesn't work
 170   # do this even if we are throwing away the result below in lieu of EUMM
 171   my $mod_ver = eval { $pkg->VERSION };
 172   if (my $err = $@) {
 173     $err =~ s/^/  /mg;
 174     say_err
 175       "Calling `$pkg->VERSION` resulted in an exception, which should never "
 176     . "happen - please file a bug with the distribution containing $pkg. "
 177     . "Follows the full text of the exception:\n\n$err\n"
 178     ;
 179   }
 180   elsif( ! defined $mod_ver ) {
 181     say_err
 182       "Calling `$pkg->VERSION` returned 'undef', which should never "
 183     . "happen - please file a bug with the distribution containing $pkg."
 184     ;
 185
 186   }
 187   elsif( ! length $mod_ver ) {
 188     say_err
 189       "Calling `$pkg->VERSION` returned the empty string '', which should never "
 190     . "happen - please file a bug with the distribution containing $pkg."
 191     ;
 192     undef $mod_ver;
 193   }
 194
 195   # if this is a real file - extract the version via EUMM whenever possible
 196   my $fn = $INC{module_notional_filename($pkg)};
 197
 198   my $eumm_ver = eval { MM->parse_version( $fn ) }
 199     if $fn and  -f $fn and -r $fn;
 200
 201   if (
 202     $has_versionpm
 203       and
 204     defined $eumm_ver
 205       and
 206     defined $mod_ver
 207       and
 208     $eumm_ver ne $mod_ver
 209       and
 210     (
 211       ( eval { version->parse( do { (my $v = $eumm_ver) =~ s/_//g; $v } ) } || 0 )
 212         !=
 213       ( eval { version->parse( do { (my $v = $mod_ver) =~ s/_//g; $v } ) } || 0 )
 214     )
 215   ) {
 216     say_err
 217       "Mismatch of versions '$mod_ver' and '$eumm_ver', obtained respectively "
 218     . "via `$pkg->VERSION` and parsing the version out of @{[ describe_fn $fn ]} "
 219     . "with ExtUtils::MakeMaker\@@{[ ExtUtils::MakeMaker->VERSION ]}. "
 220     . "This should never happen - please check whether this is still present "
 221     . "in the latest version, and then file a bug with the distribution "
 222     . "containing $pkg."
 223     ;
 224   }
 225
 226   if( defined $eumm_ver ) {
 227     $version_list->{$pkg} = $eumm_ver;
 228   }
 229   elsif( defined $mod_ver ) {
 230     $version_list->{$pkg} = $mod_ver;
 231   }
 232
 233   1;
 234 });
 235
 236 # compress identical versions as close to the root as we can
 237 # unless we are dealing with a smoker - in which case we want
 238 # to see every MD5 there is
 239 unless ( $ENV{AUTOMATED_TESTING} ) {
 240   for my $mod ( sort { length($b) <=> length($a) } keys %$version_list ) {
 241     my $parent = $mod;
 242
 243     while ( $parent =~ s/ :: (?: . (?! :: ) )+ $ //x ) {
 244       $version_list->{$parent}
 245         and
 246       $version_list->{$parent} eq $version_list->{$mod}
 247         and
 248       ( ( delete $version_list->{$mod} ) or 1 )
 249         and
 250       last
 251     }
 252   }
 253 }
 254
 255 ok 1, (scalar keys %$version_list) . " distinctly versioned modules";
 256
 257 exit if ($ENV{TRAVIS}||'') eq 'true';
 258
 259 # sort stuff into @INC segments
 260 my $segments;
 261
 262 MODULE:
 263 for my $mod ( sort { lc($a) cmp lc($b) } keys %$version_list ) {
 264   my $fn = $INC{module_notional_filename($mod)};
 265
 266   my $tuple = [
 267     $mod,
 268     ( ( $fn && -f $fn && -r $fn ) ? $fn : undef )
 269   ];
 270
 271
 272   if ($fn) {
 273     for my $lib (@lib_display_order, './lib') {
 274       if ( $lib_paths->{$lib} and index($fn, $lib_paths->{$lib}) == 0 ) {
 275         push @{$segments->{$lib}}, $tuple;
 276         next MODULE;
 277       }
 278     }
 279   }
 280
 281   # fallthrough for anything without a physical filename, or unknown lib
 282   push @{$segments->{''}}, $tuple;
 283 }
 284
 285 # diag the result out
 286 my $max_ver_len = max map { length $_ } values %$version_list;
 287 my $max_mod_len = max map { length $_ } keys %$version_list;
 288
 289 my $diag = "\n\nVersions of all loadable modules within the configure/build/test/runtime dependency chains present on this system (both core and optional)\n\n";
 290 for my $seg ( '', @lib_display_order, './lib' ) {
 291   next unless $segments->{$seg};
 292
 293   $diag .= sprintf "=== %s ===\n\n",
 294     $seg
 295       ? "Modules found in " . ( $Config{$seg} ? "\$Config{$seg}" : $seg )
 296       : 'Misc'
 297   ;
 298
 299   $diag .= sprintf (
 300     "   %*s  %*s%s\n",
 301     $max_ver_len => $version_list->{$_->[0]},
 302     -$max_mod_len => $_->[0],
 303     ($_->[1]
 304       ? "  [ MD5: @{[ md5_of_fn( $_->[1] ) ]} ]"
 305       : ''
 306     ),
 307   ) for @{$segments->{$seg}};
 308
 309   $diag .= "\n\n"
 310 }
 311
 312 diag $diag;