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 { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) }
  15
  16 BEGIN {
  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
  52 # Things happen... unfortunately
  53 $SIG{__DIE__} = sub {
  54   die $_[0] unless defined $^S and ! $^S;
  55
  56   diag "Something horrible happened while assembling the diag data\n$_[0]";
  57   exit 0;
  58 };
  59
  60 use Config;
  61 use File::Find 'find';
  62 use Digest::MD5 ();
  63 use Cwd 'abs_path';
  64 use File::Spec;
  65 use List::Util 'max';
  66 use ExtUtils::MakeMaker;
  67
  68 use DBICTest::RunMode;
  69 use DBIx::Class::_Util 'visit_namespaces';
  70 use DBIx::Class::Optional::Dependencies;
  71
  72 my $known_paths = {
  73   SA => {
  74     config_key => 'sitearch',
  75   },
  76   SL => {
  77     config_key => 'sitelib',
  78   },
  79   SS => {
  80     config_key => 'sitelib_stem',
  81     match_order => 1,
  82   },
  83   SP => {
  84     config_key => 'siteprefix',
  85     match_order => 2,
  86   },
  87   VA => {
  88     config_key => 'vendorarch',
  89   },
  90   VL => {
  91     config_key => 'vendorlib',
  92   },
  93   VS => {
  94     config_key => 'vendorlib_stem',
  95     match_order => 3,
  96   },
  97   VP => {
  98     config_key => 'vendorprefix',
  99     match_order => 4,
 100   },
 101   PA => {
 102     config_key => 'archlib',
 103   },
 104   PL => {
 105     config_key => 'privlib',
 106   },
 107   PP => {
 108     config_key => 'prefix',
 109     match_order => 5,
 110   },
 111   BLA => {
 112     rel_path => './blib/arch',
 113     skip_unversioned_modules => 1,
 114   },
 115   BLL => {
 116     rel_path => './blib/lib',
 117     skip_unversioned_modules => 1,
 118   },
 119   INC => {
 120     rel_path => './inc',
 121   },
 122   LIB => {
 123     rel_path => './lib',
 124     skip_unversioned_modules => 1,
 125   },
 126   T => {
 127     rel_path => './t',
 128     skip_unversioned_modules => 1,
 129   },
 130   XT => {
 131     rel_path => './xt',
 132     skip_unversioned_modules => 1,
 133   },
 134   CWD => {
 135     rel_path => '.',
 136   },
 137   HOME => {
 138     rel_path => '~',
 139     abs_unix_path => abs_unix_path (
 140       eval { require File::HomeDir and File::HomeDir->my_home }
 141         ||
 142       $ENV{USERPROFILE}
 143         ||
 144       $ENV{HOME}
 145         ||
 146       glob('~')
 147     ),
 148   },
 149 };
 150
 151 for my $k (keys %$known_paths) {
 152   my $v = $known_paths->{$k};
 153
 154   # never use home as a found-in-dir marker - it is too broad
 155   # HOME is only used by the shortener
 156   $v->{marker} = $k unless $k eq 'HOME';
 157
 158   unless ( $v->{abs_unix_path} ) {
 159     if ( $v->{rel_path} ) {
 160       $v->{abs_unix_path} = abs_unix_path( $v->{rel_path} );
 161     }
 162     elsif ( $Config{ $v->{config_key} || '' } ) {
 163       $v->{abs_unix_path} = abs_unix_path (
 164         $Config{"$v->{config_key}exp"} || $Config{$v->{config_key}}
 165       );
 166     }
 167   }
 168
 169   delete $known_paths->{$k} unless $v->{abs_unix_path} and -d $v->{abs_unix_path};
 170 }
 171 my $seen_markers = {};
 172
 173 # first run through lib/ and *try* to load anything we can find
 174 # within our own project
 175 find({
 176   wanted => sub {
 177     -f $_ or return;
 178
 179     $_ =~ m|lib/DBIx/Class/_TempExtlib| and return;
 180
 181     # can't just `require $fn`, as we need %INC to be
 182     # populated properly
 183     my ($mod) = $_ =~ /^ lib [\/\\] (.+) \.pm $/x
 184       or return;
 185
 186     try_module_require(join ('::', File::Spec->splitdir($mod)) )
 187   },
 188   no_chdir => 1,
 189 }, 'lib' );
 190
 191
 192
 193 # now run through OptDeps and attempt loading everything else
 194 #
 195 # some things needs to be sorted before other things
 196 # positive - load first
 197 # negative - load last
 198 my $load_weights = {
 199   # Make sure oracle is tried last - some clients (e.g. 10.2) have symbol
 200   # clashes with libssl, and will segfault everything coming after them
 201   "DBD::Oracle" => -999,
 202 };
 203
 204 my @known_modules = sort
 205   { ($load_weights->{$b}||0) <=> ($load_weights->{$a}||0) }
 206   qw( Data::Dumper ),
 207   keys %{
 208     DBIx::Class::Optional::Dependencies->req_list_for([
 209       grep
 210         # some DBDs are notoriously problematic to load
 211         # hence only show stuff based on test_rdbms which will
 212         # take into account necessary ENVs
 213         { $_ !~ /^ (?: rdbms | dist )_ /x }
 214         keys %{DBIx::Class::Optional::Dependencies->req_group_list}
 215     ])
 216   }
 217 ;
 218
 219 try_module_require($_) for @known_modules;
 220
 221 my $has_versionpm = eval { require version };
 222
 223
 224 # At this point we've loaded everything we ever could, but some modules
 225 # (understandably) crapped out. For an even more thorough report, note
 226 # everthing present in @INC we excplicitly know about (via OptDeps)
 227 # *even though* it didn't load
 228 my $known_failed_loads;
 229
 230 for my $mod (@known_modules) {
 231   my $inc_key = module_notional_filename($mod);
 232   next if defined $INC{$inc_key};
 233
 234   if (defined( my $idx = module_found_at_inc_index( $mod, \@INC ) ) ) {
 235     $known_failed_loads->{$mod} = abs_unix_path( "$INC[$idx]/$inc_key" );
 236   }
 237
 238 }
 239
 240 my $perl = 'perl';
 241
 242 # This is a cool idea, but the line is too long even with shortening :(
 243 #
 244 #for my $i ( 1 .. $Config{config_argc} ) {
 245 #  my $conf_arg = $Config{"config_arg$i"};
 246 #  $conf_arg =~ s!
 247 #    \= (.+)
 248 #  !
 249 #    '=' . shorten_fn($1)
 250 #  !ex;
 251 #
 252 #  $perl .= " $conf_arg";
 253 #}
 254
 255 my $interesting_modules = {
 256   # pseudo module
 257   $perl => {
 258     version => $],
 259     abs_unix_path => abs_unix_path($^X),
 260   }
 261 };
 262
 263
 264 # drill through the *ENTIRE* symtable and build a map of interesting modules
 265 visit_namespaces( action => sub {
 266   no strict 'refs';
 267   my $pkg = shift;
 268
 269   # keep going, but nothing to see here
 270   return 1 if $pkg eq 'main';
 271
 272   # private - not interested, including no further descent
 273   return 0 if $pkg =~ / (?: ^ | :: ) _ /x;
 274
 275   my $inc_key = module_notional_filename($pkg);
 276
 277   my $abs_unix_path = (
 278     $INC{$inc_key}
 279       and
 280     -f $INC{$inc_key}
 281       and
 282     -r $INC{$inc_key}
 283       and
 284     abs_unix_path($INC{$inc_key})
 285   );
 286
 287   # handle versions first (not interested in synthetic classes)
 288   if (
 289     defined ${"${pkg}::VERSION"}
 290       and
 291     ${"${pkg}::VERSION"} !~ /\Qset by base.pm/
 292   ) {
 293
 294     # make sure a version can be extracted, be noisy when it doesn't work
 295     # do this even if we are throwing away the result below in lieu of EUMM
 296     my $mod_ver = eval { $pkg->VERSION };
 297
 298     if (my $err = $@) {
 299       $err =~ s/^/  /mg;
 300       say_err (
 301         "Calling `$pkg->VERSION` resulted in an exception, which should never "
 302       . "happen - please file a bug with the distribution containing $pkg. "
 303       . "Complete exception text below:\n\n$err"
 304       );
 305     }
 306     elsif( ! defined $mod_ver or ! length $mod_ver ) {
 307       my $ret = defined $mod_ver
 308         ? "the empty string ''"
 309         : "'undef'"
 310       ;
 311
 312       say_err (
 313         "Calling `$pkg->VERSION` returned $ret, even though \$${pkg}::VERSION "
 314       . "is defined, which should never happen - please file a bug with the "
 315       . "distribution containing $pkg."
 316       );
 317
 318       undef $mod_ver;
 319     }
 320
 321     if (
 322       $abs_unix_path
 323         and
 324       defined ( my $eumm_ver = eval { MM->parse_version( $abs_unix_path ) } )
 325     ) {
 326
 327       # can only run the check reliably if v.pm is there
 328       if (
 329         $has_versionpm
 330           and
 331         defined $mod_ver
 332           and
 333         $eumm_ver ne $mod_ver
 334           and
 335         (
 336           ( eval { version->parse( do { (my $v = $eumm_ver) =~ s/_//g; $v } ) } || 0 )
 337             !=
 338           ( eval { version->parse( do { (my $v = $mod_ver) =~ s/_//g; $v } ) } || 0 )
 339         )
 340       ) {
 341         say_err (
 342           "Mismatch of versions '$mod_ver' and '$eumm_ver', obtained respectively "
 343         . "via `$pkg->VERSION` and parsing the version out of @{[ shorten_fn( $abs_unix_path ) ]} "
 344         . "with ExtUtils::MakeMaker\@@{[ ExtUtils::MakeMaker->VERSION ]}. "
 345         . "This should never happen - please check whether this is still present "
 346         . "in the latest version, and then file a bug with the distribution "
 347         . "containing $pkg."
 348         );
 349       }
 350
 351       $interesting_modules->{$pkg}{version} = $eumm_ver;
 352     }
 353     elsif( defined $mod_ver ) {
 354
 355       $interesting_modules->{$pkg}{version} = $mod_ver;
 356     }
 357   }
 358   elsif ( $known_failed_loads->{$pkg} ) {
 359     $abs_unix_path = $known_failed_loads->{$pkg};
 360     $interesting_modules->{$pkg}{version} = '!! LOAD FAIL !!';
 361   }
 362
 363   if ($abs_unix_path) {
 364     my ($marker, $initial_inc_idx);
 365
 366     my $current_inc_idx = module_found_at_inc_index($pkg, \@INC);
 367     my $p = subpath_of_known_path( $abs_unix_path );
 368
 369     if (
 370       defined $current_inc_idx
 371         and
 372       $p->{marker}
 373         and
 374       abs_unix_path($INC[$current_inc_idx]) eq $p->{abs_unix_path}
 375     ) {
 376       $marker = $p->{marker};
 377     }
 378     elsif (defined ( $initial_inc_idx = module_found_at_inc_index($pkg, \@initial_INC) ) ) {
 379       $marker = "\$INC[$initial_inc_idx]";
 380     }
 381
 382     # we are only interested if there was a declared version already above
 383     # OR if the module came from somewhere other than skip_unversioned_modules
 384     if (
 385       $marker
 386         and
 387       (
 388         $interesting_modules->{$pkg}
 389           or
 390         !$p->{skip_unversioned_modules}
 391       )
 392     ) {
 393       $interesting_modules->{$pkg}{source_marker} = $marker;
 394       $seen_markers->{$marker} = 1;
 395     }
 396
 397     # at this point only fill in the path (md5 calc) IFF it is interesting
 398     # in any respect
 399     $interesting_modules->{$pkg}{abs_unix_path} = $abs_unix_path
 400       if $interesting_modules->{$pkg};
 401   }
 402
 403   1;
 404 });
 405
 406 # compress identical versions sourced from ./blib, ./lib, ./t and ./xt
 407 # as close to the root of a namespace as we can
 408 purge_identically_versioned_submodules_with_markers([ map {
 409   ( $_->{skip_unversioned_modules} && $_->{marker} ) || ()
 410 } values %$known_paths ]);
 411
 412 ok 1, (scalar keys %$interesting_modules) . " distinctly versioned modules found";
 413
 414 # do not announce anything under ci - we are watching for STDERR silence
 415 exit 0 if DBICTest::RunMode->is_ci;
 416
 417
 418 # diag the result out
 419 my $max_ver_len = max map
 420   { length "$_" }
 421   ( 'xxx.yyyzzz_bbb', map { $_->{version} || '' } values %$interesting_modules )
 422 ;
 423 my $max_marker_len = max map { length $_ } ( '$INC[999]', keys %$seen_markers );
 424
 425 # Note - must be less than 76 chars wide to account for the diag() prefix
 426 my $discl = <<'EOD';
 427
 428 List of loadable modules within both *OPTIONAL* and core dependency chains
 429 present on this system (modules sourced from ./blib, ./lib, ./t, and ./xt
 430 with versions identical to their parent namespace were omitted for brevity)
 431
 432     *** Note that *MANY* of these modules will *NEVER* be loaded ***
 433             *** during normal operation of DBIx::Class ***
 434 EOD
 435
 436 # pre-assemble everything and print it in one shot
 437 # makes it less likely for parallel test execution to insert bogus lines
 438 my $final_out = "\n$discl\n";
 439
 440 $final_out .= "\@INC at startup (does not reflect manipulation at runtime):\n";
 441
 442 my $in_inc_skip;
 443 for (0.. $#initial_INC) {
 444
 445   my $shortname = shorten_fn( $initial_INC[$_] );
 446
 447   # when *to* print a line of INC
 448   if (
 449     ! $ENV{AUTOMATED_TESTING}
 450       or
 451     @initial_INC < 11
 452       or
 453     $seen_markers->{"\$INC[$_]"}
 454       or
 455     ! -e $shortname
 456       or
 457     ! File::Spec->file_name_is_absolute($shortname)
 458   ) {
 459     $in_inc_skip = 0;
 460     $final_out .= sprintf ( "% 3s: %s\n",
 461       $_,
 462       $shortname
 463     );
 464   }
 465   elsif(! $in_inc_skip++) {
 466     $final_out .= "  ...\n";
 467   }
 468 }
 469
 470 $final_out .= "\n";
 471
 472 if (my @seen_known_paths = grep { $known_paths->{$_} } keys %$seen_markers) {
 473
 474   $final_out .= join "\n", 'Sourcing markers:', (map
 475     {
 476       sprintf "%*s: %s",
 477         $max_marker_len => $_->{marker},
 478         ($_->{config_key} ? "\$Config{$_->{config_key}}" : "$_->{rel_path}/" )
 479     }
 480     sort
 481       {
 482         !!$b->{config_key} cmp !!$a->{config_key}
 483           or
 484         ( $a->{marker}||'') cmp ($b->{marker}||'')
 485       }
 486       @{$known_paths}{@seen_known_paths}
 487   ), '', '';
 488
 489 }
 490
 491 $final_out .= "=============================\n";
 492
 493 $final_out .= join "\n", (map
 494   { sprintf (
 495     "%*s  %*s  %*s%s",
 496     $max_marker_len => $interesting_modules->{$_}{source_marker} || '',
 497     $max_ver_len => ( defined $interesting_modules->{$_}{version}
 498       ? $interesting_modules->{$_}{version}
 499       : ''
 500     ),
 501     -78 => $_,
 502     ($interesting_modules->{$_}{abs_unix_path}
 503       ? "  [ MD5: @{[ get_md5( $interesting_modules->{$_}{abs_unix_path} ) ]} ]"
 504       : "! -f \$INC{'@{[ module_notional_filename($_) ]}'}"
 505     ),
 506   ) }
 507   sort { lc($a) cmp lc($b) } keys %$interesting_modules
 508 ), '';
 509
 510 $final_out .= "=============================\n$discl\n\n";
 511
 512 diag $final_out;
 513
 514 # *very* large printouts may not finish flushing before the test exits
 515 # injecting a <testname> ... ok in the middle of the diag
 516 # http://www.cpantesters.org/cpan/report/fbdac74c-35ca-11e6-ab41-c893a58a4b8c
 517 select( undef, undef, undef, 0.2 );
 518
 519 exit 0;
 520
 521
 522
 523 sub say_err { print STDERR "\n", @_, "\n\n" };
 524
 525 # do !!!NOT!!! use Module::Runtime's require_module - it breaks CORE::require
 526 sub try_module_require {
 527   # trap deprecation warnings and whatnot
 528   local $SIG{__WARN__} = sub {};
 529   local $@;
 530   eval "require $_[0]";
 531 }
 532
 533 sub abs_unix_path {
 534   return '' unless (
 535     defined $_[0]
 536       and
 537     ( -e $_[0] or File::Spec->file_name_is_absolute($_[0]) )
 538   );
 539
 540   # File::Spec's rel2abs does not resolve symlinks
 541   # we *need* to look at the filesystem to be sure
 542   #
 543   # But looking at the FS for non-existing basenames *may*
 544   # throw on some OSes so be extra paranoid:
 545   # http://www.cpantesters.org/cpan/report/26a6e42f-6c23-1014-b7dd-5cd275d8a230
 546   #
 547   my $abs_fn = eval { abs_path($_[0]) } || '';
 548
 549   if ( $abs_fn and $^O eq 'MSWin32' ) {
 550
 551     # sometimes we can get a short/longname mix, normalize everything to longnames
 552     $abs_fn = Win32::GetLongPathName($abs_fn)
 553       if -e $abs_fn;
 554
 555     # Fixup (native) slashes in Config not matching (unixy) slashes in INC
 556     $abs_fn =~ s|\\|/|g;
 557   }
 558
 559   $abs_fn;
 560 }
 561
 562 sub shorten_fn {
 563   my $fn = shift;
 564
 565   my $abs_fn = abs_unix_path($fn);
 566
 567   if ($abs_fn and my $p = subpath_of_known_path( $fn ) ) {
 568     $abs_fn =~ s| (?<! / ) $|/|x
 569       if -d $abs_fn;
 570
 571     if ($p->{rel_path}) {
 572       $abs_fn =~ s!\Q$p->{abs_unix_path}!$p->{rel_path}!
 573         and return $abs_fn;
 574     }
 575     elsif ($p->{config_key}) {
 576       $abs_fn =~ s!\Q$p->{abs_unix_path}!<<$p->{marker}>>!
 577         and
 578       $seen_markers->{$p->{marker}} = 1
 579         and
 580       return $abs_fn;
 581     }
 582   }
 583
 584   # we got so far - not a known path
 585   # return the unixified version it if was absolute, leave as-is otherwise
 586   my $rv = ( $abs_fn and File::Spec->file_name_is_absolute( $fn ) )
 587     ? $abs_fn
 588     : $fn
 589   ;
 590
 591   $rv = "( ! -e ) $rv" unless -e $rv;
 592
 593   return $rv;
 594 }
 595
 596 sub subpath_of_known_path {
 597   my $abs_fn = abs_unix_path( $_[0] )
 598     or return '';
 599
 600   for my $p (
 601     sort {
 602       length( $b->{abs_unix_path} ) <=> length( $a->{abs_unix_path} )
 603         or
 604       ( $a->{match_order} || 0 ) <=> ( $b->{match_order} || 0 )
 605     }
 606     values %$known_paths
 607   ) {
 608     # run through the matcher twice - first always append a /
 609     # then try without
 610     # important to avoid false positives
 611     for my $suff ( '/', '' ) {
 612       return { %$p } if 0 == index( $abs_fn, "$p->{abs_unix_path}$suff" );
 613     }
 614   }
 615 }
 616
 617 sub module_found_at_inc_index {
 618   my ($mod, $inc_dirs) = @_;
 619
 620   return undef unless @$inc_dirs;
 621
 622   my $fn = module_notional_filename($mod);
 623
 624   # trust INC if it specifies an existing path
 625   if( -f ( my $existing_path = abs_unix_path( $INC{$fn} ) ) ) {
 626     for my $i ( 0 .. $#$inc_dirs ) {
 627
 628       # searching from here on out won't mean anything
 629       # FIXME - there is actually a way to interrogate this safely, but
 630       # that's a fight for another day
 631       return undef if length ref $inc_dirs->[$i];
 632
 633       return $i
 634         if 0 == index( $existing_path, abs_unix_path( $inc_dirs->[$i] ) . '/' );
 635     }
 636   }
 637
 638   for my $i ( 0 .. $#$inc_dirs ) {
 639
 640     if (
 641       -d $inc_dirs->[$i]
 642         and
 643       -f "$inc_dirs->[$i]/$fn"
 644         and
 645       -r "$inc_dirs->[$i]/$fn"
 646     ) {
 647       return $i;
 648     }
 649   }
 650
 651   return undef;
 652 }
 653
 654 sub purge_identically_versioned_submodules_with_markers {
 655   my $markers = shift;
 656
 657   return unless @$markers;
 658
 659   for my $mod ( sort { length($b) <=> length($a) } keys %$interesting_modules ) {
 660
 661     next unless defined $interesting_modules->{$mod}{version};
 662
 663     my $marker = $interesting_modules->{$mod}{source_marker}
 664       or next;
 665
 666     next unless grep { $marker eq $_ } @$markers;
 667
 668     my $parent = $mod;
 669
 670     while ( $parent =~ s/ :: (?: . (?! :: ) )+ $ //x ) {
 671       $interesting_modules->{$parent}
 672         and
 673       ($interesting_modules->{$parent}{version}||'') eq $interesting_modules->{$mod}{version}
 674         and
 675       ($interesting_modules->{$parent}{source_marker}||'') eq $interesting_modules->{$mod}{source_marker}
 676         and
 677     delete $interesting_modules->{$mod}
 678         and
 679       last
 680     }
 681   }
 682 }
 683
 684 sub module_notional_filename {
 685   (my $fn = $_[0] . '.pm') =~ s|::|/|g;
 686   $fn;
 687 }
 688
 689 sub get_md5 {
 690   # we already checked for -r/-f, just bail if can't open
 691   open my $fh, '<:raw', $_[0] or return '';
 692   Digest::MD5->new->addfile($fh)->hexdigest;
 693 }