From: Peter Rabbitson Date: Sat, 18 Jun 2016 10:07:36 +0000 (+0200) Subject: Port t/00describe_environment as seen in master X-Git-Tag: v0.082840~7 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=645e7af473a1c4c488e9c4e6345f4ca19b486001;p=dbsrgits%2FDBIx-Class.git Port t/00describe_environment as seen in master Not adding a dep - too obnoxious in a maint --- diff --git a/t/00describe_environment.t b/t/00describe_environment.t index 07756f2..dd17859 100644 --- a/t/00describe_environment.t +++ b/t/00describe_environment.t @@ -3,9 +3,19 @@ ### It certainly can be rewritten to degrade well on 5.6 ### +# Very important to grab the snapshot early, as we will be reporting +# the INC indices from the POV of whoever ran the script, *NOT* from +# the POV of the internals +my @initial_INC; +BEGIN { + @initial_INC = @INC; +} BEGIN { - if ($] < 5.010) { + local @INC = ( 't/lib', @INC ); + + + if ( "$]" < 5.010) { # Pre-5.10 perls pollute %INC on unsuccesfull module # require, making it appear as if the module is already @@ -22,7 +32,6 @@ BEGIN { # we want to do this here, in the very beginning, before even # warnings/strict are loaded - unshift @INC, 't/lib'; require DBICTest::Util::OverrideRequire; DBICTest::Util::OverrideRequire::override_global_require( sub { @@ -33,13 +42,12 @@ BEGIN { } return $res; } ); + } -} -# Explicitly add 'lib' to the front of INC - this way we will -# know without ambiguity what was loaded from the local untar -# and what came from elsewhere -use lib qw(lib t/lib); + require DBICTest::RunMode; + require DBICTest::Util; +} use strict; use warnings; @@ -47,98 +55,135 @@ use warnings; use Test::More 'no_plan'; use Config; use File::Find 'find'; -use Module::Runtime 'module_notional_filename'; -use List::Util qw(max min); +use Digest::MD5 (); +use Cwd 'abs_path'; +use File::Spec; +use List::Util 'max'; use ExtUtils::MakeMaker; -use DBICTest::Util 'visit_namespaces'; - -# load these two to pull in the t/lib armada -use DBICTest; -use DBICTest::Schema; -DBICTest->init_schema; - -# do !!!NOT!!! use Module::Runtime's require_module - it breaks CORE::require -sub req_mod ($) { - # trap deprecation warnings and whatnot - local $SIG{__WARN__} = sub {}; - local $@; - eval "require $_[0]"; -} - -sub say_err { - print STDERR "\n", @_, "\n"; -} - -# needed for WeirdOS -sub fixup_path ($) { - return $_[0] unless ( $^O eq 'MSWin32' and $_[0] ); - - # sometimes we can get a short/longname mix, normalize everything to longnames - my $fn = Win32::GetLongPathName($_[0]); - - # Fixup (native) slashes in Config not matching (unixy) slashes in INC - $fn =~ s|\\|/|g; - - $fn; -} -my @lib_display_order = qw( - sitearch - sitelib - vendorarch - vendorlib - archlib - privlib -); -my $lib_paths = { - (map - { $Config{$_} - ? ( $_ => fixup_path( $Config{"${_}exp"} || $Config{$_} ) ) - : () - } - @lib_display_order - ), +use DBIx::Class::Optional::Dependencies; - # synthetic, for display - './lib' => 'lib', +my $known_paths = { + SA => { + config_key => 'sitearch', + }, + SL => { + config_key => 'sitelib', + }, + SS => { + config_key => 'sitelib_stem', + match_order => 1, + }, + SP => { + config_key => 'siteprefix', + match_order => 2, + }, + VA => { + config_key => 'vendorarch', + }, + VL => { + config_key => 'vendorlib', + }, + VS => { + config_key => 'vendorlib_stem', + match_order => 3, + }, + VP => { + config_key => 'vendorprefix', + match_order => 4, + }, + PA => { + config_key => 'archlib', + }, + PL => { + config_key => 'privlib', + }, + PP => { + config_key => 'prefix', + match_order => 5, + }, + BLA => { + rel_path => './blib/arch', + skip_unversioned_modules => 1, + }, + BLL => { + rel_path => './blib/lib', + skip_unversioned_modules => 1, + }, + INC => { + rel_path => './inc', + }, + LIB => { + rel_path => './lib', + skip_unversioned_modules => 1, + }, + T => { + rel_path => './t', + skip_unversioned_modules => 1, + }, + XT => { + rel_path => './xt', + skip_unversioned_modules => 1, + }, + CWD => { + rel_path => '.', + }, + HOME => { + rel_path => '~', + abs_unix_path => abs_unix_path ( + eval { require File::HomeDir and File::HomeDir->my_home } + || + $ENV{USERPROFILE} + || + $ENV{HOME} + || + glob('~') + ), + }, }; -sub describe_fn { - my $fn = shift; - - return '' if !defined $fn; +for my $k (keys %$known_paths) { + my $v = $known_paths->{$k}; - $fn = fixup_path( $fn ); + # never use home as a found-in-dir marker - it is too broad + # HOME is only used by the shortener + $v->{marker} = $k unless $k eq 'HOME'; - $lib_paths->{$_} and $fn =~ s/^\Q$lib_paths->{$_}/<<$_>>/ and last - for @lib_display_order; - - $fn; -} + unless ( $v->{abs_unix_path} ) { + if ( $v->{rel_path} ) { + $v->{abs_unix_path} = abs_unix_path( $v->{rel_path} ); + } + elsif ( $Config{ $v->{config_key} || '' } ) { + $v->{abs_unix_path} = abs_unix_path ( + $Config{"$v->{config_key}exp"} || $Config{$v->{config_key}} + ); + } + } -sub md5_of_fn { - # we already checked for -r/-f, just bail if can't open - open my $fh, '<:raw', $_[0] or return ''; - require Digest::MD5; - Digest::MD5->new->addfile($fh)->hexdigest; + delete $known_paths->{$k} unless $v->{abs_unix_path} and -d $v->{abs_unix_path}; } +my $seen_markers = {}; -# first run through lib and *try* to load anything we can find +# first run through lib/ and *try* to load anything we can find # within our own project find({ wanted => sub { -f $_ or return; + $_ =~ m|lib/DBIx/Class/_TempExtlib| and return; + # can't just `require $fn`, as we need %INC to be # populated properly my ($mod) = $_ =~ /^ lib [\/\\] (.+) \.pm $/x or return; - req_mod join ('::', File::Spec->splitdir($mod)); + try_module_require(join ('::', File::Spec->splitdir($mod)) ) }, no_chdir => 1, }, 'lib' ); + + # now run through OptDeps and attempt loading everything else # # some things needs to be sorted before other things @@ -150,26 +195,68 @@ my $load_weights = { "DBD::Oracle" => -999, }; -my $optdeps = { +my @known_modules = sort + { ($load_weights->{$b}||0) <=> ($load_weights->{$a}||0) } + qw( Data::Dumper ), map { $_ => 1 } map - { keys %{DBIx::Class::Optional::Dependencies->req_list_for($_)} } + { keys %{ DBIx::Class::Optional::Dependencies->req_list_for($_) } } grep - { $_ !~ /rdbms/ } + # some DBDs are notoriously problematic to load + # hence only show stuff based on test_rdbms which will + # take into account necessary ENVs + { $_ !~ /^ (?: rdbms | dist )_ /x } keys %{DBIx::Class::Optional::Dependencies->req_group_list} -}; -req_mod $_ for sort - { ($load_weights->{$b}||0) <=> ($load_weights->{$a}||0) } - keys %$optdeps ; +try_module_require($_) for @known_modules; + my $has_versionpm = eval { require version }; -# at this point we've loaded everything we ever could, let's drill through -# the *ENTIRE* symtable and build a map of versions -my $version_list = { perl => $] }; -visit_namespaces( action => sub { + +# At this point we've loaded everything we ever could, but some modules +# (understandably) crapped out. For an even more thorough report, note +# everthing present in @INC we excplicitly know about (via OptDeps) +# *even though* it didn't load +my $known_failed_loads; + +for my $mod (@known_modules) { + my $inc_key = module_notional_filename($mod); + next if defined $INC{$inc_key}; + + if (defined( my $idx = module_found_at_inc_index( $mod, \@INC ) ) ) { + $known_failed_loads->{$mod} = abs_unix_path( "$INC[$idx]/$inc_key" ); + } + +} + +my $perl = 'perl'; + +# This is a cool idea, but the line is too long even with shortening :( +# +#for my $i ( 1 .. $Config{config_argc} ) { +# my $conf_arg = $Config{"config_arg$i"}; +# $conf_arg =~ s! +# \= (.+) +# ! +# '=' . shorten_fn($1) +# !ex; +# +# $perl .= " $conf_arg"; +#} + +my $interesting_modules = { + # pseudo module + $perl => { + version => $], + abs_unix_path => abs_unix_path($^X), + } +}; + + +# drill through the *ENTIRE* symtable and build a map of interesting modules +DBICTest::Util::visit_namespaces( action => sub { no strict 'refs'; my $pkg = shift; @@ -179,180 +266,410 @@ visit_namespaces( action => sub { # private - not interested, including no further descent return 0 if $pkg =~ / (?: ^ | :: ) _ /x; - # not interested in no-VERSION-containing modules, nor synthetic classes - return 1 if ( - ! defined ${"${pkg}::VERSION"} - or - ${"${pkg}::VERSION"} =~ /\Qset by base.pm/ - ); + my $inc_key = module_notional_filename($pkg); - # make sure a version can be extracted, be noisy when it doesn't work - # do this even if we are throwing away the result below in lieu of EUMM - my $mod_ver = eval { $pkg->VERSION }; - if (my $err = $@) { - $err =~ s/^/ /mg; - say_err - "Calling `$pkg->VERSION` resulted in an exception, which should never " - . "happen - please file a bug with the distribution containing $pkg. " - . "Complete exception text below:\n\n$err" - ; - } - elsif( ! defined $mod_ver or ! length $mod_ver ) { - my $ret = defined $mod_ver - ? "the empty string ''" - : "'undef'" - ; - - say_err - "Calling `$pkg->VERSION` returned $ret, even though \$${pkg}::VERSION " - . "is defined, which should never happen - please file a bug with the " - . "distribution containing $pkg." - ; - - undef $mod_ver; - } - - # if this is a real file - extract the version via EUMM whenever possible - my $fn = $INC{module_notional_filename($pkg)}; - - my $eumm_ver = ( - $fn + my $abs_unix_path = ( + $INC{$inc_key} and - -f $fn + -f $INC{$inc_key} and - -r $fn + -r $INC{$inc_key} and - eval { MM->parse_version( $fn ) } - ) || undef; + abs_unix_path($INC{$inc_key}) + ); + # handle versions first (not interested in synthetic classes) if ( - $has_versionpm + defined ${"${pkg}::VERSION"} and - defined $eumm_ver - and - defined $mod_ver - and - $eumm_ver ne $mod_ver - and - ( - ( eval { version->parse( do { (my $v = $eumm_ver) =~ s/_//g; $v } ) } || 0 ) - != - ( eval { version->parse( do { (my $v = $mod_ver) =~ s/_//g; $v } ) } || 0 ) - ) + ${"${pkg}::VERSION"} !~ /\Qset by base.pm/ ) { - say_err - "Mismatch of versions '$mod_ver' and '$eumm_ver', obtained respectively " - . "via `$pkg->VERSION` and parsing the version out of @{[ describe_fn $fn ]} " - . "with ExtUtils::MakeMaker\@@{[ ExtUtils::MakeMaker->VERSION ]}. " - . "This should never happen - please check whether this is still present " - . "in the latest version, and then file a bug with the distribution " - . "containing $pkg." - ; - } - if( defined $eumm_ver ) { - $version_list->{$pkg} = $eumm_ver; + # make sure a version can be extracted, be noisy when it doesn't work + # do this even if we are throwing away the result below in lieu of EUMM + my $mod_ver = eval { $pkg->VERSION }; + + if (my $err = $@) { + $err =~ s/^/ /mg; + say_err ( + "Calling `$pkg->VERSION` resulted in an exception, which should never " + . "happen - please file a bug with the distribution containing $pkg. " + . "Complete exception text below:\n\n$err" + ); + } + elsif( ! defined $mod_ver or ! length $mod_ver ) { + my $ret = defined $mod_ver + ? "the empty string ''" + : "'undef'" + ; + + say_err ( + "Calling `$pkg->VERSION` returned $ret, even though \$${pkg}::VERSION " + . "is defined, which should never happen - please file a bug with the " + . "distribution containing $pkg." + ); + + undef $mod_ver; + } + + if ( + $abs_unix_path + and + defined ( my $eumm_ver = eval { MM->parse_version( $abs_unix_path ) } ) + ) { + + # can only run the check reliably if v.pm is there + if ( + $has_versionpm + and + defined $mod_ver + and + $eumm_ver ne $mod_ver + and + ( + ( eval { version->parse( do { (my $v = $eumm_ver) =~ s/_//g; $v } ) } || 0 ) + != + ( eval { version->parse( do { (my $v = $mod_ver) =~ s/_//g; $v } ) } || 0 ) + ) + ) { + say_err ( + "Mismatch of versions '$mod_ver' and '$eumm_ver', obtained respectively " + . "via `$pkg->VERSION` and parsing the version out of @{[ shorten_fn( $abs_unix_path ) ]} " + . "with ExtUtils::MakeMaker\@@{[ ExtUtils::MakeMaker->VERSION ]}. " + . "This should never happen - please check whether this is still present " + . "in the latest version, and then file a bug with the distribution " + . "containing $pkg." + ); + } + + $interesting_modules->{$pkg}{version} = $eumm_ver; + } + elsif( defined $mod_ver ) { + + $interesting_modules->{$pkg}{version} = $mod_ver; + } } - elsif( defined $mod_ver ) { - $version_list->{$pkg} = $mod_ver; + elsif ( $known_failed_loads->{$pkg} ) { + $abs_unix_path = $known_failed_loads->{$pkg}; + $interesting_modules->{$pkg}{version} = '!! LOAD FAIL !!'; } - 1; -}); + if ($abs_unix_path) { + my ($marker, $initial_inc_idx); -# In retrospect it makes little sense to omit this information - just -# show everything at all times. -# Nevertheless leave the dead code, in case it turns out to be a bad idea... -my $show_all = 1; -#my $show_all = $ENV{PERL_DESCRIBE_ALL_DEPS} || !DBICTest::RunMode->is_plain; - -# compress identical versions as close to the root as we can -# unless we are dealing with a smoker - in which case we want -# to see every MD5 there is -unless ($show_all) { - for my $mod ( sort { length($b) <=> length($a) } keys %$version_list ) { - my $parent = $mod; + my $current_inc_idx = module_found_at_inc_index($pkg, \@INC); + my $p = subpath_of_known_path( $abs_unix_path ); - while ( $parent =~ s/ :: (?: . (?! :: ) )+ $ //x ) { - $version_list->{$parent} - and - $version_list->{$parent} eq $version_list->{$mod} + if ( + defined $current_inc_idx and - ( ( delete $version_list->{$mod} ) or 1 ) + $p->{marker} and - last + abs_unix_path($INC[$current_inc_idx]) eq $p->{abs_unix_path} + ) { + $marker = $p->{marker}; + } + elsif (defined ( $initial_inc_idx = module_found_at_inc_index($pkg, \@initial_INC) ) ) { + $marker = "\$INC[$initial_inc_idx]"; } - } -} - -ok 1, (scalar keys %$version_list) . " distinctly versioned modules"; -exit if ($ENV{TRAVIS}||'') eq 'true'; + # we are only interested if there was a declared version already above + # OR if the module came from somewhere other than skip_unversioned_modules + if ( + $marker + and + ( + $interesting_modules->{$pkg} + or + !$p->{skip_unversioned_modules} + ) + ) { + $interesting_modules->{$pkg}{source_marker} = $marker; + $seen_markers->{$marker} = 1; + } -# sort stuff into @INC segments -my $segments; + # at this point only fill in the path (md5 calc) IFF it is interesting + # in any respect + $interesting_modules->{$pkg}{abs_unix_path} = $abs_unix_path + if $interesting_modules->{$pkg}; + } -MODULE: -for my $mod ( sort { lc($a) cmp lc($b) } keys %$version_list ) { - my $fn = $INC{module_notional_filename($mod)}; + 1; +}); - my $tuple = [ $mod ]; +# compress identical versions sourced from ./blib, ./lib, ./t and ./xt +# as close to the root of a namespace as we can +purge_identically_versioned_submodules_with_markers([ map { + ( $_->{skip_unversioned_modules} && $_->{marker} ) || () +} values %$known_paths ]); - if ( defined $fn && -f $fn && -r $fn ) { - push @$tuple, ( $fn = fixup_path($fn) ); +ok 1, (scalar keys %$interesting_modules) . " distinctly versioned modules found"; - for my $lib (@lib_display_order, './lib') { - if ( $lib_paths->{$lib} and index($fn, $lib_paths->{$lib}) == 0 ) { - push @{$segments->{$lib}}, $tuple; - next MODULE; - } - } - } +# do not announce anything under ci - we are watching for STDERR silence +exit 0 if DBICTest::RunMode->is_ci; - # fallthrough for anything without a physical filename, or unknown lib - push @{$segments->{''}}, $tuple; -} # diag the result out my $max_ver_len = max map - { length $_ } - ( values %$version_list, 'xxx.yyyzzz_bbb' ) + { length "$_" } + ( 'xxx.yyyzzz_bbb', map { $_->{version} || '' } values %$interesting_modules ) ; -my $max_mod_len = max map { length $_ } keys %$version_list; +my $max_marker_len = max map { length $_ } ( '$INC[999]', keys %$seen_markers ); my $discl = <<'EOD'; -Versions of all loadable modules within both the core and *OPTIONAL* dependency chains present on this system -Note that *MANY* of these modules will *NEVER* be loaded during normal operation of DBIx::Class +List of loadable modules within both the core and *OPTIONAL* dependency chains +present on this system (modules sourced from ./blib, ./lib, ./t, and ./xt +with versions identical to their parent namespace were omitted for brevity) + + *** Note that *MANY* of these modules will *NEVER* be loaded *** + *** during normal operation of DBIx::Class *** EOD -$discl .= "(modules with versions identical to their parent namespace were omitted - set PERL_DESCRIBE_ALL_DEPS to see them)\n" - unless $show_all; +# pre-assemble everything and print it in one shot +# makes it less likely for parallel test execution to insert bogus lines +my $final_out = "\n$discl\n"; -diag $discl; +$final_out .= "\@INC at startup (does not reflect manipulation at runtime):\n"; -diag "\n"; +my $in_inc_skip; +for (0.. $#initial_INC) { -for my $seg ( '', @lib_display_order, './lib' ) { - next unless $segments->{$seg}; + my $shortname = shorten_fn( $initial_INC[$_] ); - diag sprintf "=== %s ===\n\n", - $seg - ? "Modules found in " . ( $Config{$seg} ? "\$Config{$seg}" : $seg ) - : 'Misc versions' - ; + # when *to* print a line of INC + if ( + ! $ENV{AUTOMATED_TESTING} + or + @initial_INC < 11 + or + $seen_markers->{"\$INC[$_]"} + or + ! -e $shortname + or + ! File::Spec->file_name_is_absolute($shortname) + ) { + $in_inc_skip = 0; + $final_out .= sprintf ( "% 3s: %s\n", + $_, + $shortname + ); + } + elsif(! $in_inc_skip++) { + $final_out .= " ...\n"; + } +} + +$final_out .= "\n"; + +if (my @seen_known_paths = grep { $known_paths->{$_} } keys %$seen_markers) { + + $final_out .= join "\n", 'Sourcing markers:', (map + { + sprintf "%*s: %s", + $max_marker_len => $_->{marker}, + ($_->{config_key} ? "\$Config{$_->{config_key}}" : "$_->{rel_path}/" ) + } + sort + { + !!$b->{config_key} cmp !!$a->{config_key} + or + ( $a->{marker}||'') cmp ($b->{marker}||'') + } + @{$known_paths}{@seen_known_paths} + ), '', ''; - diag sprintf ( - "%*s %*s%s\n", - $max_ver_len => $version_list->{$_->[0]}, - -$max_mod_len => $_->[0], - ($_->[1] - ? ' ' x (80 - min(78, $max_mod_len)) . "[ MD5: @{[ md5_of_fn( $_->[1] ) ]} ]" +} + +$final_out .= "=============================\n"; + +$final_out .= join "\n", (map + { sprintf ( + "%*s %*s %*s%s", + $max_marker_len => $interesting_modules->{$_}{source_marker} || '', + $max_ver_len => ( defined $interesting_modules->{$_}{version} + ? $interesting_modules->{$_}{version} : '' ), - ) for @{$segments->{$seg}}; + -78 => $_, + ($interesting_modules->{$_}{abs_unix_path} + ? " [ MD5: @{[ get_md5( $interesting_modules->{$_}{abs_unix_path} ) ]} ]" + : "! -f \$INC{'@{[ module_notional_filename($_) ]}'}" + ), + ) } + sort { lc($a) cmp lc($b) } keys %$interesting_modules +), ''; + +$final_out .= "=============================\n$discl\n\n"; + +diag $final_out; + +exit 0; - diag "\n\n" + + +sub say_err { print STDERR "\n", @_, "\n\n" }; + +# do !!!NOT!!! use Module::Runtime's require_module - it breaks CORE::require +sub try_module_require { + # trap deprecation warnings and whatnot + local $SIG{__WARN__} = sub {}; + local $@; + eval "require $_[0]"; } -diag "$discl\n"; +sub abs_unix_path { + return '' unless ( + defined $_[0] + and + ( -e $_[0] or File::Spec->file_name_is_absolute($_[0]) ) + ); + + # File::Spec's rel2abs does not resolve symlinks + # we *need* to look at the filesystem to be sure + my $abs_fn = abs_path($_[0]); + + if ( $^O eq 'MSWin32' and $abs_fn ) { + + # sometimes we can get a short/longname mix, normalize everything to longnames + $abs_fn = Win32::GetLongPathName($abs_fn); + + # Fixup (native) slashes in Config not matching (unixy) slashes in INC + $abs_fn =~ s|\\|/|g; + } + + $abs_fn; +} + +sub shorten_fn { + my $fn = shift; + + my $abs_fn = abs_unix_path($fn); + + if (my $p = subpath_of_known_path( $fn ) ) { + $abs_fn =~ s| (?{rel_path}) { + $abs_fn =~ s!\Q$p->{abs_unix_path}!$p->{rel_path}! + and return $abs_fn; + } + elsif ($p->{config_key}) { + $abs_fn =~ s!\Q$p->{abs_unix_path}!<<$p->{marker}>>! + and + $seen_markers->{$p->{marker}} = 1 + and + return $abs_fn; + } + } + + # we got so far - not a known path + # return the unixified version it if was absolute, leave as-is otherwise + my $rv = ( $abs_fn and File::Spec->file_name_is_absolute( $fn ) ) + ? $abs_fn + : $fn + ; + + $rv = "( ! -e ) $rv" unless -e $rv; + + return $rv; +} + +sub subpath_of_known_path { + my $abs_fn = abs_unix_path( $_[0] ) + or return ''; + + for my $p ( + sort { + length( $b->{abs_unix_path} ) <=> length( $a->{abs_unix_path} ) + or + ( $a->{match_order} || 0 ) <=> ( $b->{match_order} || 0 ) + } + values %$known_paths + ) { + # run through the matcher twice - first always append a / + # then try without + # important to avoid false positives + for my $suff ( '/', '' ) { + return { %$p } if 0 == index( $abs_fn, "$p->{abs_unix_path}$suff" ); + } + } +} + +sub module_found_at_inc_index { + my ($mod, $inc_dirs) = @_; + + return undef unless @$inc_dirs; + + my $fn = module_notional_filename($mod); + + # trust INC if it specifies an existing path + if( -f ( my $existing_path = abs_unix_path( $INC{$fn} ) ) ) { + for my $i ( 0 .. $#$inc_dirs ) { + + # searching from here on out won't mean anything + # FIXME - there is actually a way to interrogate this safely, but + # that's a fight for another day + return undef if length ref $inc_dirs->[$i]; + + return $i + if 0 == index( $existing_path, abs_unix_path( $inc_dirs->[$i] ) . '/' ); + } + } + + for my $i ( 0 .. $#$inc_dirs ) { + + if ( + -d $inc_dirs->[$i] + and + -f "$inc_dirs->[$i]/$fn" + and + -r "$inc_dirs->[$i]/$fn" + ) { + return $i; + } + } + + return undef; +} + +sub purge_identically_versioned_submodules_with_markers { + my $markers = shift; + + return unless @$markers; + + for my $mod ( sort { length($b) <=> length($a) } keys %$interesting_modules ) { + + next unless defined $interesting_modules->{$mod}{version}; + + my $marker = $interesting_modules->{$mod}{source_marker} + or next; + + next unless grep { $marker eq $_ } @$markers; + + my $parent = $mod; + + while ( $parent =~ s/ :: (?: . (?! :: ) )+ $ //x ) { + $interesting_modules->{$parent} + and + ($interesting_modules->{$parent}{version}||'') eq $interesting_modules->{$mod}{version} + and + ($interesting_modules->{$parent}{source_marker}||'') eq $interesting_modules->{$mod}{source_marker} + and + delete $interesting_modules->{$mod} + and + last + } + } +} + +sub module_notional_filename { + (my $fn = $_[0] . '.pm') =~ s|::|/|g; + $fn; +} + +sub get_md5 { + # we already checked for -r/-f, just bail if can't open + open my $fh, '<:raw', $_[0] or return ''; + Digest::MD5->new->addfile($fh)->hexdigest; +}