X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=t%2F00describe_environment.t;h=82f2fdb27c2ae09d7975777c2ac0b0fb75d74037;hb=3ed87c5822edc8f384ba8d035ead908bf8b9b25d;hp=7f7d108c3eff8d5e5c59467d52555f2431e989b0;hpb=55c6fb91c49622238426338d04dbc4f253445cdf;p=dbsrgits%2FDBIx-Class.git diff --git a/t/00describe_environment.t b/t/00describe_environment.t index 7f7d108..82f2fdb 100644 --- a/t/00describe_environment.t +++ b/t/00describe_environment.t @@ -3,7 +3,17 @@ ### 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 { + unshift @INC, 't/lib'; + if ($] < 5.010) { # Pre-5.10 perls pollute %INC on unsuccesfull module @@ -21,7 +31,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 { @@ -35,57 +44,90 @@ BEGIN { } } -# 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); - use strict; 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; +use DBICTest::RunMode; +use DBICTest::Util 'visit_namespaces'; +use DBIx::Class::Optional::Dependencies; -my $known_libpaths = { +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 => { - relpath => './inc', + rel_path => './inc', }, LIB => { - relpath => './lib', + rel_path => './lib', + skip_unversioned_modules => 1, + }, + T => { + rel_path => './t', + skip_unversioned_modules => 1, + }, + CWD => { + rel_path => '.', }, HOME => { - relpath => '~', - full_path => full_path ( + rel_path => '~', + abs_unix_path => abs_unix_path ( eval { require File::HomeDir and File::HomeDir->my_home } || + $ENV{USERPROFILE} + || $ENV{HOME} || glob('~') @@ -93,27 +135,27 @@ my $known_libpaths = { }, }; -for my $k (keys %$known_libpaths) { - my $v = $known_libpaths->{$k}; +for my $k (keys %$known_paths) { + my $v = $known_paths->{$k}; # never use home as a found-in-dir marker - it is too broad # HOME is only used by the shortener - $v->{abbrev} = $k unless $k eq 'HOME'; + $v->{marker} = $k unless $k eq 'HOME'; - unless ( $v->{full_path} ) { - if ( $v->{relpath} ) { - $v->{full_path} = full_path( $v->{relpath} ); + 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->{full_path} = full_path ( + $v->{abs_unix_path} = abs_unix_path ( $Config{"$v->{config_key}exp"} || $Config{$v->{config_key}} ); } } - delete $known_libpaths->{$k} unless $v->{full_path} and -d $v->{full_path}; + 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 # within our own project @@ -143,7 +185,8 @@ my $load_weights = { # clashes with libssl, and will segfault everything coming after them "DBD::Oracle" => -999, }; -try_module_require($_) for sort + +my @known_modules = sort { ($load_weights->{$b}||0) <=> ($load_weights->{$a}||0) } keys %{ DBIx::Class::Optional::Dependencies->req_list_for([ @@ -157,14 +200,52 @@ try_module_require($_) for sort } ; +try_module_require($_) for @known_modules; -# at this point we've loaded everything we ever could, let's drill through -# the *ENTIRE* symtable and build a map of versions my $has_versionpm = eval { require version }; -my $versioned_modules = { - perl => { version => $], full_path => $^X } + + +# 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 => $^X, + } }; -my $seen_known_libs; + + +# drill through the *ENTIRE* symtable and build a map of intereseting modules visit_namespaces( action => sub { no strict 'refs'; my $pkg = shift; @@ -175,180 +256,248 @@ 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/ - ); - - # 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; - } + my $inc_key = module_notional_filename($pkg); - # if this is a real file - extract the version via EUMM whenever possible - my $fn = $INC{module_notional_filename($pkg)}; - - my $full_path; - - 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 - $full_path = full_path($fn) - 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 @{[ shorten_fn( $full_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." - ); - } - if( defined $eumm_ver ) { - $versioned_modules->{$pkg} = { version => $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 ) { - $versioned_modules->{$pkg} = { version => $mod_ver }; + elsif ( $abs_unix_path = $known_failed_loads->{$pkg} ) { + $interesting_modules->{$pkg}{version} = '!! LOAD FAIL !!'; } - # add the path and a "where-from" marker if any - if ( $full_path and my $slot = $versioned_modules->{$pkg} ) { - $slot->{full_path} = $full_path; + if ($abs_unix_path) { + my ($marker, $initial_inc_idx); + + my $current_inc_idx = module_found_at_inc_index($pkg, \@INC); + my $p = subpath_of_known_path( $abs_unix_path ); + + if ( + defined $current_inc_idx + and + $p->{marker} + and + 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]"; + } - if ( my $abbr = ( matching_known_lib( $full_path ) || {} )->{abbrev} ) { - $slot->{from_known_lib} = $abbr; - $seen_known_libs->{$abbr} = 1; + # 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; } + + # 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}; } 1; }); -# compress identical versions sourced from ./lib as close to the root as we can -for my $mod ( sort { length($b) <=> length($a) } keys %$versioned_modules ) { - ($versioned_modules->{$mod}{from_known_lib}||'') eq 'LIB' - or next; - - my $parent = $mod; +# compress identical versions sourced from ./blib, ./lib and ./t 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 ]); - while ( $parent =~ s/ :: (?: . (?! :: ) )+ $ //x ) { - $versioned_modules->{$parent} - and - $versioned_modules->{$parent}{version} eq $versioned_modules->{$mod}{version} - and - ($versioned_modules->{$parent}{from_known_lib}||'') eq 'LIB' - and - delete $versioned_modules->{$mod} - and - last - } -} - -ok 1, (scalar keys %$versioned_modules) . " distinctly versioned modules found"; +ok 1, (scalar keys %$interesting_modules) . " distinctly versioned modules found"; # do not announce anything under ci - we are watching for STDERR silence -exit if DBICTest::RunMode->is_ci; +exit 0 if DBICTest::RunMode->is_ci; # diag the result out my $max_ver_len = max map { length "$_" } - ( 'xxx.yyyzzz_bbb', map { $_->{version} } values %$versioned_modules ) + ( 'xxx.yyyzzz_bbb', map { $_->{version} || '' } values %$interesting_modules ) ; -my $max_mod_len = max map { length $_ } keys %$versioned_modules; -my $max_marker_len = max map { length $_ } keys %{ $seen_known_libs || {} }; +my $max_marker_len = max map { length $_ } ( '$INC[999]', keys %$seen_markers ); my $discl = <<'EOD'; -List of loadable modules specifying a version 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 -(modules sourced from ./lib with versions identical to their parent namespace were omitted for brevity) +List of loadable modules within both the core and *OPTIONAL* dependency +chains present on this system (modules sourced from ./blib, ./lib and ./t +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 -diag "\n$discl\n"; +# 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"; + +$final_out .= "\@INC at startup (does not reflect manipulation at runtime):\n"; + +my $in_inc_skip; +for (0.. $#initial_INC) { -if ($seen_known_libs) { - diag "Sourcing markers:\n"; + my $path = shorten_fn( $initial_INC[$_] ); - diag $_ for - map + # when *to* print + if ( + ! $ENV{AUTOMATED_TESTING} + or + @initial_INC < 11 + or + $seen_markers->{"\$INC[$_]"} + or + ! -e $path + or + ! File::Spec->file_name_is_absolute($path) + ) { + $in_inc_skip = 0; + $final_out .= sprintf ( "% 3s: %s\n", + $_, + $path + ); + } + 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 { - sprintf " %*s: %s", - $max_marker_len => $_->{abbrev}, - ($_->{config_key} ? "\$Config{$_->{config_key}}" : $_->{relpath} ) + !!$b->{config_key} cmp !!$a->{config_key} + or + ( $a->{marker}||'') cmp ($b->{marker}||'') } - @{$known_libpaths}{ sort keys %$seen_known_libs } - ; + @{$known_paths}{@seen_known_paths} + ), '', ''; - diag "\n"; } -diag "=============================\n"; +$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} + : '' + ), + -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 +), ''; -diag sprintf ( - "%*s %*s %*s%s\n", - $max_marker_len+2 => $versioned_modules->{$_}{from_known_lib} || '', - $max_ver_len => $versioned_modules->{$_}{version}, - -$max_mod_len => $_, - ($versioned_modules->{$_}{full_path} - ? ' ' x (80 - min(78, $max_mod_len)) . "[ MD5: @{[ get_md5( $versioned_modules->{$_}{full_path} ) ]} ]" - : '' - ), -) for sort { lc($a) cmp lc($b) } keys %$versioned_modules; +$final_out .= "=============================\n$discl\n\n"; -diag "=============================\n$discl\n"; +diag $final_out; exit 0; -sub say_err { print STDERR "\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 { @@ -358,54 +507,145 @@ sub try_module_require { eval "require $_[0]"; } -sub full_path { - return '' unless ( defined $_[0] and -e $_[0] ); +sub abs_unix_path { + return '' unless ( + defined $_[0] + and + ( -e $_[0] or File::Spec->file_name_is_absolute($_[0]) ) + ); - my $fn = Cwd::abs_path($_[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 $fn ) { + if ( $^O eq 'MSWin32' and $abs_fn ) { # sometimes we can get a short/longname mix, normalize everything to longnames - $fn = Win32::GetLongPathName($fn); + $abs_fn = Win32::GetLongPathName($abs_fn); # Fixup (native) slashes in Config not matching (unixy) slashes in INC - $fn =~ s|\\|/|g; + $abs_fn =~ s|\\|/|g; } - $fn; + $abs_fn; } sub shorten_fn { my $fn = shift; - my $l = matching_known_lib( $fn ) - or return $fn; + my $abs_fn = abs_unix_path($fn); - if ($l->{relpath}) { - $fn =~ s/\Q$l->{full_path}\E/$l->{relpath}/; - } - elsif ($l->{config_key}) { - $fn =~ s/\Q$l->{full_path}\E/<<$l->{config_key}>>/; + 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; + } } - $fn; + # we got so far - not a known path + # return the unixified version it if was absolute, leave as-is otherwise + return ( $abs_fn and File::Spec->file_name_is_absolute( $fn ) ) + ? $abs_fn + : $fn + ; } -sub matching_known_lib { - my $fn = full_path( $_[0] ) +sub subpath_of_known_path { + my $abs_fn = abs_unix_path( $_[0] ) or return ''; - for my $l ( - sort { length( $b->{full_path} ) <=> length( $a->{full_path} ) } - values %$known_libpaths + 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 ) { - return { %$l } if 0 == index( $fn, $l->{full_path} ); + # 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); + + 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]; + + 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 ''; - require Digest::MD5; Digest::MD5->new->addfile($fh)->hexdigest; }