Codebase list libdbix-class-perl / 645e7af
Port t/00describe_environment as seen in master Not adding a dep - too obnoxious in a maint Peter Rabbitson 7 years ago
1 changed file(s) with 573 addition(s) and 256 deletion(s). Raw diff Collapse all Expand all
+573
-256
t/00describe_environment.t less more
22 ### It certainly can be rewritten to degrade well on 5.6
33 ###
44
5
5 # Very important to grab the snapshot early, as we will be reporting
6 # the INC indices from the POV of whoever ran the script, *NOT* from
7 # the POV of the internals
8 my @initial_INC;
69 BEGIN {
7 if ($] < 5.010) {
10 @initial_INC = @INC;
11 }
12
13 BEGIN {
14 local @INC = ( 't/lib', @INC );
15
16
17 if ( "$]" < 5.010) {
818
919 # Pre-5.10 perls pollute %INC on unsuccesfull module
1020 # require, making it appear as if the module is already
2131 # we want to do this here, in the very beginning, before even
2232 # warnings/strict are loaded
2333
24 unshift @INC, 't/lib';
2534 require DBICTest::Util::OverrideRequire;
2635
2736 DBICTest::Util::OverrideRequire::override_global_require( sub {
3241 }
3342 return $res;
3443 } );
35 }
36 }
37
38 # Explicitly add 'lib' to the front of INC - this way we will
39 # know without ambiguity what was loaded from the local untar
40 # and what came from elsewhere
41 use lib qw(lib t/lib);
44
45 }
46
47 require DBICTest::RunMode;
48 require DBICTest::Util;
49 }
4250
4351 use strict;
4452 use warnings;
4654 use Test::More 'no_plan';
4755 use Config;
4856 use File::Find 'find';
49 use Module::Runtime 'module_notional_filename';
50 use List::Util qw(max min);
57 use Digest::MD5 ();
58 use Cwd 'abs_path';
59 use File::Spec;
60 use List::Util 'max';
5161 use ExtUtils::MakeMaker;
52 use DBICTest::Util 'visit_namespaces';
53
54 # load these two to pull in the t/lib armada
55 use DBICTest;
56 use DBICTest::Schema;
57 DBICTest->init_schema;
58
59 # do !!!NOT!!! use Module::Runtime's require_module - it breaks CORE::require
60 sub req_mod ($) {
61 # trap deprecation warnings and whatnot
62 local $SIG{__WARN__} = sub {};
63 local $@;
64 eval "require $_[0]";
65 }
66
67 sub say_err {
68 print STDERR "\n", @_, "\n";
69 }
70
71 # needed for WeirdOS
72 sub fixup_path ($) {
73 return $_[0] unless ( $^O eq 'MSWin32' and $_[0] );
74
75 # sometimes we can get a short/longname mix, normalize everything to longnames
76 my $fn = Win32::GetLongPathName($_[0]);
77
78 # Fixup (native) slashes in Config not matching (unixy) slashes in INC
79 $fn =~ s|\\|/|g;
80
81 $fn;
82 }
83
84 my @lib_display_order = qw(
85 sitearch
86 sitelib
87 vendorarch
88 vendorlib
89 archlib
90 privlib
91 );
92 my $lib_paths = {
93 (map
94 { $Config{$_}
95 ? ( $_ => fixup_path( $Config{"${_}exp"} || $Config{$_} ) )
96 : ()
97 }
98 @lib_display_order
99 ),
100
101 # synthetic, for display
102 './lib' => 'lib',
62
63 use DBIx::Class::Optional::Dependencies;
64
65 my $known_paths = {
66 SA => {
67 config_key => 'sitearch',
68 },
69 SL => {
70 config_key => 'sitelib',
71 },
72 SS => {
73 config_key => 'sitelib_stem',
74 match_order => 1,
75 },
76 SP => {
77 config_key => 'siteprefix',
78 match_order => 2,
79 },
80 VA => {
81 config_key => 'vendorarch',
82 },
83 VL => {
84 config_key => 'vendorlib',
85 },
86 VS => {
87 config_key => 'vendorlib_stem',
88 match_order => 3,
89 },
90 VP => {
91 config_key => 'vendorprefix',
92 match_order => 4,
93 },
94 PA => {
95 config_key => 'archlib',
96 },
97 PL => {
98 config_key => 'privlib',
99 },
100 PP => {
101 config_key => 'prefix',
102 match_order => 5,
103 },
104 BLA => {
105 rel_path => './blib/arch',
106 skip_unversioned_modules => 1,
107 },
108 BLL => {
109 rel_path => './blib/lib',
110 skip_unversioned_modules => 1,
111 },
112 INC => {
113 rel_path => './inc',
114 },
115 LIB => {
116 rel_path => './lib',
117 skip_unversioned_modules => 1,
118 },
119 T => {
120 rel_path => './t',
121 skip_unversioned_modules => 1,
122 },
123 XT => {
124 rel_path => './xt',
125 skip_unversioned_modules => 1,
126 },
127 CWD => {
128 rel_path => '.',
129 },
130 HOME => {
131 rel_path => '~',
132 abs_unix_path => abs_unix_path (
133 eval { require File::HomeDir and File::HomeDir->my_home }
134 ||
135 $ENV{USERPROFILE}
136 ||
137 $ENV{HOME}
138 ||
139 glob('~')
140 ),
141 },
103142 };
104143
105 sub describe_fn {
106 my $fn = shift;
107
108 return '' if !defined $fn;
109
110 $fn = fixup_path( $fn );
111
112 $lib_paths->{$_} and $fn =~ s/^\Q$lib_paths->{$_}/<<$_>>/ and last
113 for @lib_display_order;
114
115 $fn;
116 }
117
118 sub md5_of_fn {
119 # we already checked for -r/-f, just bail if can't open
120 open my $fh, '<:raw', $_[0] or return '';
121 require Digest::MD5;
122 Digest::MD5->new->addfile($fh)->hexdigest;
123 }
124
125 # first run through lib and *try* to load anything we can find
144 for my $k (keys %$known_paths) {
145 my $v = $known_paths->{$k};
146
147 # never use home as a found-in-dir marker - it is too broad
148 # HOME is only used by the shortener
149 $v->{marker} = $k unless $k eq 'HOME';
150
151 unless ( $v->{abs_unix_path} ) {
152 if ( $v->{rel_path} ) {
153 $v->{abs_unix_path} = abs_unix_path( $v->{rel_path} );
154 }
155 elsif ( $Config{ $v->{config_key} || '' } ) {
156 $v->{abs_unix_path} = abs_unix_path (
157 $Config{"$v->{config_key}exp"} || $Config{$v->{config_key}}
158 );
159 }
160 }
161
162 delete $known_paths->{$k} unless $v->{abs_unix_path} and -d $v->{abs_unix_path};
163 }
164 my $seen_markers = {};
165
166 # first run through lib/ and *try* to load anything we can find
126167 # within our own project
127168 find({
128169 wanted => sub {
129170 -f $_ or return;
130171
172 $_ =~ m|lib/DBIx/Class/_TempExtlib| and return;
173
131174 # can't just `require $fn`, as we need %INC to be
132175 # populated properly
133176 my ($mod) = $_ =~ /^ lib [\/\\] (.+) \.pm $/x
134177 or return;
135178
136 req_mod join ('::', File::Spec->splitdir($mod));
179 try_module_require(join ('::', File::Spec->splitdir($mod)) )
137180 },
138181 no_chdir => 1,
139182 }, 'lib' );
183
184
140185
141186 # now run through OptDeps and attempt loading everything else
142187 #
149194 "DBD::Oracle" => -999,
150195 };
151196
152 my $optdeps = {
197 my @known_modules = sort
198 { ($load_weights->{$b}||0) <=> ($load_weights->{$a}||0) }
199 qw( Data::Dumper ),
153200 map
154201 { $_ => 1 }
155202 map
156 { keys %{DBIx::Class::Optional::Dependencies->req_list_for($_)} }
203 { keys %{ DBIx::Class::Optional::Dependencies->req_list_for($_) } }
157204 grep
158 { $_ !~ /rdbms/ }
205 # some DBDs are notoriously problematic to load
206 # hence only show stuff based on test_rdbms which will
207 # take into account necessary ENVs
208 { $_ !~ /^ (?: rdbms | dist )_ /x }
159209 keys %{DBIx::Class::Optional::Dependencies->req_group_list}
210 ;
211
212 try_module_require($_) for @known_modules;
213
214 my $has_versionpm = eval { require version };
215
216
217 # At this point we've loaded everything we ever could, but some modules
218 # (understandably) crapped out. For an even more thorough report, note
219 # everthing present in @INC we excplicitly know about (via OptDeps)
220 # *even though* it didn't load
221 my $known_failed_loads;
222
223 for my $mod (@known_modules) {
224 my $inc_key = module_notional_filename($mod);
225 next if defined $INC{$inc_key};
226
227 if (defined( my $idx = module_found_at_inc_index( $mod, \@INC ) ) ) {
228 $known_failed_loads->{$mod} = abs_unix_path( "$INC[$idx]/$inc_key" );
229 }
230
231 }
232
233 my $perl = 'perl';
234
235 # This is a cool idea, but the line is too long even with shortening :(
236 #
237 #for my $i ( 1 .. $Config{config_argc} ) {
238 # my $conf_arg = $Config{"config_arg$i"};
239 # $conf_arg =~ s!
240 # \= (.+)
241 # !
242 # '=' . shorten_fn($1)
243 # !ex;
244 #
245 # $perl .= " $conf_arg";
246 #}
247
248 my $interesting_modules = {
249 # pseudo module
250 $perl => {
251 version => $],
252 abs_unix_path => abs_unix_path($^X),
253 }
160254 };
161 req_mod $_ for sort
162 { ($load_weights->{$b}||0) <=> ($load_weights->{$a}||0) }
163 keys %$optdeps
164 ;
165
166 my $has_versionpm = eval { require version };
167
168 # at this point we've loaded everything we ever could, let's drill through
169 # the *ENTIRE* symtable and build a map of versions
170 my $version_list = { perl => $] };
171 visit_namespaces( action => sub {
255
256
257 # drill through the *ENTIRE* symtable and build a map of interesting modules
258 DBICTest::Util::visit_namespaces( action => sub {
172259 no strict 'refs';
173260 my $pkg = shift;
174261
178265 # private - not interested, including no further descent
179266 return 0 if $pkg =~ / (?: ^ | :: ) _ /x;
180267
181 # not interested in no-VERSION-containing modules, nor synthetic classes
182 return 1 if (
183 ! defined ${"${pkg}::VERSION"}
184 or
185 ${"${pkg}::VERSION"} =~ /\Qset by base.pm/
268 my $inc_key = module_notional_filename($pkg);
269
270 my $abs_unix_path = (
271 $INC{$inc_key}
272 and
273 -f $INC{$inc_key}
274 and
275 -r $INC{$inc_key}
276 and
277 abs_unix_path($INC{$inc_key})
186278 );
187279
188 # make sure a version can be extracted, be noisy when it doesn't work
189 # do this even if we are throwing away the result below in lieu of EUMM
190 my $mod_ver = eval { $pkg->VERSION };
191 if (my $err = $@) {
192 $err =~ s/^/ /mg;
193 say_err
194 "Calling `$pkg->VERSION` resulted in an exception, which should never "
195 . "happen - please file a bug with the distribution containing $pkg. "
196 . "Complete exception text below:\n\n$err"
197 ;
198 }
199 elsif( ! defined $mod_ver or ! length $mod_ver ) {
200 my $ret = defined $mod_ver
201 ? "the empty string ''"
202 : "'undef'"
203 ;
204
205 say_err
206 "Calling `$pkg->VERSION` returned $ret, even though \$${pkg}::VERSION "
207 . "is defined, which should never happen - please file a bug with the "
208 . "distribution containing $pkg."
209 ;
210
211 undef $mod_ver;
212 }
213
214 # if this is a real file - extract the version via EUMM whenever possible
215 my $fn = $INC{module_notional_filename($pkg)};
216
217 my $eumm_ver = (
218 $fn
280 # handle versions first (not interested in synthetic classes)
281 if (
282 defined ${"${pkg}::VERSION"}
219283 and
220 -f $fn
221 and
222 -r $fn
223 and
224 eval { MM->parse_version( $fn ) }
225 ) || undef;
226
227 if (
228 $has_versionpm
229 and
230 defined $eumm_ver
231 and
232 defined $mod_ver
233 and
234 $eumm_ver ne $mod_ver
235 and
236 (
237 ( eval { version->parse( do { (my $v = $eumm_ver) =~ s/_//g; $v } ) } || 0 )
238 !=
239 ( eval { version->parse( do { (my $v = $mod_ver) =~ s/_//g; $v } ) } || 0 )
240 )
284 ${"${pkg}::VERSION"} !~ /\Qset by base.pm/
241285 ) {
242 say_err
243 "Mismatch of versions '$mod_ver' and '$eumm_ver', obtained respectively "
244 . "via `$pkg->VERSION` and parsing the version out of @{[ describe_fn $fn ]} "
245 . "with ExtUtils::MakeMaker\@@{[ ExtUtils::MakeMaker->VERSION ]}. "
246 . "This should never happen - please check whether this is still present "
247 . "in the latest version, and then file a bug with the distribution "
248 . "containing $pkg."
249 ;
250 }
251
252 if( defined $eumm_ver ) {
253 $version_list->{$pkg} = $eumm_ver;
254 }
255 elsif( defined $mod_ver ) {
256 $version_list->{$pkg} = $mod_ver;
286
287 # make sure a version can be extracted, be noisy when it doesn't work
288 # do this even if we are throwing away the result below in lieu of EUMM
289 my $mod_ver = eval { $pkg->VERSION };
290
291 if (my $err = $@) {
292 $err =~ s/^/ /mg;
293 say_err (
294 "Calling `$pkg->VERSION` resulted in an exception, which should never "
295 . "happen - please file a bug with the distribution containing $pkg. "
296 . "Complete exception text below:\n\n$err"
297 );
298 }
299 elsif( ! defined $mod_ver or ! length $mod_ver ) {
300 my $ret = defined $mod_ver
301 ? "the empty string ''"
302 : "'undef'"
303 ;
304
305 say_err (
306 "Calling `$pkg->VERSION` returned $ret, even though \$${pkg}::VERSION "
307 . "is defined, which should never happen - please file a bug with the "
308 . "distribution containing $pkg."
309 );
310
311 undef $mod_ver;
312 }
313
314 if (
315 $abs_unix_path
316 and
317 defined ( my $eumm_ver = eval { MM->parse_version( $abs_unix_path ) } )
318 ) {
319
320 # can only run the check reliably if v.pm is there
321 if (
322 $has_versionpm
323 and
324 defined $mod_ver
325 and
326 $eumm_ver ne $mod_ver
327 and
328 (
329 ( eval { version->parse( do { (my $v = $eumm_ver) =~ s/_//g; $v } ) } || 0 )
330 !=
331 ( eval { version->parse( do { (my $v = $mod_ver) =~ s/_//g; $v } ) } || 0 )
332 )
333 ) {
334 say_err (
335 "Mismatch of versions '$mod_ver' and '$eumm_ver', obtained respectively "
336 . "via `$pkg->VERSION` and parsing the version out of @{[ shorten_fn( $abs_unix_path ) ]} "
337 . "with ExtUtils::MakeMaker\@@{[ ExtUtils::MakeMaker->VERSION ]}. "
338 . "This should never happen - please check whether this is still present "
339 . "in the latest version, and then file a bug with the distribution "
340 . "containing $pkg."
341 );
342 }
343
344 $interesting_modules->{$pkg}{version} = $eumm_ver;
345 }
346 elsif( defined $mod_ver ) {
347
348 $interesting_modules->{$pkg}{version} = $mod_ver;
349 }
350 }
351 elsif ( $known_failed_loads->{$pkg} ) {
352 $abs_unix_path = $known_failed_loads->{$pkg};
353 $interesting_modules->{$pkg}{version} = '!! LOAD FAIL !!';
354 }
355
356 if ($abs_unix_path) {
357 my ($marker, $initial_inc_idx);
358
359 my $current_inc_idx = module_found_at_inc_index($pkg, \@INC);
360 my $p = subpath_of_known_path( $abs_unix_path );
361
362 if (
363 defined $current_inc_idx
364 and
365 $p->{marker}
366 and
367 abs_unix_path($INC[$current_inc_idx]) eq $p->{abs_unix_path}
368 ) {
369 $marker = $p->{marker};
370 }
371 elsif (defined ( $initial_inc_idx = module_found_at_inc_index($pkg, \@initial_INC) ) ) {
372 $marker = "\$INC[$initial_inc_idx]";
373 }
374
375 # we are only interested if there was a declared version already above
376 # OR if the module came from somewhere other than skip_unversioned_modules
377 if (
378 $marker
379 and
380 (
381 $interesting_modules->{$pkg}
382 or
383 !$p->{skip_unversioned_modules}
384 )
385 ) {
386 $interesting_modules->{$pkg}{source_marker} = $marker;
387 $seen_markers->{$marker} = 1;
388 }
389
390 # at this point only fill in the path (md5 calc) IFF it is interesting
391 # in any respect
392 $interesting_modules->{$pkg}{abs_unix_path} = $abs_unix_path
393 if $interesting_modules->{$pkg};
257394 }
258395
259396 1;
260397 });
261398
262 # In retrospect it makes little sense to omit this information - just
263 # show everything at all times.
264 # Nevertheless leave the dead code, in case it turns out to be a bad idea...
265 my $show_all = 1;
266 #my $show_all = $ENV{PERL_DESCRIBE_ALL_DEPS} || !DBICTest::RunMode->is_plain;
267
268 # compress identical versions as close to the root as we can
269 # unless we are dealing with a smoker - in which case we want
270 # to see every MD5 there is
271 unless ($show_all) {
272 for my $mod ( sort { length($b) <=> length($a) } keys %$version_list ) {
273 my $parent = $mod;
274
275 while ( $parent =~ s/ :: (?: . (?! :: ) )+ $ //x ) {
276 $version_list->{$parent}
277 and
278 $version_list->{$parent} eq $version_list->{$mod}
279 and
280 ( ( delete $version_list->{$mod} ) or 1 )
281 and
282 last
283 }
284 }
285 }
286
287 ok 1, (scalar keys %$version_list) . " distinctly versioned modules";
288
289 exit if ($ENV{TRAVIS}||'') eq 'true';
290
291 # sort stuff into @INC segments
292 my $segments;
293
294 MODULE:
295 for my $mod ( sort { lc($a) cmp lc($b) } keys %$version_list ) {
296 my $fn = $INC{module_notional_filename($mod)};
297
298 my $tuple = [ $mod ];
299
300 if ( defined $fn && -f $fn && -r $fn ) {
301 push @$tuple, ( $fn = fixup_path($fn) );
302
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;
306 next MODULE;
307 }
308 }
309 }
310
311 # fallthrough for anything without a physical filename, or unknown lib
312 push @{$segments->{''}}, $tuple;
313 }
399 # compress identical versions sourced from ./blib, ./lib, ./t and ./xt
400 # as close to the root of a namespace as we can
401 purge_identically_versioned_submodules_with_markers([ map {
402 ( $_->{skip_unversioned_modules} && $_->{marker} ) || ()
403 } values %$known_paths ]);
404
405 ok 1, (scalar keys %$interesting_modules) . " distinctly versioned modules found";
406
407 # do not announce anything under ci - we are watching for STDERR silence
408 exit 0 if DBICTest::RunMode->is_ci;
409
314410
315411 # diag the result out
316412 my $max_ver_len = max map
317 { length $_ }
318 ( values %$version_list, 'xxx.yyyzzz_bbb' )
413 { length "$_" }
414 ( 'xxx.yyyzzz_bbb', map { $_->{version} || '' } values %$interesting_modules )
319415 ;
320 my $max_mod_len = max map { length $_ } keys %$version_list;
416 my $max_marker_len = max map { length $_ } ( '$INC[999]', keys %$seen_markers );
321417
322418 my $discl = <<'EOD';
323419
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
420 List of loadable modules within both the core and *OPTIONAL* dependency chains
421 present on this system (modules sourced from ./blib, ./lib, ./t, and ./xt
422 with versions identical to their parent namespace were omitted for brevity)
423
424 *** Note that *MANY* of these modules will *NEVER* be loaded ***
425 *** during normal operation of DBIx::Class ***
326426 EOD
327427
328 $discl .= "(modules with versions identical to their parent namespace were omitted - set PERL_DESCRIBE_ALL_DEPS to see them)\n"
329 unless $show_all;
330
331 diag $discl;
332
333 diag "\n";
334
335 for my $seg ( '', @lib_display_order, './lib' ) {
336 next unless $segments->{$seg};
337
338 diag sprintf "=== %s ===\n\n",
339 $seg
340 ? "Modules found in " . ( $Config{$seg} ? "\$Config{$seg}" : $seg )
341 : 'Misc versions'
342 ;
343
344 diag sprintf (
345 "%*s %*s%s\n",
346 $max_ver_len => $version_list->{$_->[0]},
347 -$max_mod_len => $_->[0],
348 ($_->[1]
349 ? ' ' x (80 - min(78, $max_mod_len)) . "[ MD5: @{[ md5_of_fn( $_->[1] ) ]} ]"
428 # pre-assemble everything and print it in one shot
429 # makes it less likely for parallel test execution to insert bogus lines
430 my $final_out = "\n$discl\n";
431
432 $final_out .= "\@INC at startup (does not reflect manipulation at runtime):\n";
433
434 my $in_inc_skip;
435 for (0.. $#initial_INC) {
436
437 my $shortname = shorten_fn( $initial_INC[$_] );
438
439 # when *to* print a line of INC
440 if (
441 ! $ENV{AUTOMATED_TESTING}
442 or
443 @initial_INC < 11
444 or
445 $seen_markers->{"\$INC[$_]"}
446 or
447 ! -e $shortname
448 or
449 ! File::Spec->file_name_is_absolute($shortname)
450 ) {
451 $in_inc_skip = 0;
452 $final_out .= sprintf ( "% 3s: %s\n",
453 $_,
454 $shortname
455 );
456 }
457 elsif(! $in_inc_skip++) {
458 $final_out .= " ...\n";
459 }
460 }
461
462 $final_out .= "\n";
463
464 if (my @seen_known_paths = grep { $known_paths->{$_} } keys %$seen_markers) {
465
466 $final_out .= join "\n", 'Sourcing markers:', (map
467 {
468 sprintf "%*s: %s",
469 $max_marker_len => $_->{marker},
470 ($_->{config_key} ? "\$Config{$_->{config_key}}" : "$_->{rel_path}/" )
471 }
472 sort
473 {
474 !!$b->{config_key} cmp !!$a->{config_key}
475 or
476 ( $a->{marker}||'') cmp ($b->{marker}||'')
477 }
478 @{$known_paths}{@seen_known_paths}
479 ), '', '';
480
481 }
482
483 $final_out .= "=============================\n";
484
485 $final_out .= join "\n", (map
486 { sprintf (
487 "%*s %*s %*s%s",
488 $max_marker_len => $interesting_modules->{$_}{source_marker} || '',
489 $max_ver_len => ( defined $interesting_modules->{$_}{version}
490 ? $interesting_modules->{$_}{version}
350491 : ''
351492 ),
352 ) for @{$segments->{$seg}};
353
354 diag "\n\n"
355 }
356
357 diag "$discl\n";
493 -78 => $_,
494 ($interesting_modules->{$_}{abs_unix_path}
495 ? " [ MD5: @{[ get_md5( $interesting_modules->{$_}{abs_unix_path} ) ]} ]"
496 : "! -f \$INC{'@{[ module_notional_filename($_) ]}'}"
497 ),
498 ) }
499 sort { lc($a) cmp lc($b) } keys %$interesting_modules
500 ), '';
501
502 $final_out .= "=============================\n$discl\n\n";
503
504 diag $final_out;
505
506 exit 0;
507
508
509
510 sub say_err { print STDERR "\n", @_, "\n\n" };
511
512 # do !!!NOT!!! use Module::Runtime's require_module - it breaks CORE::require
513 sub try_module_require {
514 # trap deprecation warnings and whatnot
515 local $SIG{__WARN__} = sub {};
516 local $@;
517 eval "require $_[0]";
518 }
519
520 sub abs_unix_path {
521 return '' unless (
522 defined $_[0]
523 and
524 ( -e $_[0] or File::Spec->file_name_is_absolute($_[0]) )
525 );
526
527 # File::Spec's rel2abs does not resolve symlinks
528 # we *need* to look at the filesystem to be sure
529 my $abs_fn = abs_path($_[0]);
530
531 if ( $^O eq 'MSWin32' and $abs_fn ) {
532
533 # sometimes we can get a short/longname mix, normalize everything to longnames
534 $abs_fn = Win32::GetLongPathName($abs_fn);
535
536 # Fixup (native) slashes in Config not matching (unixy) slashes in INC
537 $abs_fn =~ s|\\|/|g;
538 }
539
540 $abs_fn;
541 }
542
543 sub shorten_fn {
544 my $fn = shift;
545
546 my $abs_fn = abs_unix_path($fn);
547
548 if (my $p = subpath_of_known_path( $fn ) ) {
549 $abs_fn =~ s| (?<! / ) $|/|x
550 if -d $abs_fn;
551
552 if ($p->{rel_path}) {
553 $abs_fn =~ s!\Q$p->{abs_unix_path}!$p->{rel_path}!
554 and return $abs_fn;
555 }
556 elsif ($p->{config_key}) {
557 $abs_fn =~ s!\Q$p->{abs_unix_path}!<<$p->{marker}>>!
558 and
559 $seen_markers->{$p->{marker}} = 1
560 and
561 return $abs_fn;
562 }
563 }
564
565 # we got so far - not a known path
566 # return the unixified version it if was absolute, leave as-is otherwise
567 my $rv = ( $abs_fn and File::Spec->file_name_is_absolute( $fn ) )
568 ? $abs_fn
569 : $fn
570 ;
571
572 $rv = "( ! -e ) $rv" unless -e $rv;
573
574 return $rv;
575 }
576
577 sub subpath_of_known_path {
578 my $abs_fn = abs_unix_path( $_[0] )
579 or return '';
580
581 for my $p (
582 sort {
583 length( $b->{abs_unix_path} ) <=> length( $a->{abs_unix_path} )
584 or
585 ( $a->{match_order} || 0 ) <=> ( $b->{match_order} || 0 )
586 }
587 values %$known_paths
588 ) {
589 # run through the matcher twice - first always append a /
590 # then try without
591 # important to avoid false positives
592 for my $suff ( '/', '' ) {
593 return { %$p } if 0 == index( $abs_fn, "$p->{abs_unix_path}$suff" );
594 }
595 }
596 }
597
598 sub module_found_at_inc_index {
599 my ($mod, $inc_dirs) = @_;
600
601 return undef unless @$inc_dirs;
602
603 my $fn = module_notional_filename($mod);
604
605 # trust INC if it specifies an existing path
606 if( -f ( my $existing_path = abs_unix_path( $INC{$fn} ) ) ) {
607 for my $i ( 0 .. $#$inc_dirs ) {
608
609 # searching from here on out won't mean anything
610 # FIXME - there is actually a way to interrogate this safely, but
611 # that's a fight for another day
612 return undef if length ref $inc_dirs->[$i];
613
614 return $i
615 if 0 == index( $existing_path, abs_unix_path( $inc_dirs->[$i] ) . '/' );
616 }
617 }
618
619 for my $i ( 0 .. $#$inc_dirs ) {
620
621 if (
622 -d $inc_dirs->[$i]
623 and
624 -f "$inc_dirs->[$i]/$fn"
625 and
626 -r "$inc_dirs->[$i]/$fn"
627 ) {
628 return $i;
629 }
630 }
631
632 return undef;
633 }
634
635 sub purge_identically_versioned_submodules_with_markers {
636 my $markers = shift;
637
638 return unless @$markers;
639
640 for my $mod ( sort { length($b) <=> length($a) } keys %$interesting_modules ) {
641
642 next unless defined $interesting_modules->{$mod}{version};
643
644 my $marker = $interesting_modules->{$mod}{source_marker}
645 or next;
646
647 next unless grep { $marker eq $_ } @$markers;
648
649 my $parent = $mod;
650
651 while ( $parent =~ s/ :: (?: . (?! :: ) )+ $ //x ) {
652 $interesting_modules->{$parent}
653 and
654 ($interesting_modules->{$parent}{version}||'') eq $interesting_modules->{$mod}{version}
655 and
656 ($interesting_modules->{$parent}{source_marker}||'') eq $interesting_modules->{$mod}{source_marker}
657 and
658 delete $interesting_modules->{$mod}
659 and
660 last
661 }
662 }
663 }
664
665 sub module_notional_filename {
666 (my $fn = $_[0] . '.pm') =~ s|::|/|g;
667 $fn;
668 }
669
670 sub get_md5 {
671 # we already checked for -r/-f, just bail if can't open
672 open my $fh, '<:raw', $_[0] or return '';
673 Digest::MD5->new->addfile($fh)->hexdigest;
674 }