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