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