From: Peter Rabbitson Date: Thu, 5 Mar 2015 23:39:00 +0000 (+0100) Subject: More desc_env fixes: Win32 lib matching, and better formatting of final diag X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=4bfba4eedee106378b84da103a9bc5eafd3dce41;p=dbsrgits%2FDBIx-Class-Historic.git More desc_env fixes: Win32 lib matching, and better formatting of final diag This is what the slash-situation is on a typical strawberry: 'inc' => [ 'C:/Strawberry/perl/site/lib/MSWin32-x64-multi-thread', 'C:/Strawberry/perl/site/lib', 'C:/Strawberry/perl/vendor/lib', 'C:/Strawberry/perl/lib', '.' ], 'archlib' => 'C:\\STRAWB~1\\perl\\lib', 'archlibexp' => 'C:\\STRAWB~1\\perl\\lib', 'privlib' => 'C:\\STRAWB~1\\perl\\lib', 'privlibexp' => 'C:\\STRAWB~1\\perl\\lib', 'sitearch' => 'C:\\STRAWB~1\\perl\\site\\lib', 'sitearchexp' => 'C:\\STRAWB~1\\perl\\site\\lib', 'sitelib' => 'C:\\STRAWB~1\\perl\\site\\lib', 'sitelibexp' => 'C:\\STRAWB~1\\perl\\site\\lib', 'vendorarch' => 'C:\\STRAWB~1\\perl\\vendor\\lib', 'vendorarchexp' => 'C:\\STRAWB~1\\perl\\vendor\\lib', 'vendorlib' => 'C:\\STRAWB~1\\perl\\vendor\\lib', 'vendorlibexp' => 'C:\\STRAWB~1\\perl\\vendor\\lib' Instead of trying to wade through it with File::Spec, just turn short names into longnames and every \ into / and hope it works. Also make it so that the MD5 line will align correctly on an 80-col terminal (on wider terminals it won't matter either way), and show *all* the hashes at all times (omitting the information makes little sense). In addition some clarification to the undef/empty ->VERSION return error and the diag contents themselves (Mithaldu++) --- diff --git a/t/00describe_environment.t b/t/00describe_environment.t index 8abb7b9..fa3df9c 100644 --- a/t/00describe_environment.t +++ b/t/00describe_environment.t @@ -48,7 +48,7 @@ use Test::More 'no_plan'; use Config; use File::Find 'find'; use Module::Runtime 'module_notional_filename'; -use List::Util 'max'; +use List::Util qw(max min); use ExtUtils::MakeMaker; use DBICTest::Util 'visit_namespaces'; @@ -68,6 +68,19 @@ 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 @@ -78,7 +91,10 @@ my @lib_display_order = qw( ); my $lib_paths = { (map - { $Config{$_} ? ( $_ => $Config{"${_}exp"} || $Config{$_} ) : () } + { $Config{$_} + ? ( $_ => fixup_path( $Config{"${_}exp"} || $Config{$_} ) ) + : () + } @lib_display_order ), @@ -89,6 +105,10 @@ my $lib_paths = { sub describe_fn { my $fn = shift; + return '' if !defined $fn; + + $fn = fixup_path( $fn ); + $lib_paths->{$_} and $fn =~ s/^\Q$lib_paths->{$_}/<<$_>>/ and last for @lib_display_order; @@ -148,16 +168,16 @@ my $has_versionpm = eval { require version }; # the *ENTIRE* symtable and build a map of versions my $version_list = { perl => $] }; 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 + # not interested in no-VERSION-containing modules, nor synthetic classes return 1 if ( ! defined ${"${pkg}::VERSION"} or @@ -172,29 +192,36 @@ visit_namespaces( action => sub { 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" + . "Complete exception text below:\n\n$err" ; } - elsif( ! defined $mod_ver ) { - say_err - "Calling `$pkg->VERSION` returned 'undef', which should never " - . "happen - please file a bug with the distribution containing $pkg." + elsif( ! defined $mod_ver or ! length $mod_ver ) { + my $ret = defined $mod_ver + ? "the empty string ''" + : "'undef'" ; - } - 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." + "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 = eval { MM->parse_version( $fn ) } - if $fn and -f $fn and -r $fn; + my $eumm_ver = ( + $fn + and + -f $fn + and + -r $fn + and + eval { MM->parse_version( $fn ) } + ) || undef; if ( $has_versionpm @@ -231,10 +258,16 @@ visit_namespaces( action => sub { 1; }); +# 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 ( $ENV{AUTOMATED_TESTING} ) { +unless ($show_all) { for my $mod ( sort { length($b) <=> length($a) } keys %$version_list ) { my $parent = $mod; @@ -262,13 +295,11 @@ MODULE: for my $mod ( sort { lc($a) cmp lc($b) } keys %$version_list ) { my $fn = $INC{module_notional_filename($mod)}; - my $tuple = [ - $mod, - ( ( $fn && -f $fn && -r $fn ) ? $fn : undef ) - ]; + my $tuple = [ $mod ]; + if ( defined $fn && -f $fn && -r $fn ) { + push @$tuple, ( $fn = fixup_path($fn) ); - if ($fn) { for my $lib (@lib_display_order, './lib') { if ( $lib_paths->{$lib} and index($fn, $lib_paths->{$lib}) == 0 ) { push @{$segments->{$lib}}, $tuple; @@ -282,30 +313,45 @@ for my $mod ( sort { lc($a) cmp lc($b) } keys %$version_list ) { } # diag the result out -my $max_ver_len = max map { length $_ } values %$version_list; +my $max_ver_len = max map + { length $_ } + ( values %$version_list, 'xxx.yyyzzz_bbb' ) +; my $max_mod_len = max map { length $_ } keys %$version_list; -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"; +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 +EOD + +$discl .= "(modules with versions identical to their parent namespace were omitted - set PERL_DESCRIBE_ALL_DEPS to see them)\n" + unless $show_all; + +diag $discl; + +diag "\n"; + for my $seg ( '', @lib_display_order, './lib' ) { next unless $segments->{$seg}; - $diag .= sprintf "=== %s ===\n\n", + diag sprintf "=== %s ===\n\n", $seg ? "Modules found in " . ( $Config{$seg} ? "\$Config{$seg}" : $seg ) - : 'Misc' + : 'Misc versions' ; - $diag .= sprintf ( - " %*s %*s%s\n", + diag sprintf ( + "%*s %*s%s\n", $max_ver_len => $version_list->{$_->[0]}, -$max_mod_len => $_->[0], ($_->[1] - ? " [ MD5: @{[ md5_of_fn( $_->[1] ) ]} ]" + ? ' ' x (80 - min(78, $max_mod_len)) . "[ MD5: @{[ md5_of_fn( $_->[1] ) ]} ]" : '' ), ) for @{$segments->{$seg}}; - $diag .= "\n\n" + diag "\n\n" } -diag $diag; +diag "$discl\n";