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
10 # Pre-5.10 perls pollute %INC on unsuccesfull module
11 # require, making it appear as if the module is already
12 # loaded on subsequent require()s
13 # Can't seem to find the exact RT/perldelta entry
15 # The reason we can't just use a sane, clean loader, is because
16 # if a Module require()s another module the %INC will still
17 # get filled with crap and we are back to square one. A global
18 # fix is really the only way for this test, as we try to load
19 # each available module separately, and have no control (nor
20 # knowledge) over their common dependencies.
22 # we want to do this here, in the very beginning, before even
23 # warnings/strict are loaded
25 unshift @INC, 't/lib';
26 require DBICTest::Util::OverrideRequire;
28 DBICTest::Util::OverrideRequire::override_global_require( sub {
29 my $res = eval { $_[0]->() };
39 # Explicitly add 'lib' to the front of INC - this way we will
40 # know without ambiguity what was loaded from the local untar
41 # and what came from elsewhere
42 use lib qw(lib t/lib);
47 use Test::More 'no_plan';
49 use File::Find 'find';
50 use Module::Runtime 'module_notional_filename';
51 use List::Util qw(max min);
52 use ExtUtils::MakeMaker;
53 use DBICTest::Util 'visit_namespaces';
55 # load these two to pull in the t/lib armada
59 # do !!!NOT!!! use Module::Runtime's require_module - it breaks CORE::require
61 # trap deprecation warnings and whatnot
62 local $SIG{__WARN__} = sub {};
68 print STDERR "\n", @_, "\n";
73 return $_[0] unless ( $^O eq 'MSWin32' and $_[0] );
75 # sometimes we can get a short/longname mix, normalize everything to longnames
76 my $fn = Win32::GetLongPathName($_[0]);
78 # Fixup (native) slashes in Config not matching (unixy) slashes in INC
84 my @lib_display_order = qw(
95 ? ( $_ => fixup_path( $Config{"${_}exp"} || $Config{$_} ) )
101 # synthetic, for display
108 return '' if !defined $fn;
110 $fn = fixup_path( $fn );
112 $lib_paths->{$_} and $fn =~ s/^\Q$lib_paths->{$_}/<<$_>>/ and last
113 for @lib_display_order;
119 # we already checked for -r/-f, just bail if can't open
120 open my $fh, '<:raw', $_[0] or return '';
122 Digest::MD5->new->addfile($fh)->hexdigest;
125 # first run through lib and *try* to load anything we can find
126 # within our own project
131 # can't just `require $fn`, as we need %INC to be
133 my ($mod) = $_ =~ /^ lib [\/\\] (.+) \.pm $/x
136 req_mod join ('::', File::Spec->splitdir($mod));
141 # now run through OptDeps and attempt loading everything else
143 # some things needs to be sorted before other things
144 # positive - load first
145 # negative - load last
147 # Make sure oracle is tried last - some clients (e.g. 10.2) have symbol
148 # clashes with libssl, and will segfault everything coming after them
149 "DBD::Oracle" => -999,
152 { ($load_weights->{$b}||0) <=> ($load_weights->{$a}||0) }
154 DBIx::Class::Optional::Dependencies->req_list_for([
156 # some DBDs are notoriously problematic to load
157 # hence only show stuff based on test_rdbms which will
158 # take into account necessary ENVs
160 keys %{DBIx::Class::Optional::Dependencies->req_group_list}
165 my $has_versionpm = eval { require version };
167 # at this point we've loaded everything we ever could, let's drill through
168 # the *ENTIRE* symtable and build a map of versions
169 my $version_list = { perl => $] };
170 visit_namespaces( action => sub {
174 # keep going, but nothing to see here
175 return 1 if $pkg eq 'main';
177 # private - not interested, including no further descent
178 return 0 if $pkg =~ / (?: ^ | :: ) _ /x;
180 # not interested in no-VERSION-containing modules, nor synthetic classes
182 ! defined ${"${pkg}::VERSION"}
184 ${"${pkg}::VERSION"} =~ /\Qset by base.pm/
187 # make sure a version can be extracted, be noisy when it doesn't work
188 # do this even if we are throwing away the result below in lieu of EUMM
189 my $mod_ver = eval { $pkg->VERSION };
193 "Calling `$pkg->VERSION` resulted in an exception, which should never "
194 . "happen - please file a bug with the distribution containing $pkg. "
195 . "Complete exception text below:\n\n$err"
198 elsif( ! defined $mod_ver or ! length $mod_ver ) {
199 my $ret = defined $mod_ver
200 ? "the empty string ''"
205 "Calling `$pkg->VERSION` returned $ret, even though \$${pkg}::VERSION "
206 . "is defined, which should never happen - please file a bug with the "
207 . "distribution containing $pkg."
213 # if this is a real file - extract the version via EUMM whenever possible
214 my $fn = $INC{module_notional_filename($pkg)};
223 eval { MM->parse_version( $fn ) }
233 $eumm_ver ne $mod_ver
236 ( eval { version->parse( do { (my $v = $eumm_ver) =~ s/_//g; $v } ) } || 0 )
238 ( eval { version->parse( do { (my $v = $mod_ver) =~ s/_//g; $v } ) } || 0 )
242 "Mismatch of versions '$mod_ver' and '$eumm_ver', obtained respectively "
243 . "via `$pkg->VERSION` and parsing the version out of @{[ describe_fn $fn ]} "
244 . "with ExtUtils::MakeMaker\@@{[ ExtUtils::MakeMaker->VERSION ]}. "
245 . "This should never happen - please check whether this is still present "
246 . "in the latest version, and then file a bug with the distribution "
251 if( defined $eumm_ver ) {
252 $version_list->{$pkg} = $eumm_ver;
254 elsif( defined $mod_ver ) {
255 $version_list->{$pkg} = $mod_ver;
261 # In retrospect it makes little sense to omit this information - just
262 # show everything at all times.
263 # Nevertheless leave the dead code, in case it turns out to be a bad idea...
265 #my $show_all = $ENV{PERL_DESCRIBE_ALL_DEPS} || !DBICTest::RunMode->is_plain;
267 # compress identical versions as close to the root as we can
268 # unless we are dealing with a smoker - in which case we want
269 # to see every MD5 there is
271 for my $mod ( sort { length($b) <=> length($a) } keys %$version_list ) {
274 while ( $parent =~ s/ :: (?: . (?! :: ) )+ $ //x ) {
275 $version_list->{$parent}
277 $version_list->{$parent} eq $version_list->{$mod}
279 ( ( delete $version_list->{$mod} ) or 1 )
286 ok 1, (scalar keys %$version_list) . " distinctly versioned modules";
288 # do not announce anything under ci - we are watching for STDERR silence
289 exit if DBICTest::RunMode->is_ci;
291 # sort stuff into @INC segments
295 for my $mod ( sort { lc($a) cmp lc($b) } keys %$version_list ) {
296 my $fn = $INC{module_notional_filename($mod)};
298 my $tuple = [ $mod ];
300 if ( defined $fn && -f $fn && -r $fn ) {
301 push @$tuple, ( $fn = fixup_path($fn) );
303 for my $lib (@lib_display_order, './lib') {
304 if ( $lib_paths->{$lib} and index($fn, $lib_paths->{$lib}) == 0 ) {
305 push @{$segments->{$lib}}, $tuple;
311 # fallthrough for anything without a physical filename, or unknown lib
312 push @{$segments->{''}}, $tuple;
315 # diag the result out
316 my $max_ver_len = max map
318 ( values %$version_list, 'xxx.yyyzzz_bbb' )
320 my $max_mod_len = max map { length $_ } keys %$version_list;
324 Versions of all loadable modules within both the core and *OPTIONAL* dependency chains present on this system
325 Note that *MANY* of these modules will *NEVER* be loaded during normal operation of DBIx::Class
328 $discl .= "(modules with versions identical to their parent namespace were omitted - set PERL_DESCRIBE_ALL_DEPS to see them)\n"
335 for my $seg ( '', @lib_display_order, './lib' ) {
336 next unless $segments->{$seg};
338 diag sprintf "=== %s ===\n\n",
340 ? "Modules found in " . ( $Config{$seg} ? "\$Config{$seg}" : $seg )
346 $max_ver_len => $version_list->{$_->[0]},
347 -$max_mod_len => $_->[0],
349 ? ' ' x (80 - min(78, $max_mod_len)) . "[ MD5: @{[ md5_of_fn( $_->[1] ) ]} ]"
352 ) for @{$segments->{$seg}};