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 # Very important to grab the snapshot early, as we will be reporting
   7 # the INC indices from the POV of whoever ran the script, *NOT* from
   8 # the POV of the internals
   9 my @initial_INC;
  10 BEGIN {
  11   @initial_INC = @INC;
  12 }
  13
  14 BEGIN {
  15   unshift @INC, 't/lib';
  16
  17   if ($] < 5.010) {
  18
  19     # Pre-5.10 perls pollute %INC on unsuccesfull module
  20     # require, making it appear as if the module is already
  21     # loaded on subsequent require()s
  22     # Can't seem to find the exact RT/perldelta entry
  23     #
  24     # The reason we can't just use a sane, clean loader, is because
  25     # if a Module require()s another module the %INC will still
  26     # get filled with crap and we are back to square one. A global
  27     # fix is really the only way for this test, as we try to load
  28     # each available module separately, and have no control (nor
  29     # knowledge) over their common dependencies.
  30     #
  31     # we want to do this here, in the very beginning, before even
  32     # warnings/strict are loaded
  33
  34     require DBICTest::Util::OverrideRequire;
  35
  36     DBICTest::Util::OverrideRequire::override_global_require( sub {
  37       my $res = eval { $_[0]->() };
  38       if ($@ ne '') {
  39         delete $INC{$_[1]};
  40         die $@;
  41       }
  42       return $res;
  43     } );
  44   }
  45 }
  46
  47 use strict;
  48 use warnings;
  49
  50 use Test::More 'no_plan';
  51 use Config;
  52 use File::Find 'find';
  53 use Digest::MD5 ();
  54 use Cwd 'abs_path';
  55 use List::Util qw(max min);
  56 use ExtUtils::MakeMaker;
  57 use DBICTest::Util 'visit_namespaces';
  58
  59 # load these two to pull in the t/lib armada
  60 use DBICTest;
  61 use DBICTest::Schema;
  62
  63 my $known_libpaths = {
  64   SA => {
  65     config_key => 'sitearch',
  66   },
  67   SL => {
  68     config_key => 'sitelib',
  69   },
  70   VA => {
  71     config_key => 'vendorarch',
  72   },
  73   VL => {
  74     config_key => 'vendorlib',
  75   },
  76   PA => {
  77     config_key => 'archlib',
  78   },
  79   PL => {
  80     config_key => 'privlib',
  81   },
  82   INC => {
  83     relpath => './inc',
  84   },
  85   LIB => {
  86     relpath => './lib',
  87   },
  88   T => {
  89     relpath => './t',
  90   },
  91   HOME => {
  92     relpath => '~',
  93     full_path => full_path (
  94       eval { require File::HomeDir and File::HomeDir->my_home }
  95         ||
  96       $ENV{HOME}
  97         ||
  98       glob('~')
  99     ),
 100   },
 101 };
 102
 103 for my $k (keys %$known_libpaths) {
 104   my $v = $known_libpaths->{$k};
 105
 106   # never use home as a found-in-dir marker - it is too broad
 107   # HOME is only used by the shortener
 108   $v->{marker} = $k unless $k eq 'HOME';
 109
 110   unless ( $v->{full_path} ) {
 111     if ( $v->{relpath} ) {
 112       $v->{full_path} = full_path( $v->{relpath} );
 113     }
 114     elsif ( $Config{ $v->{config_key} || '' } ) {
 115       $v->{full_path} = full_path (
 116         $Config{"$v->{config_key}exp"} || $Config{$v->{config_key}}
 117       );
 118     }
 119   }
 120
 121   delete $known_libpaths->{$k} unless $v->{full_path} and -d $v->{full_path};
 122 }
 123 my $seen_known_markers;
 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     try_module_require(join ('::', File::Spec->splitdir($mod)) )
 137   },
 138   no_chdir => 1,
 139 }, 'lib' );
 140
 141
 142
 143 # now run through OptDeps and attempt loading everything else
 144 #
 145 # some things needs to be sorted before other things
 146 # positive - load first
 147 # negative - load last
 148 my $load_weights = {
 149   # Make sure oracle is tried last - some clients (e.g. 10.2) have symbol
 150   # clashes with libssl, and will segfault everything coming after them
 151   "DBD::Oracle" => -999,
 152 };
 153
 154 my @known_modules = sort
 155   { ($load_weights->{$b}||0) <=> ($load_weights->{$a}||0) }
 156   keys %{
 157     DBIx::Class::Optional::Dependencies->req_list_for([
 158       grep
 159         # some DBDs are notoriously problematic to load
 160         # hence only show stuff based on test_rdbms which will
 161         # take into account necessary ENVs
 162         { $_ !~ /^ (?: rdbms | dist )_ /x }
 163         keys %{DBIx::Class::Optional::Dependencies->req_group_list}
 164     ])
 165   }
 166 ;
 167
 168 try_module_require($_) for @known_modules;
 169
 170 my $has_versionpm = eval { require version };
 171
 172
 173 # At this point we've loaded everything we ever could, but some modules
 174 # (understandably) crapped out. For an even more thorough report, note
 175 # everthing present in @INC we excplicitly know about (via OptDeps)
 176 # *even though* it didn't load
 177 my $known_failed_loads;
 178
 179 for my $mod (@known_modules) {
 180   my $inc_key = module_notional_filename($mod);
 181   next if defined $INC{$inc_key};
 182
 183   if (defined( my $idx = module_found_at_inc_index( $mod, \@INC ) ) ) {
 184     $known_failed_loads->{$mod} = full_path( "$INC[$idx]/$inc_key" );
 185   }
 186
 187 }
 188
 189 my $perl = 'perl';
 190
 191 # This is a cool idea, but the line is too long even with shortening :(
 192 #
 193 #for my $i ( 1 .. $Config{config_argc} ) {
 194 #  my $conf_arg = $Config{"config_arg$i"};
 195 #  $conf_arg =~ s!
 196 #    \= (.+)
 197 #  !
 198 #    '=' . shorten_fn(full_path($1) )
 199 #  !ex;
 200 #
 201 #  $perl .= " $conf_arg";
 202 #}
 203
 204 my $interesting_modules = {
 205   # pseudo module
 206   $perl => {
 207     version => $],
 208     full_path => $^X,
 209   }
 210 };
 211
 212
 213 # drill through the *ENTIRE* symtable and build a map of intereseting modules
 214 visit_namespaces( action => sub {
 215   no strict 'refs';
 216   my $pkg = shift;
 217
 218   # keep going, but nothing to see here
 219   return 1 if $pkg eq 'main';
 220
 221   # private - not interested, including no further descent
 222   return 0 if $pkg =~ / (?: ^ | :: ) _ /x;
 223
 224   my $inc_key = module_notional_filename($pkg);
 225
 226   my $full_path = (
 227     $INC{$inc_key}
 228       and
 229     -f $INC{$inc_key}
 230       and
 231     -r $INC{$inc_key}
 232       and
 233     full_path($INC{$inc_key})
 234   );
 235
 236   # handle versions first (not interested in synthetic classes)
 237   if (
 238     defined ${"${pkg}::VERSION"}
 239       and
 240     ${"${pkg}::VERSION"} !~ /\Qset by base.pm/
 241   ) {
 242
 243     # make sure a version can be extracted, be noisy when it doesn't work
 244     # do this even if we are throwing away the result below in lieu of EUMM
 245     my $mod_ver = eval { $pkg->VERSION };
 246
 247     if (my $err = $@) {
 248       $err =~ s/^/  /mg;
 249       say_err (
 250         "Calling `$pkg->VERSION` resulted in an exception, which should never "
 251       . "happen - please file a bug with the distribution containing $pkg. "
 252       . "Complete exception text below:\n\n$err"
 253       );
 254     }
 255     elsif( ! defined $mod_ver or ! length $mod_ver ) {
 256       my $ret = defined $mod_ver
 257         ? "the empty string ''"
 258         : "'undef'"
 259       ;
 260
 261       say_err (
 262         "Calling `$pkg->VERSION` returned $ret, even though \$${pkg}::VERSION "
 263       . "is defined, which should never happen - please file a bug with the "
 264       . "distribution containing $pkg."
 265       );
 266
 267       undef $mod_ver;
 268     }
 269
 270     if (
 271       $full_path
 272         and
 273       defined ( my $eumm_ver = eval { MM->parse_version( $full_path ) } )
 274     ) {
 275
 276       # can only run the check reliably if v.pm is there
 277       if (
 278         $has_versionpm
 279           and
 280         defined $mod_ver
 281           and
 282         $eumm_ver ne $mod_ver
 283           and
 284         (
 285           ( eval { version->parse( do { (my $v = $eumm_ver) =~ s/_//g; $v } ) } || 0 )
 286             !=
 287           ( eval { version->parse( do { (my $v = $mod_ver) =~ s/_//g; $v } ) } || 0 )
 288         )
 289       ) {
 290         say_err (
 291           "Mismatch of versions '$mod_ver' and '$eumm_ver', obtained respectively "
 292         . "via `$pkg->VERSION` and parsing the version out of @{[ shorten_fn( $full_path ) ]} "
 293         . "with ExtUtils::MakeMaker\@@{[ ExtUtils::MakeMaker->VERSION ]}. "
 294         . "This should never happen - please check whether this is still present "
 295         . "in the latest version, and then file a bug with the distribution "
 296         . "containing $pkg."
 297         );
 298       }
 299
 300       $interesting_modules->{$pkg}{version} = $eumm_ver;
 301     }
 302     elsif( defined $mod_ver ) {
 303
 304       $interesting_modules->{$pkg}{version} = $mod_ver;
 305     }
 306   }
 307   elsif ( $full_path = $known_failed_loads->{$pkg} ) {
 308     $interesting_modules->{$pkg}{version} = '!! LOAD FAILED !!';
 309   }
 310
 311   if ($full_path) {
 312     my $marker;
 313     if (my $m = ( matching_known_lib( $full_path ) || {} )->{marker} ) {
 314       $marker = $m;
 315     }
 316     elsif (defined ( my $idx = module_found_at_inc_index($pkg, \@initial_INC) ) ) {
 317       $marker = sprintf '$INC[%d]', $idx;
 318     }
 319
 320     # we are only interested if there was a declared version already above
 321     # OR if the module came from somewhere other than T or LIB
 322     if (
 323       $marker
 324         and
 325       (
 326         $interesting_modules->{$pkg}
 327           or
 328         $marker !~ /^ (?: T | LIB ) $/x
 329       )
 330     ) {
 331       $interesting_modules->{$pkg}{source_marker} = $marker;
 332       $seen_known_markers->{$marker} = 1
 333         if $known_libpaths->{$marker};
 334     }
 335
 336     # at this point only fill in the path (md5 calc) IFF it is interesting
 337     # in any respect
 338     $interesting_modules->{$pkg}{full_path} = $full_path
 339       if $interesting_modules->{$pkg};
 340   }
 341
 342   1;
 343 });
 344
 345 # compress identical versions sourced from ./lib and ./t as close to the root
 346 # of a namespace as we can
 347 purge_identically_versioned_submodules_with_markers([qw( LIB T )]);
 348
 349 ok 1, (scalar keys %$interesting_modules) . " distinctly versioned modules found";
 350
 351 # do not announce anything under ci - we are watching for STDERR silence
 352 exit 0 if DBICTest::RunMode->is_ci;
 353
 354
 355 # diag the result out
 356 my $max_ver_len = max map
 357   { length "$_" }
 358   ( 'xxx.yyyzzz_bbb', map { $_->{version} || '' } values %$interesting_modules )
 359 ;
 360 my $max_mod_len = max map { length $_ } keys %$interesting_modules;
 361 my $max_marker_len = max map { length $_ } ( '$INC[99]', keys %{ $seen_known_markers || {} } );
 362
 363 my $discl = <<'EOD';
 364
 365 List of loadable modules within both the core and *OPTIONAL* dependency chains present on this system
 366 Note that *MANY* of these modules will *NEVER* be loaded during normal operation of DBIx::Class
 367 (modules sourced from ./lib and ./t with versions identical to their parent namespace were omitted for brevity)
 368 EOD
 369
 370 # pre-assemble everything and print it in one shot
 371 # makes it less likely for parallel test execution to insert bogus lines
 372 my $final_out = "\n$discl\n";
 373
 374
 375 if ($seen_known_markers) {
 376
 377   $final_out .= join "\n", 'Sourcing markers:', (map
 378     {
 379       sprintf "%*s: %s",
 380         $max_marker_len => $_->{marker},
 381         ($_->{config_key} ? "\$Config{$_->{config_key}}" : "$_->{relpath}/*" )
 382     }
 383     sort
 384       {
 385         !!$b->{config_key} cmp !!$a->{config_key}
 386           or
 387         ( $a->{marker}||'') cmp ($b->{marker}||'')
 388       }
 389       @{$known_libpaths}{keys %$seen_known_markers}
 390   ), '', '';
 391
 392 }
 393
 394 $final_out .= "=============================\n";
 395
 396 $final_out .= join "\n", (map
 397   { sprintf (
 398     "%*s  %*s  %s%s",
 399     $max_marker_len => $interesting_modules->{$_}{source_marker} || '',
 400     $max_ver_len => ( defined $interesting_modules->{$_}{version}
 401       ? $interesting_modules->{$_}{version}
 402       : ''
 403     ),
 404     $_,
 405     ($interesting_modules->{$_}{full_path}
 406       ? ' ' x (80 - min( 78, length($_) )) . "[ MD5: @{[ get_md5( $interesting_modules->{$_}{full_path} ) ]} ]"
 407       : ''
 408     ),
 409   ) }
 410   sort { lc($a) cmp lc($b) } keys %$interesting_modules
 411 ), '';
 412
 413 $final_out .= "=============================\n$discl\n\n";
 414
 415 diag $final_out;
 416
 417 exit 0;
 418
 419
 420
 421 sub say_err { print STDERR @_, "\n\n" };
 422
 423 # do !!!NOT!!! use Module::Runtime's require_module - it breaks CORE::require
 424 sub try_module_require {
 425   # trap deprecation warnings and whatnot
 426   local $SIG{__WARN__} = sub {};
 427   local $@;
 428   eval "require $_[0]";
 429 }
 430
 431 sub full_path {
 432   return '' unless ( defined $_[0] and -e $_[0] );
 433
 434   # File::Spec's rel2abs does not resolve symlinks
 435   # we *need* to look at the filesystem to be sure
 436   my $fn = abs_path($_[0]);
 437
 438   if ( $^O eq 'MSWin32' and $fn ) {
 439
 440     # sometimes we can get a short/longname mix, normalize everything to longnames
 441     $fn = Win32::GetLongPathName($fn);
 442
 443     # Fixup (native) slashes in Config not matching (unixy) slashes in INC
 444     $fn =~ s|\\|/|g;
 445   }
 446
 447   $fn;
 448 }
 449
 450 sub shorten_fn {
 451   my $fn = shift;
 452
 453   my $l = matching_known_lib( $fn )
 454     or return $fn;
 455
 456   if ($l->{relpath}) {
 457     $fn =~ s!\Q$l->{full_path}!$l->{relpath}!;
 458   }
 459   elsif ($l->{config_key}) {
 460     $fn =~ s!\Q$l->{full_path}!<<$l->{marker}>>!
 461       and
 462     $seen_known_markers->{$l->{marker}} = 1;
 463   }
 464
 465   $fn;
 466 }
 467
 468 sub matching_known_lib {
 469   my $fn = full_path( $_[0] )
 470     or return '';
 471
 472   for my $l (
 473     sort { length( $b->{full_path} ) <=> length( $a->{full_path} ) }
 474     values %$known_libpaths
 475   ) {
 476     # run through the matcher twice - first always append a /
 477     # then try without
 478     # important to avoid false positives
 479     for my $suff ( '/', '' ) {
 480       return { %$l } if 0 == index( $fn, "$l->{full_path}$suff" );
 481     }
 482   }
 483 }
 484
 485 sub module_found_at_inc_index {
 486   my ($mod, $dirs) = @_;
 487
 488   my $fn = module_notional_filename($mod);
 489
 490   for my $i ( 0 .. $#$dirs ) {
 491     # searching from here on out won't mean anything
 492     return undef if length ref $dirs->[$i];
 493
 494     if (
 495       -d $dirs->[$i]
 496         and
 497       -f "$dirs->[$i]/$fn"
 498         and
 499       -r "$dirs->[$i]/$fn"
 500     ) {
 501       return $i;
 502     }
 503   }
 504
 505   return undef;
 506 }
 507
 508 sub purge_identically_versioned_submodules_with_markers {
 509   my $markers = shift;
 510
 511   return unless @$markers;
 512
 513   for my $mod ( sort { length($b) <=> length($a) } keys %$interesting_modules ) {
 514
 515     next unless defined $interesting_modules->{$mod}{version};
 516
 517     my $marker = $interesting_modules->{$mod}{source_marker}
 518       or next;
 519
 520     next unless grep { $marker eq $_ } @$markers;
 521
 522     my $parent = $mod;
 523
 524     while ( $parent =~ s/ :: (?: . (?! :: ) )+ $ //x ) {
 525       $interesting_modules->{$parent}
 526         and
 527       ($interesting_modules->{$parent}{version}||'') eq $interesting_modules->{$mod}{version}
 528         and
 529       ($interesting_modules->{$parent}{source_marker}||'') eq $interesting_modules->{$mod}{source_marker}
 530         and
 531     delete $interesting_modules->{$mod}
 532         and
 533       last
 534     }
 535   }
 536 }
 537
 538 sub module_notional_filename {
 539   (my $fn = $_[0] . '.pm') =~ s|::|/|g;
 540   $fn;
 541 }
 542
 543 sub get_md5 {
 544   # we already checked for -r/-f, just bail if can't open
 545   open my $fh, '<:raw', $_[0] or return '';
 546   Digest::MD5->new->addfile($fh)->hexdigest;
 547 }