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 qw(max min);
  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
  59 # do !!!NOT!!! use Module::Runtime's require_module - it breaks CORE::require
  60 sub req_mod ($) {
  61   # trap deprecation warnings and whatnot
  62   local $SIG{__WARN__} = sub {};
  63   local $@;
  64   eval "require $_[0]";
  65 }
  66
  67 sub say_err {
  68   print STDERR "\n", @_, "\n";
  69 }
  70
  71 # needed for WeirdOS
  72 sub fixup_path ($) {
  73   return $_[0] unless ( $^O eq 'MSWin32' and $_[0] );
  74
  75   # sometimes we can get a short/longname mix, normalize everything to longnames
  76   my $fn = Win32::GetLongPathName($_[0]);
  77
  78   # Fixup (native) slashes in Config not matching (unixy) slashes in INC
  79   $fn =~ s|\\|/|g;
  80
  81   $fn;
  82 }
  83
  84 my @lib_display_order = qw(
  85   sitearch
  86   sitelib
  87   vendorarch
  88   vendorlib
  89   archlib
  90   privlib
  91 );
  92 my $lib_paths = {
  93   (map
  94     { $Config{$_}
  95       ? ( $_ => fixup_path( $Config{"${_}exp"} || $Config{$_} ) )
  96       : ()
  97     }
  98     @lib_display_order
  99   ),
 100
 101   # synthetic, for display
 102   './lib' => 'lib',
 103 };
 104
 105 sub describe_fn {
 106   my $fn = shift;
 107
 108   return '' if !defined $fn;
 109
 110   $fn = fixup_path( $fn );
 111
 112   $lib_paths->{$_} and $fn =~ s/^\Q$lib_paths->{$_}/<<$_>>/ and last
 113     for @lib_display_order;
 114
 115   $fn;
 116 }
 117
 118 sub md5_of_fn {
 119   # we already checked for -r/-f, just bail if can't open
 120   open my $fh, '<:raw', $_[0] or return '';
 121   require Digest::MD5;
 122   Digest::MD5->new->addfile($fh)->hexdigest;
 123 }
 124
 125 # first run through lib and *try* to load anything we can find
 126 # within our own project
 127 find({
 128   wanted => sub {
 129     -f $_ or return;
 130
 131     # can't just `require $fn`, as we need %INC to be
 132     # populated properly
 133     my ($mod) = $_ =~ /^ lib [\/\\] (.+) \.pm $/x
 134       or return;
 135
 136     req_mod join ('::', File::Spec->splitdir($mod));
 137   },
 138   no_chdir => 1,
 139 }, 'lib' );
 140
 141 # now run through OptDeps and attempt loading everything else
 142 #
 143 # some things needs to be sorted before other things
 144 # positive - load first
 145 # negative - load last
 146 my $load_weights = {
 147   # Make sure oracle is tried last - some clients (e.g. 10.2) have symbol
 148   # clashes with libssl, and will segfault everything coming after them
 149   "DBD::Oracle" => -999,
 150 };
 151 req_mod $_ for sort
 152   { ($load_weights->{$b}||0) <=> ($load_weights->{$a}||0) }
 153   keys %{
 154     DBIx::Class::Optional::Dependencies->req_list_for([
 155       grep
 156         # some DBDs are notoriously problematic to load
 157         # hence only show stuff based on test_rdbms which will
 158         # take into account necessary ENVs
 159         { $_ !~ /^rdbms_/ }
 160         keys %{DBIx::Class::Optional::Dependencies->req_group_list}
 161     ])
 162   }
 163 ;
 164
 165 my $has_versionpm = eval { require version };
 166
 167 # at this point we've loaded everything we ever could, let's drill through
 168 # the *ENTIRE* symtable and build a map of versions
 169 my $version_list = { perl => $] };
 170 visit_namespaces( action => sub {
 171   no strict 'refs';
 172   my $pkg = shift;
 173
 174   # keep going, but nothing to see here
 175   return 1 if $pkg eq 'main';
 176
 177   # private - not interested, including no further descent
 178   return 0 if $pkg =~ / (?: ^ | :: ) _ /x;
 179
 180   # not interested in no-VERSION-containing modules, nor synthetic classes
 181   return 1 if (
 182     ! defined ${"${pkg}::VERSION"}
 183       or
 184     ${"${pkg}::VERSION"} =~ /\Qset by base.pm/
 185   );
 186
 187   # make sure a version can be extracted, be noisy when it doesn't work
 188   # do this even if we are throwing away the result below in lieu of EUMM
 189   my $mod_ver = eval { $pkg->VERSION };
 190   if (my $err = $@) {
 191     $err =~ s/^/  /mg;
 192     say_err
 193       "Calling `$pkg->VERSION` resulted in an exception, which should never "
 194     . "happen - please file a bug with the distribution containing $pkg. "
 195     . "Complete exception text below:\n\n$err"
 196     ;
 197   }
 198   elsif( ! defined $mod_ver or ! length $mod_ver ) {
 199     my $ret = defined $mod_ver
 200       ? "the empty string ''"
 201       : "'undef'"
 202     ;
 203
 204     say_err
 205       "Calling `$pkg->VERSION` returned $ret, even though \$${pkg}::VERSION "
 206     . "is defined, which should never happen - please file a bug with the "
 207     . "distribution containing $pkg."
 208     ;
 209
 210     undef $mod_ver;
 211   }
 212
 213   # if this is a real file - extract the version via EUMM whenever possible
 214   my $fn = $INC{module_notional_filename($pkg)};
 215
 216   my $eumm_ver = (
 217     $fn
 218       and
 219     -f $fn
 220       and
 221     -r $fn
 222       and
 223     eval { MM->parse_version( $fn ) }
 224   ) || undef;
 225
 226   if (
 227     $has_versionpm
 228       and
 229     defined $eumm_ver
 230       and
 231     defined $mod_ver
 232       and
 233     $eumm_ver ne $mod_ver
 234       and
 235     (
 236       ( eval { version->parse( do { (my $v = $eumm_ver) =~ s/_//g; $v } ) } || 0 )
 237         !=
 238       ( eval { version->parse( do { (my $v = $mod_ver) =~ s/_//g; $v } ) } || 0 )
 239     )
 240   ) {
 241     say_err
 242       "Mismatch of versions '$mod_ver' and '$eumm_ver', obtained respectively "
 243     . "via `$pkg->VERSION` and parsing the version out of @{[ describe_fn $fn ]} "
 244     . "with ExtUtils::MakeMaker\@@{[ ExtUtils::MakeMaker->VERSION ]}. "
 245     . "This should never happen - please check whether this is still present "
 246     . "in the latest version, and then file a bug with the distribution "
 247     . "containing $pkg."
 248     ;
 249   }
 250
 251   if( defined $eumm_ver ) {
 252     $version_list->{$pkg} = $eumm_ver;
 253   }
 254   elsif( defined $mod_ver ) {
 255     $version_list->{$pkg} = $mod_ver;
 256   }
 257
 258   1;
 259 });
 260
 261 # In retrospect it makes little sense to omit this information - just
 262 # show everything at all times.
 263 # Nevertheless leave the dead code, in case it turns out to be a bad idea...
 264 my $show_all = 1;
 265 #my $show_all = $ENV{PERL_DESCRIBE_ALL_DEPS} || !DBICTest::RunMode->is_plain;
 266
 267 # compress identical versions as close to the root as we can
 268 # unless we are dealing with a smoker - in which case we want
 269 # to see every MD5 there is
 270 unless ($show_all) {
 271   for my $mod ( sort { length($b) <=> length($a) } keys %$version_list ) {
 272     my $parent = $mod;
 273
 274     while ( $parent =~ s/ :: (?: . (?! :: ) )+ $ //x ) {
 275       $version_list->{$parent}
 276         and
 277       $version_list->{$parent} eq $version_list->{$mod}
 278         and
 279       ( ( delete $version_list->{$mod} ) or 1 )
 280         and
 281       last
 282     }
 283   }
 284 }
 285
 286 ok 1, (scalar keys %$version_list) . " distinctly versioned modules";
 287
 288 # do not announce anything under ci - we are watching for STDERR silence
 289 exit if DBICTest::RunMode->is_ci;
 290
 291 # sort stuff into @INC segments
 292 my $segments;
 293
 294 MODULE:
 295 for my $mod ( sort { lc($a) cmp lc($b) } keys %$version_list ) {
 296   my $fn = $INC{module_notional_filename($mod)};
 297
 298   my $tuple = [ $mod ];
 299
 300   if ( defined $fn && -f $fn && -r $fn ) {
 301     push @$tuple, ( $fn = fixup_path($fn) );
 302
 303     for my $lib (@lib_display_order, './lib') {
 304       if ( $lib_paths->{$lib} and index($fn, $lib_paths->{$lib}) == 0 ) {
 305         push @{$segments->{$lib}}, $tuple;
 306         next MODULE;
 307       }
 308     }
 309   }
 310
 311   # fallthrough for anything without a physical filename, or unknown lib
 312   push @{$segments->{''}}, $tuple;
 313 }
 314
 315 # diag the result out
 316 my $max_ver_len = max map
 317   { length $_ }
 318   ( values %$version_list, 'xxx.yyyzzz_bbb' )
 319 ;
 320 my $max_mod_len = max map { length $_ } keys %$version_list;
 321
 322 my $discl = <<'EOD';
 323
 324 Versions of all loadable modules within both the core and *OPTIONAL* dependency chains present on this system
 325 Note that *MANY* of these modules will *NEVER* be loaded during normal operation of DBIx::Class
 326 EOD
 327
 328 $discl .= "(modules with versions identical to their parent namespace were omitted - set PERL_DESCRIBE_ALL_DEPS to see them)\n"
 329   unless $show_all;
 330
 331 diag $discl;
 332
 333 diag "\n";
 334
 335 for my $seg ( '', @lib_display_order, './lib' ) {
 336   next unless $segments->{$seg};
 337
 338   diag sprintf "=== %s ===\n\n",
 339     $seg
 340       ? "Modules found in " . ( $Config{$seg} ? "\$Config{$seg}" : $seg )
 341       : 'Misc versions'
 342   ;
 343
 344   diag sprintf (
 345     "%*s  %*s%s\n",
 346     $max_ver_len => $version_list->{$_->[0]},
 347     -$max_mod_len => $_->[0],
 348     ($_->[1]
 349       ? ' ' x (80 - min(78, $max_mod_len)) . "[ MD5: @{[ md5_of_fn( $_->[1] ) ]} ]"
 350       : ''
 351     ),
 352   ) for @{$segments->{$seg}};
 353
 354   diag "\n\n"
 355 }
 356
 357 diag "$discl\n";