X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=t%2F00describe_environment.t;h=ed0378bb80d59816825d366f086bc5bcb912df36;hb=02154caf0cf887228849fd0d88e0d6636ef21f8c;hp=8abb7b973a5120261f48d533a4b554d539167d71;hpb=250d9e552fcad5491aec100f2fbf6a4c63edbb3c;p=dbsrgits%2FDBIx-Class.git diff --git a/t/00describe_environment.t b/t/00describe_environment.t index 8abb7b9..ed0378b 100644 --- a/t/00describe_environment.t +++ b/t/00describe_environment.t @@ -3,9 +3,18 @@ ### 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 { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } BEGIN { - if ($] < 5.010) { + if ( "$]" < 5.010) { # Pre-5.10 perls pollute %INC on unsuccesfull module # require, making it appear as if the module is already @@ -22,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 { @@ -36,88 +44,143 @@ 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 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; - -# 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"; -} +use DBICTest::RunMode; +use DBIx::Class::_Util 'visit_namespaces'; +use DBIx::Class::Optional::Dependencies; -my @lib_display_order = qw( - sitearch - sitelib - vendorarch - vendorlib - archlib - privlib -); -my $lib_paths = { - (map - { $Config{$_} ? ( $_ => $Config{"${_}exp"} || $Config{$_} ) : () } - @lib_display_order - ), - - # 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; +for my $k (keys %$known_paths) { + my $v = $known_paths->{$k}; - $lib_paths->{$_} and $fn =~ s/^\Q$lib_paths->{$_}/<<$_>>/ and last - for @lib_display_order; + # 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'; - $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 @@ -128,184 +191,487 @@ my $load_weights = { # clashes with libssl, and will segfault everything coming after them "DBD::Oracle" => -999, }; -req_mod $_ for sort + +my @known_modules = sort { ($load_weights->{$b}||0) <=> ($load_weights->{$a}||0) } + qw( Data::Dumper ), keys %{ DBIx::Class::Optional::Dependencies->req_list_for([ grep # some DBDs are notoriously problematic to load # hence only show stuff based on test_rdbms which will # take into account necessary ENVs - { $_ !~ /^rdbms_/ } + { $_ !~ /^ (?: rdbms | dist )_ /x } keys %{DBIx::Class::Optional::Dependencies->req_group_list} ]) } ; +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 => $] }; + +# 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 visit_namespaces( action => sub { + no strict 'refs'; my $pkg = shift; # keep going, but nothing to see here return 1 if $pkg eq 'main'; - # private - not interested + # private - not interested, including no further descent return 0 if $pkg =~ / (?: ^ | :: ) _ /x; - no strict 'refs'; - # that would be some synthetic class, or a custom sub VERSION - return 1 if ( - ! defined ${"${pkg}::VERSION"} - or - ${"${pkg}::VERSION"} =~ /\Qset by base.pm/ + my $inc_key = module_notional_filename($pkg); + + my $abs_unix_path = ( + $INC{$inc_key} + and + -f $INC{$inc_key} + and + -r $INC{$inc_key} + and + abs_unix_path($INC{$inc_key}) ); - # 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. " - . "Follows the full text of the exception:\n\n$err\n" - ; - } - elsif( ! defined $mod_ver ) { - say_err - "Calling `$pkg->VERSION` returned 'undef', which should never " - . "happen - please file a bug with the distribution containing $pkg." - ; + # handle versions first (not interested in synthetic classes) + if ( + defined ${"${pkg}::VERSION"} + and + ${"${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; + } + 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( ! length $mod_ver ) { - say_err - "Calling `$pkg->VERSION` returned the empty string '', which should never " - . "happen - please file a bug with the distribution containing $pkg." - ; - undef $mod_ver; + elsif ( $known_failed_loads->{$pkg} ) { + $abs_unix_path = $known_failed_loads->{$pkg}; + $interesting_modules->{$pkg}{version} = '!! LOAD FAIL !!'; } - # if this is a real file - extract the version via EUMM whenever possible - my $fn = $INC{module_notional_filename($pkg)}; + 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]"; + } + + # 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 ./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 ]); + +ok 1, (scalar keys %$interesting_modules) . " distinctly versioned modules found"; + +# do not announce anything under ci - we are watching for STDERR silence +exit 0 if DBICTest::RunMode->is_ci; + + +# diag the result out +my $max_ver_len = max map + { length "$_" } + ( 'xxx.yyyzzz_bbb', map { $_->{version} || '' } values %$interesting_modules ) +; +my $max_marker_len = max map { length $_ } ( '$INC[999]', keys %$seen_markers ); + +my $discl = <<'EOD'; + +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 + +# 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) { - my $eumm_ver = eval { MM->parse_version( $fn ) } - if $fn and -f $fn and -r $fn; + my $shortname = shorten_fn( $initial_INC[$_] ); + # when *to* print a line of INC if ( - $has_versionpm - 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 ) - ) + ! $ENV{AUTOMATED_TESTING} + or + @initial_INC < 11 + or + $seen_markers->{"\$INC[$_]"} + or + ! -e $shortname + or + ! File::Spec->file_name_is_absolute($shortname) ) { - 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." - ; + $in_inc_skip = 0; + $final_out .= sprintf ( "% 3s: %s\n", + $_, + $shortname + ); } - - if( defined $eumm_ver ) { - $version_list->{$pkg} = $eumm_ver; + elsif(! $in_inc_skip++) { + $final_out .= " ...\n"; } - elsif( defined $mod_ver ) { - $version_list->{$pkg} = $mod_ver; +} + +$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} + ), '', ''; + +} + +$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 +), ''; + +$final_out .= "=============================\n$discl\n\n"; + +diag $final_out; + +# *very* large printouts may not finish flushing before the test exits +# injecting a ... ok in the middle of the diag +# http://www.cpantesters.org/cpan/report/fbdac74c-35ca-11e6-ab41-c893a58a4b8c +select( undef, undef, undef, 0.2 ); + +exit 0; + + + +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]"; +} + +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; } - 1; -}); + $abs_fn; +} -# 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 ( $ENV{AUTOMATED_TESTING} ) { - for my $mod ( sort { length($b) <=> length($a) } keys %$version_list ) { - my $parent = $mod; +sub shorten_fn { + my $fn = shift; - while ( $parent =~ s/ :: (?: . (?! :: ) )+ $ //x ) { - $version_list->{$parent} - and - $version_list->{$parent} eq $version_list->{$mod} + 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 - ( ( delete $version_list->{$mod} ) or 1 ) + $seen_markers->{$p->{marker}} = 1 and - last + 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; } -ok 1, (scalar keys %$version_list) . " distinctly versioned modules"; +sub subpath_of_known_path { + my $abs_fn = abs_unix_path( $_[0] ) + or return ''; -# do not announce anything under ci - we are watching for STDERR silence -exit if DBICTest::RunMode->is_ci; + 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" ); + } + } +} -# sort stuff into @INC segments -my $segments; +sub module_found_at_inc_index { + my ($mod, $inc_dirs) = @_; -MODULE: -for my $mod ( sort { lc($a) cmp lc($b) } keys %$version_list ) { - my $fn = $INC{module_notional_filename($mod)}; + return undef unless @$inc_dirs; - my $tuple = [ - $mod, - ( ( $fn && -f $fn && -r $fn ) ? $fn : undef ) - ]; + 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 ) { - if ($fn) { - for my $lib (@lib_display_order, './lib') { - if ( $lib_paths->{$lib} and index($fn, $lib_paths->{$lib}) == 0 ) { - push @{$segments->{$lib}}, $tuple; - next MODULE; - } + # 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] ) . '/' ); } } - # fallthrough for anything without a physical filename, or unknown lib - push @{$segments->{''}}, $tuple; + 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; } -# diag the result out -my $max_ver_len = max map { length $_ } values %$version_list; -my $max_mod_len = max map { length $_ } keys %$version_list; +sub purge_identically_versioned_submodules_with_markers { + my $markers = shift; -my $diag = "\n\nVersions of all loadable modules within the configure/build/test/runtime dependency chains present on this system (both core and optional)\n\n"; -for my $seg ( '', @lib_display_order, './lib' ) { - next unless $segments->{$seg}; + return unless @$markers; - $diag .= sprintf "=== %s ===\n\n", - $seg - ? "Modules found in " . ( $Config{$seg} ? "\$Config{$seg}" : $seg ) - : 'Misc' - ; + for my $mod ( sort { length($b) <=> length($a) } keys %$interesting_modules ) { - $diag .= sprintf ( - " %*s %*s%s\n", - $max_ver_len => $version_list->{$_->[0]}, - -$max_mod_len => $_->[0], - ($_->[1] - ? " [ MD5: @{[ md5_of_fn( $_->[1] ) ]} ]" - : '' - ), - ) for @{$segments->{$seg}}; + next unless defined $interesting_modules->{$mod}{version}; + + my $marker = $interesting_modules->{$mod}{source_marker} + or next; - $diag .= "\n\n" + 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; } -diag $diag; +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; +}