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
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
14 BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) }
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
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.
31 # we want to do this here, in the very beginning, before even
32 # warnings/strict are loaded
34 require DBICTest::Util::OverrideRequire;
36 DBICTest::Util::OverrideRequire::override_global_require( sub {
37 my $res = eval { $_[0]->() };
50 use Test::More 'no_plan';
52 # Things happen... unfortunately
54 die $_[0] unless defined $^S and ! $^S;
56 diag "Something horrible happened while assembling the diag data\n$_[0]";
61 use File::Find 'find';
66 use ExtUtils::MakeMaker;
68 use DBICTest::RunMode;
69 use DBIx::Class::_Util 'visit_namespaces';
70 use DBIx::Class::Optional::Dependencies;
74 config_key => 'sitearch',
77 config_key => 'sitelib',
80 config_key => 'sitelib_stem',
84 config_key => 'siteprefix',
88 config_key => 'vendorarch',
91 config_key => 'vendorlib',
94 config_key => 'vendorlib_stem',
98 config_key => 'vendorprefix',
102 config_key => 'archlib',
105 config_key => 'privlib',
108 config_key => 'prefix',
112 rel_path => './blib/arch',
113 skip_unversioned_modules => 1,
116 rel_path => './blib/lib',
117 skip_unversioned_modules => 1,
124 skip_unversioned_modules => 1,
128 skip_unversioned_modules => 1,
132 skip_unversioned_modules => 1,
139 abs_unix_path => abs_unix_path (
140 eval { require File::HomeDir and File::HomeDir->my_home }
151 for my $k (keys %$known_paths) {
152 my $v = $known_paths->{$k};
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';
158 unless ( $v->{abs_unix_path} ) {
159 if ( $v->{rel_path} ) {
160 $v->{abs_unix_path} = abs_unix_path( $v->{rel_path} );
162 elsif ( $Config{ $v->{config_key} || '' } ) {
163 $v->{abs_unix_path} = abs_unix_path (
164 $Config{"$v->{config_key}exp"} || $Config{$v->{config_key}}
169 delete $known_paths->{$k} unless $v->{abs_unix_path} and -d $v->{abs_unix_path};
171 my $seen_markers = {};
173 # first run through lib/ and *try* to load anything we can find
174 # within our own project
179 $_ =~ m|lib/DBIx/Class/_TempExtlib| and return;
181 # can't just `require $fn`, as we need %INC to be
183 my ($mod) = $_ =~ /^ lib [\/\\] (.+) \.pm $/x
186 try_module_require(join ('::', File::Spec->splitdir($mod)) )
193 # now run through OptDeps and attempt loading everything else
195 # some things needs to be sorted before other things
196 # positive - load first
197 # negative - load last
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,
204 my @known_modules = sort
205 { ($load_weights->{$b}||0) <=> ($load_weights->{$a}||0) }
208 DBIx::Class::Optional::Dependencies->req_list_for([
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}
219 try_module_require($_) for @known_modules;
221 my $has_versionpm = eval { require version };
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;
230 for my $mod (@known_modules) {
231 my $inc_key = module_notional_filename($mod);
232 next if defined $INC{$inc_key};
234 if (defined( my $idx = module_found_at_inc_index( $mod, \@INC ) ) ) {
235 $known_failed_loads->{$mod} = abs_unix_path( "$INC[$idx]/$inc_key" );
242 # This is a cool idea, but the line is too long even with shortening :(
244 #for my $i ( 1 .. $Config{config_argc} ) {
245 # my $conf_arg = $Config{"config_arg$i"};
249 # '=' . shorten_fn($1)
252 # $perl .= " $conf_arg";
255 my $interesting_modules = {
259 abs_unix_path => abs_unix_path($^X),
264 # drill through the *ENTIRE* symtable and build a map of interesting modules
265 visit_namespaces( action => sub {
269 # keep going, but nothing to see here
270 return 1 if $pkg eq 'main';
272 # private - not interested, including no further descent
273 return 0 if $pkg =~ / (?: ^ | :: ) _ /x;
275 my $inc_key = module_notional_filename($pkg);
277 my $abs_unix_path = (
284 abs_unix_path($INC{$inc_key})
287 # handle versions first (not interested in synthetic classes)
289 defined ${"${pkg}::VERSION"}
291 ${"${pkg}::VERSION"} !~ /\Qset by base.pm/
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 };
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"
306 elsif( ! defined $mod_ver or ! length $mod_ver ) {
307 my $ret = defined $mod_ver
308 ? "the empty string ''"
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."
324 defined ( my $eumm_ver = eval { MM->parse_version( $abs_unix_path ) } )
327 # can only run the check reliably if v.pm is there
333 $eumm_ver ne $mod_ver
336 ( eval { version->parse( do { (my $v = $eumm_ver) =~ s/_//g; $v } ) } || 0 )
338 ( eval { version->parse( do { (my $v = $mod_ver) =~ s/_//g; $v } ) } || 0 )
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 "
351 $interesting_modules->{$pkg}{version} = $eumm_ver;
353 elsif( defined $mod_ver ) {
355 $interesting_modules->{$pkg}{version} = $mod_ver;
358 elsif ( $known_failed_loads->{$pkg} ) {
359 $abs_unix_path = $known_failed_loads->{$pkg};
360 $interesting_modules->{$pkg}{version} = '!! LOAD FAIL !!';
363 if ($abs_unix_path) {
364 my ($marker, $initial_inc_idx);
366 my $current_inc_idx = module_found_at_inc_index($pkg, \@INC);
367 my $p = subpath_of_known_path( $abs_unix_path );
370 defined $current_inc_idx
374 abs_unix_path($INC[$current_inc_idx]) eq $p->{abs_unix_path}
376 $marker = $p->{marker};
378 elsif (defined ( $initial_inc_idx = module_found_at_inc_index($pkg, \@initial_INC) ) ) {
379 $marker = "\$INC[$initial_inc_idx]";
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
388 $interesting_modules->{$pkg}
390 !$p->{skip_unversioned_modules}
393 $interesting_modules->{$pkg}{source_marker} = $marker;
394 $seen_markers->{$marker} = 1;
397 # at this point only fill in the path (md5 calc) IFF it is interesting
399 $interesting_modules->{$pkg}{abs_unix_path} = $abs_unix_path
400 if $interesting_modules->{$pkg};
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 ]);
412 ok 1, (scalar keys %$interesting_modules) . " distinctly versioned modules found";
414 # do not announce anything under ci - we are watching for STDERR silence
415 exit 0 if DBICTest::RunMode->is_ci;
418 # diag the result out
419 my $max_ver_len = max map
421 ( 'xxx.yyyzzz_bbb', map { $_->{version} || '' } values %$interesting_modules )
423 my $max_marker_len = max map { length $_ } ( '$INC[999]', keys %$seen_markers );
425 # Note - must be less than 76 chars wide to account for the diag() prefix
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)
432 *** Note that *MANY* of these modules will *NEVER* be loaded ***
433 *** during normal operation of DBIx::Class ***
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";
440 $final_out .= "\@INC at startup (does not reflect manipulation at runtime):\n";
443 for (0.. $#initial_INC) {
445 my $shortname = shorten_fn( $initial_INC[$_] );
447 # when *to* print a line of INC
449 ! $ENV{AUTOMATED_TESTING}
453 $seen_markers->{"\$INC[$_]"}
457 ! File::Spec->file_name_is_absolute($shortname)
460 $final_out .= sprintf ( "% 3s: %s\n",
465 elsif(! $in_inc_skip++) {
466 $final_out .= " ...\n";
472 if (my @seen_known_paths = grep { $known_paths->{$_} } keys %$seen_markers) {
474 $final_out .= join "\n", 'Sourcing markers:', (map
477 $max_marker_len => $_->{marker},
478 ($_->{config_key} ? "\$Config{$_->{config_key}}" : "$_->{rel_path}/" )
482 !!$b->{config_key} cmp !!$a->{config_key}
484 ( $a->{marker}||'') cmp ($b->{marker}||'')
486 @{$known_paths}{@seen_known_paths}
491 $final_out .= "=============================\n";
493 $final_out .= join "\n", (map
496 $max_marker_len => $interesting_modules->{$_}{source_marker} || '',
497 $max_ver_len => ( defined $interesting_modules->{$_}{version}
498 ? $interesting_modules->{$_}{version}
502 ($interesting_modules->{$_}{abs_unix_path}
503 ? " [ MD5: @{[ get_md5( $interesting_modules->{$_}{abs_unix_path} ) ]} ]"
504 : "! -f \$INC{'@{[ module_notional_filename($_) ]}'}"
507 sort { lc($a) cmp lc($b) } keys %$interesting_modules
510 $final_out .= "=============================\n$discl\n\n";
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 );
523 sub say_err { print STDERR "\n", @_, "\n\n" };
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 {};
530 eval "require $_[0]";
537 ( -e $_[0] or File::Spec->file_name_is_absolute($_[0]) )
540 # File::Spec's rel2abs does not resolve symlinks
541 # we *need* to look at the filesystem to be sure
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
547 my $abs_fn = eval { abs_path($_[0]) } || '';
549 if ( $abs_fn and $^O eq 'MSWin32' ) {
551 # sometimes we can get a short/longname mix, normalize everything to longnames
552 $abs_fn = Win32::GetLongPathName($abs_fn)
555 # Fixup (native) slashes in Config not matching (unixy) slashes in INC
565 my $abs_fn = abs_unix_path($fn);
567 if ($abs_fn and my $p = subpath_of_known_path( $fn ) ) {
568 $abs_fn =~ s| (?<! / ) $|/|x
571 if ($p->{rel_path}) {
572 $abs_fn =~ s!\Q$p->{abs_unix_path}!$p->{rel_path}!
575 elsif ($p->{config_key}) {
576 $abs_fn =~ s!\Q$p->{abs_unix_path}!<<$p->{marker}>>!
578 $seen_markers->{$p->{marker}} = 1
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 ) )
591 $rv = "( ! -e ) $rv" unless -e $rv;
596 sub subpath_of_known_path {
597 my $abs_fn = abs_unix_path( $_[0] )
602 length( $b->{abs_unix_path} ) <=> length( $a->{abs_unix_path} )
604 ( $a->{match_order} || 0 ) <=> ( $b->{match_order} || 0 )
608 # run through the matcher twice - first always append a /
610 # important to avoid false positives
611 for my $suff ( '/', '' ) {
612 return { %$p } if 0 == index( $abs_fn, "$p->{abs_unix_path}$suff" );
617 sub module_found_at_inc_index {
618 my ($mod, $inc_dirs) = @_;
620 return undef unless @$inc_dirs;
622 my $fn = module_notional_filename($mod);
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 ) {
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];
634 if 0 == index( $existing_path, abs_unix_path( $inc_dirs->[$i] ) . '/' );
638 for my $i ( 0 .. $#$inc_dirs ) {
643 -f "$inc_dirs->[$i]/$fn"
645 -r "$inc_dirs->[$i]/$fn"
654 sub purge_identically_versioned_submodules_with_markers {
657 return unless @$markers;
659 for my $mod ( sort { length($b) <=> length($a) } keys %$interesting_modules ) {
661 next unless defined $interesting_modules->{$mod}{version};
663 my $marker = $interesting_modules->{$mod}{source_marker}
666 next unless grep { $marker eq $_ } @$markers;
670 while ( $parent =~ s/ :: (?: . (?! :: ) )+ $ //x ) {
671 $interesting_modules->{$parent}
673 ($interesting_modules->{$parent}{version}||'') eq $interesting_modules->{$mod}{version}
675 ($interesting_modules->{$parent}{source_marker}||'') eq $interesting_modules->{$mod}{source_marker}
677 delete $interesting_modules->{$mod}
684 sub module_notional_filename {
685 (my $fn = $_[0] . '.pm') =~ s|::|/|g;
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;