From aaa4599a052dc0b99f24e8e7c2426a03966f936f Mon Sep 17 00:00:00 2001 From: Kent Fredric Date: Fri, 20 May 2016 17:03:04 +1200 Subject: [PATCH 01/16] Make PODNAME for isa-splain match binary name. Hopefully this will make MetaCPAN rendering less confusing. --- bin/isa-splain | 4 ++++ weaver.ini | 4 ++++ 2 files changed, 8 insertions(+) diff --git a/bin/isa-splain b/bin/isa-splain index ed799ff..abf6df5 100755 --- a/bin/isa-splain +++ b/bin/isa-splain @@ -10,12 +10,16 @@ our $VERSION = '0.002002'; # AUTHORITY +# PODNAME: isa-splain + # ABSTRACT: Visualize Module Hierarchies on the command line use App::Isa::Splain; App::Isa::Splain->new_from_ARGV->run; +=for stopwords isa splain + =head1 DESCRIPTION See L<< C |App::Isa::Splain >> For details. diff --git a/weaver.ini b/weaver.ini index 530ce8f..c4bc3c1 100644 --- a/weaver.ini +++ b/weaver.ini @@ -2,6 +2,10 @@ [=inc::H1Nester] [-SingleEncoding] +[Region / stopwords] +allow_nonpod = 1 +flatten = 0 + [Name] [Version] From a0b0664da51ba0c149e37c5fb1fcfa0cc1f27c92 Mon Sep 17 00:00:00 2001 From: Kent Fredric Date: Fri, 20 May 2016 17:19:13 +1200 Subject: [PATCH 02/16] Improve bin/isa-splain's documentation to be more helpful. This is mostly for places where `man isa-splain` might be expected to work, where "See some Perl Module" might just be irritating. --- Changes | 3 +++ bin/isa-splain | 30 +++++++++++++++++++++++++++--- perlcritic.rc | 2 +- 3 files changed, 31 insertions(+), 4 deletions(-) diff --git a/Changes b/Changes index e497102..c1d4edb 100644 --- a/Changes +++ b/Changes @@ -1,6 +1,9 @@ Release history for Devel-Isa-Explainer {{$NEXT}} + [Documentation] + - Improve bin/isa-splain's documentation to be more helpful in places where `man isa-splain` might be expected to + work. 0.002001 2016-05-19T14:07:12Z c167598 [Documentation] diff --git a/bin/isa-splain b/bin/isa-splain index abf6df5..ee3bcf7 100755 --- a/bin/isa-splain +++ b/bin/isa-splain @@ -18,8 +18,32 @@ use App::Isa::Splain; App::Isa::Splain->new_from_ARGV->run; -=for stopwords isa splain +=for stopwords isa splain Preload -=head1 DESCRIPTION +=head1 USAGE -See L<< C |App::Isa::Splain >> For details. + isa-splain [OPTS] Module::Name::To::Inspect + +=head1 OPTIONS + +=head2 -MC + +Preload C instead of C + +This is useful in cases where loading C directly +is either impossible ( due to not existing as a .pm file ), or problematic ( due to +some load time complication ) + +=head1 EXAMPLES + + isa-splain -MB B::CV + +This shows the graph of C after loading C + + isa-splain -Moose Class::MOP::Class + +This shows the graph of C after loading C + +=head1 SEE ALSO + +L, L diff --git a/perlcritic.rc b/perlcritic.rc index 2e21a2b..a4f7ba5 100644 --- a/perlcritic.rc +++ b/perlcritic.rc @@ -160,7 +160,7 @@ stop_words = explainer Explainer interoperability [Documentation::RequirePodAtEnd] -[Documentation::RequirePodLinksIncludeText] +[-Documentation::RequirePodLinksIncludeText] [-Documentation::RequirePodSections] From 3a108250c925a7d839051d150f1cc9dc7e95b51a Mon Sep 17 00:00:00 2001 From: Kent Fredric Date: Wed, 20 Apr 2016 23:45:50 +1200 Subject: [PATCH 03/16] Pass sub properties directly to highlighters instead of binary flags. This is to make way for adding more sub properties and having it scale with demand. --- Changes | 4 ++++ lib/Devel/Isa/Explainer.pm | 30 ++++++++++++++++-------------- 2 files changed, 20 insertions(+), 14 deletions(-) diff --git a/Changes b/Changes index c1d4edb..7a6475f 100644 --- a/Changes +++ b/Changes @@ -5,6 +5,10 @@ Release history for Devel-Isa-Explainer - Improve bin/isa-splain's documentation to be more helpful in places where `man isa-splain` might be expected to work. + [Internals] + - Highligher functions now receive all sub metadata directly as a hash, instead of being called with a list of binary + flags. + 0.002001 2016-05-19T14:07:12Z c167598 [Documentation] - Reference updated screenshots. diff --git a/lib/Devel/Isa/Explainer.pm b/lib/Devel/Isa/Explainer.pm index cb213fa..f66c42c 100644 --- a/lib/Devel/Isa/Explainer.pm +++ b/lib/Devel/Isa/Explainer.pm @@ -78,21 +78,21 @@ sub _hl_TYPE_UTIL { } sub _hl_suffix { - return colored( $_[0], $SHADOW_SUFFIX ) if $_[2]; - return colored( $_[0], $SHADOWED_SUFFIX ) if $_[1]; + return colored( $_[0], $SHADOW_SUFFIX ) if $_[1]->{shadowing}; + return colored( $_[0], $SHADOWED_SUFFIX ) if $_[1]->{shadowed}; return q[]; } sub _hl_TYPE { return colored( \@TYPE, $_[0] ) } sub _hl_PUBLIC { - return ( $_[1] ? colored( \@SHADOWED_PUBLIC, $_[0] ) : colored( \@PUBLIC, $_[0] ) ) - . _hl_suffix( \@SHADOWED_PUBLIC, $_[1], $_[2] ); + return ( $_[1]->{shadowed} ? colored( \@SHADOWED_PUBLIC, $_[0] ) : colored( \@PUBLIC, $_[0] ) ) + . _hl_suffix( \@SHADOWED_PUBLIC, $_[1] ); } sub _hl_PRIVATE { - return ( $_[1] ? colored( \@SHADOWED_PRIVATE, $_[0] ) : colored( \@PRIVATE, $_[0] ) ) - . _hl_suffix( \@SHADOWED_PRIVATE, $_[1], $_[2] ); + return ( $_[1]->{shadowed} ? colored( \@SHADOWED_PRIVATE, $_[0] ) : colored( \@PRIVATE, $_[0] ) ) + . _hl_suffix( \@SHADOWED_PRIVATE, $_[1] ); } sub _pp_sub { @@ -106,13 +106,15 @@ sub _pp_key { push @tokens, 'Type Constraint Utility: ' . _hl_TYPE_UTIL('typeop_TypeName'); push @tokens, 'Private/Boring Sub: ' . _hl_PRIVATE('foo_example'); if ($SHOW_SHADOWED) { - push @tokens, 'Public Sub shadowing another: ' . _hl_PUBLIC( 'shadowing_example', 0, 1 ); - push @tokens, 'Public Sub shadowed by higher scope: ' . _hl_PUBLIC( 'shadowed_example', 1 ); - push @tokens, 'Public Sub shadowing another and shadowed itself: ' . _hl_PUBLIC( 'shadowed_shadowing_example', 1, 1 ); - - push @tokens, 'Private/Boring Sub shadowing another: ' . _hl_PRIVATE( 'shadowing_example', 0, 1 ); - push @tokens, 'Private/Boring Sub shadowed by higher scope: ' . _hl_PRIVATE( 'shadowed_example', 1 ); - push @tokens, 'Private/Boring Sub another and shadowed itself: ' . _hl_PRIVATE( 'shadowing_shadowed_example', 1, 1 ); + push @tokens, 'Public Sub shadowing another: ' . _hl_PUBLIC( 'shadowing_example', { shadowing => 1 } ); + push @tokens, 'Public Sub shadowed by higher scope: ' . _hl_PUBLIC( 'shadowed_example', { shadowed => 1 } ); + push @tokens, 'Public Sub shadowing another and shadowed itself: ' + . _hl_PUBLIC( 'shadowed_shadowing_example', { shadowing => 1, shadowed => 1 } ); + + push @tokens, 'Private/Boring Sub shadowing another: ' . _hl_PRIVATE( 'shadowing_example', { shadowing => 1 } ); + push @tokens, 'Private/Boring Sub shadowed by higher scope: ' . _hl_PRIVATE( 'shadowed_example', { shadowed => 1 } ); + push @tokens, 'Private/Boring Sub another and shadowed itself: ' + . _hl_PRIVATE( 'shadowing_shadowed_example', { shadowed => 1, shadowing => 1 } ); } push @tokens, 'No Subs: ()'; return sprintf "Key:\n$INDENT%s\n\n", join qq[\n$INDENT], @tokens; @@ -189,7 +191,7 @@ sub _pp_subs { # Suck up trailing , $cluster_out =~ s/,[ ]\n\z/\n/sx; - $cluster_out =~ s{(\w+)}{ _pp_sub($1, $subs{$1}->{shadowed}, $subs{$1}->{shadowing} ) }gsex; + $cluster_out =~ s{(\w+)}{ _pp_sub($1, $subs{$1} ) }gsex; push @out_clusters, $cluster_out; } return join qq[\n], @out_clusters; From a5eac85c71ebee3b0aebb6269cce6bb03e93b13b Mon Sep 17 00:00:00 2001 From: Kent Fredric Date: Wed, 8 Jun 2016 05:59:46 +1200 Subject: [PATCH 04/16] UNIVERSAL now shown in inheritance. Closes #11 --- Changes | 2 ++ lib/Devel/Isa/Explainer.pm | 36 +++++++++++++++++++++++++++--------- 2 files changed, 29 insertions(+), 9 deletions(-) diff --git a/Changes b/Changes index 7a6475f..7c02e47 100644 --- a/Changes +++ b/Changes @@ -1,6 +1,8 @@ Release history for Devel-Isa-Explainer {{$NEXT}} + - UNIVERSAL now automatically shown in inheritance. ( Closes #11 ) + [Documentation] - Improve bin/isa-splain's documentation to be more helpful in places where `man isa-splain` might be expected to work. diff --git a/lib/Devel/Isa/Explainer.pm b/lib/Devel/Isa/Explainer.pm index f66c42c..8a94ae8 100644 --- a/lib/Devel/Isa/Explainer.pm +++ b/lib/Devel/Isa/Explainer.pm @@ -216,12 +216,10 @@ sub _pp_class { return $out; } -sub _extract_mro { - my ($class) = @_; - my ($seen_subs) = {}; - - ## no critic (ProhibitCallsToUnexportedSubs) - my (@isa) = @{ mro::get_linear_isa($class) }; +sub _extract_subs { + my (@isa) = @_; + my $seen_subs = {}; + my $found_interesting = 0; # Discover all subs and compute full MRO every time a new sub-name # is found @@ -230,7 +228,6 @@ sub _extract_mro { next if exists $seen_subs->{$sub}; # Compute the full sub->package MRO table bottom up - $seen_subs->{$sub} = []; my $currently_visible; for my $class ( reverse @isa ) { @@ -238,13 +235,34 @@ sub _extract_mro { # Record the frame where the first new instance is seen. if ( not defined $currently_visible or $currently_visible != $coderef ) { - unshift @{ $seen_subs->{$sub} }, $class; # note: we're working bottom-up + + # note: we're working bottom-up + + unshift @{ $seen_subs->{$sub} }, $class; + + # UNIVERSAL is not interesting, it is always present, + # but if any parents turn up with subs? Interested + $found_interesting++ unless 'UNIVERSAL' eq $class; $currently_visible = $coderef; next; } } } } + return ( $found_interesting, $seen_subs ); +} + +sub _extract_mro { + my ($class) = @_; + + ## no critic (ProhibitCallsToUnexportedSubs) + my (@isa) = @{ mro::get_linear_isa($class) }; + + # UNIVERSAL must be assumed last because mro does not return it + # this also returns any parents UNIVERSAL may have had injected. + push @isa, @{ mro::get_linear_isa('UNIVERSAL') }; + + my ( $found_interesting, $seen_subs ) = _extract_subs(@isa); my $class_data = {}; @@ -270,7 +288,7 @@ sub _extract_mro { # Order class structures by MRO order my (@mro_order) = map { { class => $_, subs => $class_data->{$_} || {} } } @isa; - if ( 1 > @mro_order or ( 1 >= @mro_order and 1 > keys %{ $mro_order[0]->{subs} } ) ) { + if ( not $found_interesting ) { # Huh, No inheritance, and no subs. K. my $module_path = $class; From dc2062d82938082b317f5dd1fad2d31bb06f7374 Mon Sep 17 00:00:00 2001 From: Kent Fredric Date: Sat, 25 Jun 2016 23:49:07 +1200 Subject: [PATCH 05/16] Add UNIVERSAL-including get_linear_isa Provide a new module, _MRO, that contains a variation of get_linear_isa that includes UNIVERSAL and UNIVERSALs parents. Parents of UNIVERSAL don't return UNIVERSAL as their parents, for reasons of logical circularity. However, parents of UNIVERSAL can still have UNIVERSAL methods called on them, due to perl magic. --- Changes | 4 ++ Makefile.PL | 4 +- lib/Devel/Isa/Explainer.pm | 7 +-- lib/Devel/Isa/Explainer/_MRO.pm | 58 +++++++++++++++++++++ misc/Changes.deps | 2 + misc/Changes.deps.all | 2 + perlcritic.rc | 4 +- t/internals/mro/01-get-linear-isa.t | 81 +++++++++++++++++++++++++++++ 8 files changed, 154 insertions(+), 8 deletions(-) create mode 100644 lib/Devel/Isa/Explainer/_MRO.pm create mode 100644 t/internals/mro/01-get-linear-isa.t diff --git a/Changes b/Changes index 7c02e47..fdeb004 100644 --- a/Changes +++ b/Changes @@ -3,6 +3,10 @@ Release history for Devel-Isa-Explainer {{$NEXT}} - UNIVERSAL now automatically shown in inheritance. ( Closes #11 ) + [Dependencies::Stats] + - Dependencies changed since 0.002001, see misc/*.deps* for details + - test: +1 + [Documentation] - Improve bin/isa-splain's documentation to be more helpful in places where `man isa-splain` might be expected to work. diff --git a/Makefile.PL b/Makefile.PL index dc5b6a6..56724e4 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -35,11 +35,12 @@ my %WriteMakefileArgs = ( "ExtUtils::MakeMaker" => 0, "File::Spec" => 0, "Test::Builder" => 0, + "Test::Differences" => 0, "Test::More" => "0.89" }, "VERSION" => "0.002002", "test" => { - "TESTS" => "t/*.t t/00-compile/*.t t/cli/*.t t/internals/*.t" + "TESTS" => "t/*.t t/00-compile/*.t t/cli/*.t t/internals/*.t t/internals/mro/*.t" } ); @@ -54,6 +55,7 @@ my %FallbackPrereqs = ( "Package::Stash" => 0, "Term::ANSIColor" => "3.00", "Test::Builder" => 0, + "Test::Differences" => 0, "Test::More" => "0.89", "constant" => "1.03", "namespace::clean" => 0, diff --git a/lib/Devel/Isa/Explainer.pm b/lib/Devel/Isa/Explainer.pm index 8a94ae8..2ee7438 100644 --- a/lib/Devel/Isa/Explainer.pm +++ b/lib/Devel/Isa/Explainer.pm @@ -15,6 +15,7 @@ use Term::ANSIColor 3.00 ('colored'); # bright_ use Carp ('croak'); use Package::Stash (); use MRO::Compat (); +use Devel::Isa::Explainer::_MRO qw( get_linear_isa ); # Perl critic is broken. This is not a void context. ## no critic (BuiltinFunctions::ProhibitVoidMap) @@ -256,11 +257,7 @@ sub _extract_mro { my ($class) = @_; ## no critic (ProhibitCallsToUnexportedSubs) - my (@isa) = @{ mro::get_linear_isa($class) }; - - # UNIVERSAL must be assumed last because mro does not return it - # this also returns any parents UNIVERSAL may have had injected. - push @isa, @{ mro::get_linear_isa('UNIVERSAL') }; + my (@isa) = @{ get_linear_isa($class) }; my ( $found_interesting, $seen_subs ) = _extract_subs(@isa); diff --git a/lib/Devel/Isa/Explainer/_MRO.pm b/lib/Devel/Isa/Explainer/_MRO.pm new file mode 100644 index 0000000..d6d4a5e --- /dev/null +++ b/lib/Devel/Isa/Explainer/_MRO.pm @@ -0,0 +1,58 @@ +use 5.006; # our +use strict; +use warnings; + +package Devel::Isa::Explainer::_MRO; + +# ABSTRACT: Method-resolution-order Utilities for DIE + +# AUTHORITY + +our $VERSION = '0.002900'; + +use MRO::Compat (); +use Exporter (); + +BEGIN { + ## no critic (ProhibitCallsToUnexportedSubs) + *import = \&Exporter::import; + *_mro_get_linear_isa = \&mro::get_linear_isa; + *_mro_is_universal = \&mro::is_universal; +} + +# yes, this is evil + +our @EXPORT_OK = qw( + get_linear_isa +); + +use namespace::clean -except => 'import'; + +=func get_linear_isa + + my $isa = get_linear_isa( $class ); + +This function is like C<< mro::get_linear_isa()|mro/get_linear_isa >>, with +the exception that it includes C and any parents of C +where relevant. + +If pointed at C, will include Cs parents. + +If pointed at a L<< parent of C|mro/is_univeral >>, will B +show C, despite the fact calling C<< ->can() >> on a parent of +C still works, despite the fact its actually defined in C. + +=cut + +sub get_linear_isa { + [ + @{ _mro_get_linear_isa( $_[0] ) }, + #<<< + _mro_is_universal( $_[0] ) + ? () + : @{ _mro_get_linear_isa('UNIVERSAL') }, + #>>> + ]; +} + +1; diff --git a/misc/Changes.deps b/misc/Changes.deps index 10dc8a1..e78aba9 100644 --- a/misc/Changes.deps +++ b/misc/Changes.deps @@ -1,6 +1,8 @@ This file contains changes in REQUIRED dependencies for standard CPAN phases (configure/build/runtime/test) 0.002002 + [Added / test requires] + - Test::Differences 0.002001 2016-05-19T14:07:12Z diff --git a/misc/Changes.deps.all b/misc/Changes.deps.all index 49a0da5..39d502f 100644 --- a/misc/Changes.deps.all +++ b/misc/Changes.deps.all @@ -1,6 +1,8 @@ This file contains ALL changes in dependencies in both REQUIRED / OPTIONAL dependencies for all phases (configure/build/runtime/test/develop) 0.002002 + [Added / test requires] + - Test::Differences 0.002001 2016-05-19T14:07:12Z diff --git a/perlcritic.rc b/perlcritic.rc index a4f7ba5..21edb08 100644 --- a/perlcritic.rc +++ b/perlcritic.rc @@ -317,7 +317,7 @@ allowed_pragmata = diagnostics feature perlversion strict warnings utf8 [Subroutines::ProhibitExcessComplexity] -[Subroutines::ProhibitExplicitReturnUndef] +[-Subroutines::ProhibitExplicitReturnUndef] [Subroutines::ProhibitExportingUndeclaredSubs] @@ -338,7 +338,7 @@ private_name_regex = _(?!build_)\w [-Subroutines::RequireArgUnpacking] -[Subroutines::RequireFinalReturn] +[-Subroutines::RequireFinalReturn] [-TestingAndDebugging::ProhibitNoStrict] diff --git a/t/internals/mro/01-get-linear-isa.t b/t/internals/mro/01-get-linear-isa.t new file mode 100644 index 0000000..e7e6341 --- /dev/null +++ b/t/internals/mro/01-get-linear-isa.t @@ -0,0 +1,81 @@ +use strict; +use warnings; + +use Test::More; +use Devel::Isa::Explainer::_MRO; +use Test::Differences qw( eq_or_diff ); + +# A -> C +# -> D +# A <- +# -> B +@My::Example::A::ISA = ( 'My::Example::C', 'My::Example::B' ); +@My::Example::B::ISA = ('My::Example::C'); +@My::Example::C::ISA = ('My::Example::D'); +@My::Example::D::ISA = (); + +eq_or_diff( + Devel::Isa::Explainer::_MRO::get_linear_isa('My::Example::A'), + [ 'My::Example::A', 'My::Example::C', 'My::Example::D', 'My::Example::B', 'UNIVERSAL' ], + 'dfs lookup works' +); + +# DFS: +# E -> F +# -> H +# <------ +# -> G +# -> UNIVERSAL +# C3: +# E -> +# -> F +# -> G +# -> H +# -> UNIVERSAL +@My::Example::E::ISA = ( 'My::Example::F', 'My::Example::G' ); +@My::Example::F::ISA = ('My::Example::H'); +@My::Example::G::ISA = ('My::Example::H'); +@My::Example::H::ISA = (); + +eq_or_diff( + Devel::Isa::Explainer::_MRO::get_linear_isa('My::Example::E'), + [ 'My::Example::E', 'My::Example::F', 'My::Example::H', 'My::Example::G', 'UNIVERSAL' ], + 'dfs lookup works v2' +); + +use MRO::Compat; +mro::set_mro( "My::Example::E", "c3" ); + +eq_or_diff( + Devel::Isa::Explainer::_MRO::get_linear_isa('My::Example::E'), + [ 'My::Example::E', 'My::Example::F', 'My::Example::G', 'My::Example::H', 'UNIVERSAL' ], + 'c3 lookup works and changes MRO' +); + +eq_or_diff( Devel::Isa::Explainer::_MRO::get_linear_isa('UNIVERSAL'), ['UNIVERSAL'], 'UNIVERSAL contains only itself' ); + +@My::EVIL::ISA = (); +push @UNIVERSAL::ISA, "My::EVIL"; + +eq_or_diff( + Devel::Isa::Explainer::_MRO::get_linear_isa('My::Example::A'), + [ 'My::Example::A', 'My::Example::C', 'My::Example::D', 'My::Example::B', 'UNIVERSAL', 'My::EVIL' ], + 'Tweaking UNIVERSAL::ISA shows up' +); + +eq_or_diff( + Devel::Isa::Explainer::_MRO::get_linear_isa('My::Example::E'), + [ 'My::Example::E', 'My::Example::F', 'My::Example::G', 'My::Example::H', 'UNIVERSAL', 'My::EVIL' ], + 'tweaking UNIVERSAL::ISA shows up in c3' +); + +eq_or_diff( + Devel::Isa::Explainer::_MRO::get_linear_isa('UNIVERSAL'), + [ 'UNIVERSAL', 'My::EVIL' ], + 'UNIVERSAL contains evil when extended' +); + +eq_or_diff( Devel::Isa::Explainer::_MRO::get_linear_isa('My::EVIL'), + ['My::EVIL'], 'Parents of Universal dont inherit from UNIVERSAL' ); + +done_testing; From 3c5758615e642a303e0b40d704cd53a3112de788 Mon Sep 17 00:00:00 2001 From: Kent Fredric Date: Sat, 25 Jun 2016 23:54:46 +1200 Subject: [PATCH 06/16] Add utility is_mro_proxy This utility will allow us to isolate and ignore proxies installed by Class::C3 in its C3 emulation on 5.8 --- lib/Devel/Isa/Explainer/_MRO.pm | 29 +++++++++++++++++++++++++++++ 1 file changed, 29 insertions(+) diff --git a/lib/Devel/Isa/Explainer/_MRO.pm b/lib/Devel/Isa/Explainer/_MRO.pm index d6d4a5e..af853a8 100644 --- a/lib/Devel/Isa/Explainer/_MRO.pm +++ b/lib/Devel/Isa/Explainer/_MRO.pm @@ -23,11 +23,40 @@ BEGIN { # yes, this is evil our @EXPORT_OK = qw( + is_mro_proxy get_linear_isa ); +BEGIN { + # MRO Proxies removed since 5.009_005 + *MRO_PROXIES = ( $] <= 5.009005 ) ? sub() { 1 } : sub() { 0 }; +} + use namespace::clean -except => 'import'; +=func is_mro_proxy + + if ( MRO_PROXIES and is_mro_proxy( $package, $sub ) ) { + // its a proxy + } else { + // anything else + } + +Prior to 5.009_005, L<< backwards-compatibility support for C|MRO::Compat >> for +5.8 has to install "proxy" subs at various levels that I alternative +resolution orders by hiding relevant nodes in the gaps in tree. + +This detects those nodes so that we can pretend they don't exist. + +=cut + +sub is_mro_proxy { + + # Note: this sub should be optimised out from calling anyway + # but this is just a failsafe + MRO_PROXIES ? !!( $Class::C3::MRO{ $_[0] } || {} )->{methods}{ $_[1] } : 0; +} + =func get_linear_isa my $isa = get_linear_isa( $class ); From 6cdad6478786920af996d0f3f213a25c29a9ec69 Mon Sep 17 00:00:00 2001 From: Kent Fredric Date: Sun, 26 Jun 2016 00:12:03 +1200 Subject: [PATCH 07/16] Remove usage of "can" to determine which subs are visible. "can" traces the method-resolution order of the invocants class, not the method resoltuion of the target class. This means "can" can: - Show subs ahead of their declaration point in DFS, requiring additional deduplication - Show subs appearing "between" 2 alternative ISA frames, as follows: X -> meth(b) -> via Z Y -> meth(a) -> via C Z -> meth(b) C -> meth(a) Whereas it never actually appeared there, because MRO for "X" saw only: X Y Z -> meth(b) C -> meth(a) Closes #10 Inadvertently solves problems with blessed subs. --- Changes | 7 +- Makefile.PL | 4 + lib/Devel/Isa/Explainer.pm | 5 +- lib/Devel/Isa/Explainer/_MRO.pm | 48 +++++++++++ misc/Changes.deps | 4 + misc/Changes.deps.all | 4 + t/internals/04-blessed_subs.t | 32 +++++++ t/internals/mro/02-get-package-sub.t | 39 +++++++++ xt/release/01-package-stash-compat.t | 120 +++++++++++++++++++++++++++ 9 files changed, 260 insertions(+), 3 deletions(-) create mode 100644 t/internals/04-blessed_subs.t create mode 100644 t/internals/mro/02-get-package-sub.t create mode 100644 xt/release/01-package-stash-compat.t diff --git a/Changes b/Changes index fdeb004..01e915b 100644 --- a/Changes +++ b/Changes @@ -2,10 +2,15 @@ Release history for Devel-Isa-Explainer {{$NEXT}} - UNIVERSAL now automatically shown in inheritance. ( Closes #11 ) + - discovering subs using "can" now removed, as "can" was prematurely exposing subs in crossed inheritances, which + leads to over-zealous de-duplication, and additional appearances of shadowing where no actual shadowing was + happening. ( #10 ) + - blessed coderefs no longer misunderstood. [Dependencies::Stats] - Dependencies changed since 0.002001, see misc/*.deps* for details - - test: +1 + - runtime: +1 + - test: +2 [Documentation] - Improve bin/isa-splain's documentation to be more helpful in places where `man isa-splain` might be expected to diff --git a/Makefile.PL b/Makefile.PL index 56724e4..72a0437 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -25,6 +25,7 @@ my %WriteMakefileArgs = ( "MRO::Compat" => 0, "Module::Load" => 0, "Package::Stash" => 0, + "Scalar::Util" => 0, "Term::ANSIColor" => "3.00", "constant" => "1.03", "namespace::clean" => 0, @@ -32,6 +33,7 @@ my %WriteMakefileArgs = ( "warnings" => 0 }, "TEST_REQUIRES" => { + "B" => 0, "ExtUtils::MakeMaker" => 0, "File::Spec" => 0, "Test::Builder" => 0, @@ -46,6 +48,7 @@ my %WriteMakefileArgs = ( my %FallbackPrereqs = ( + "B" => 0, "Carp" => 0, "Exporter" => 0, "ExtUtils::MakeMaker" => 0, @@ -53,6 +56,7 @@ my %FallbackPrereqs = ( "MRO::Compat" => 0, "Module::Load" => 0, "Package::Stash" => 0, + "Scalar::Util" => 0, "Term::ANSIColor" => "3.00", "Test::Builder" => 0, "Test::Differences" => 0, diff --git a/lib/Devel/Isa/Explainer.pm b/lib/Devel/Isa/Explainer.pm index 2ee7438..bb58c6d 100644 --- a/lib/Devel/Isa/Explainer.pm +++ b/lib/Devel/Isa/Explainer.pm @@ -15,7 +15,8 @@ use Term::ANSIColor 3.00 ('colored'); # bright_ use Carp ('croak'); use Package::Stash (); use MRO::Compat (); -use Devel::Isa::Explainer::_MRO qw( get_linear_isa ); +use Devel::Isa::Explainer::_MRO qw( get_linear_isa get_package_sub ); + # Perl critic is broken. This is not a void context. ## no critic (BuiltinFunctions::ProhibitVoidMap) @@ -232,7 +233,7 @@ sub _extract_subs { $seen_subs->{$sub} = []; my $currently_visible; for my $class ( reverse @isa ) { - my $coderef = $class->can($sub) or next; + my $coderef = get_package_sub( $class, $sub ) or next; # Record the frame where the first new instance is seen. if ( not defined $currently_visible or $currently_visible != $coderef ) { diff --git a/lib/Devel/Isa/Explainer/_MRO.pm b/lib/Devel/Isa/Explainer/_MRO.pm index af853a8..bc92e98 100644 --- a/lib/Devel/Isa/Explainer/_MRO.pm +++ b/lib/Devel/Isa/Explainer/_MRO.pm @@ -12,6 +12,7 @@ our $VERSION = '0.002900'; use MRO::Compat (); use Exporter (); +use Scalar::Util qw(reftype); BEGIN { ## no critic (ProhibitCallsToUnexportedSubs) @@ -25,6 +26,7 @@ BEGIN { our @EXPORT_OK = qw( is_mro_proxy get_linear_isa + get_package_sub ); BEGIN { @@ -84,4 +86,50 @@ sub get_linear_isa { ]; } +=func get_package_sub + + my $sub = get_package_sub($package, $sub); + +Fetch a directly defined C from C<$package> named C<$sub> + +Fake proxy methods (such as Class::C3 proxies) and stubs are ignored by this +and instead return C + + $result = undef / CODEREF + +=cut + +sub get_package_sub { + return undef if MRO_PROXIES and is_mro_proxy(@_); + my ( $package, $sub ) = @_; + + # this is counter intuitive, but literally + # everything in a stash that is not a glob *is* a sub. + # + # Though they're usually constant-subs. + # + # Globs however can /contain/ subs in their {CODE} slot, + # but globs are not subs. + my $namespace = do { + no strict 'refs'; + \%{"${package}::"}; + }; + return undef unless exists $namespace->{$sub}; + if ( 'GLOB' eq reftype \$namespace->{$sub} ) { + + # Autoviv guard. + return defined *{ \$namespace->{$sub} }{'CODE'} ? *{ \$namespace->{$sub} }{'CODE'} : undef; + } + + # Note: This vivifies the stash slot into a glob... + # there's not much that can be done about this at present. + # Package::Stash does the same. + # + # This means the first of us or Package::Stash to traverse a symtable turns + # everything into globs in order to get coderefs out. + # + # Ideally, we don't do this, but ENEEDINFO + return \&{"${package}::${sub}"}; +} + 1; diff --git a/misc/Changes.deps b/misc/Changes.deps index e78aba9..737116e 100644 --- a/misc/Changes.deps +++ b/misc/Changes.deps @@ -1,7 +1,11 @@ This file contains changes in REQUIRED dependencies for standard CPAN phases (configure/build/runtime/test) 0.002002 + [Added / runtime requires] + - Scalar::Util + [Added / test requires] + - B - Test::Differences 0.002001 2016-05-19T14:07:12Z diff --git a/misc/Changes.deps.all b/misc/Changes.deps.all index 39d502f..b13cca4 100644 --- a/misc/Changes.deps.all +++ b/misc/Changes.deps.all @@ -1,7 +1,11 @@ This file contains ALL changes in dependencies in both REQUIRED / OPTIONAL dependencies for all phases (configure/build/runtime/test/develop) 0.002002 + [Added / runtime requires] + - Scalar::Util + [Added / test requires] + - B - Test::Differences 0.002001 2016-05-19T14:07:12Z diff --git a/t/internals/04-blessed_subs.t b/t/internals/04-blessed_subs.t new file mode 100644 index 0000000..62b4769 --- /dev/null +++ b/t/internals/04-blessed_subs.t @@ -0,0 +1,32 @@ +use strict; +use warnings; + +use Test::More; +use B qw(); +{ + package My::Test; + sub constant_sub() { 'Hello' } + BEGIN { + bless \&My::Test::constant_sub, 'My::Test'; + *My::Test::xsub = \&B::svref_2object; + bless \&My::Test::xsub, 'B'; + }; +} + +use Devel::Isa::Explainer (); + +*extract_mro = \&Devel::Isa::Explainer::_extract_mro; +{ + my $mro = extract_mro("My::Test"); + my $fail = 0; + for my $class ( @{$mro} ) { + next unless $class->{class} eq 'My::Test'; + $fail = 1 unless ok( exists $class->{subs}->{'constant_sub'}, "constant_sub discovered in class" ); + $fail = 1 unless ok( $class->{subs}->{'constant_sub'}->{constant}, "constant_sub is a constant sub" ); + $fail = 1 unless ok( exists $class->{subs}->{'xsub'}, "xsub discovered in class" ); + $fail = 1 unless ok( $class->{subs}->{'xsub'}->{xsub}, "xsub is an XSUB" ); + } + diag explain $mro if $fail; + +} +done_testing; diff --git a/t/internals/mro/02-get-package-sub.t b/t/internals/mro/02-get-package-sub.t new file mode 100644 index 0000000..5f62095 --- /dev/null +++ b/t/internals/mro/02-get-package-sub.t @@ -0,0 +1,39 @@ +use strict; +use warnings; + +use Test::More; +use Devel::Isa::Explainer::_MRO; + +BEGIN { + *getsub = sub { + Devel::Isa::Explainer::_MRO::get_package_sub( 'KENTNL::Example', $_[0] ); + }; +} + +{ + package # hide + KENTNL::Example; + + sub foo { 'foo' } + sub bar { 'bar' } + sub indef; + + our %HASHV; + our @ARRAYV; + our $SCALARV; + *SYMV = *SYMV; +} + +ok( defined getsub('foo'), "foo is a sub" ); +ok( defined getsub('bar'), "bar is a sub" ); +ok( defined getsub('indef'), "indef is a sub" ); +ok( !defined getsub('HASHV'), "HASHV is not a sub" ); +ok( !defined getsub('ARRAYV'), "ARRAYV is not a sub" ); +ok( !defined getsub('SCALARV'), "SCALARV is not a sub" ); +ok( !defined getsub('SYMV'), "SYMV is not a sub" ); +ok( !defined getsub('missing'), "missing is not a sub" ); +is( getsub('foo')->(), 'foo', "foo sub returned ok" ); +is( getsub('bar')->(), 'bar', "bar sub returned ok" ); + +done_testing; + diff --git a/xt/release/01-package-stash-compat.t b/xt/release/01-package-stash-compat.t new file mode 100644 index 0000000..006b168 --- /dev/null +++ b/xt/release/01-package-stash-compat.t @@ -0,0 +1,120 @@ + +use strict; +use warnings; + +use Test::Needs { + 'Package::Stash::PP' => 0, + 'Scalar::Util' => 0, +}; + +use Test::More; +use Devel::Isa::Explainer::_MRO qw( get_package_sub ); + +use Scalar::Util qw( reftype refaddr ); + +{ + + package Foo; + use constant CSCALAR => 1; + use constant CSCALARREF => \1; + use constant CARRAYREF => []; + use constant CHASHREF => {}; + use constant CSUB => sub { }; + sub subnormal { } + sub substub; + sub subnormalproto () { } + sub substubproto (); + + our @OURARRAY; + our %OURHASH; + our $OURSCALAR; + + *EMPTYGLOB = *EMPTYGLOB; + + our @GLOBCOLLISION; + our %GLOBCOLLISION; + sub GLOBCOLLISION { } + + do { no strict 'refs'; my $var = 'Foo'; \%{ $var . '::' } } + ->{'stubUNDEF'} = undef; + do { no strict 'refs'; my $var = 'Foo'; \%{ $var . '::' } } + ->{'stubDSCALAR'} = 1; + + package Foo::SubPackage; + *CHILDGLOB = *CHILDGLOB; +} + +my (@cases); +push @cases, qw( CSCALAR CSCALARREF CARRAYREF CHASHREF CSUB ); +push @cases, qw( subnormal substub subnormalproto substubproto ); +push @cases, qw( OURARRAY OURHASH OURSCALAR ); +push @cases, qw( EMPTYGLOB GLOBCOLLISION stubUNDEF stubDSCALAR ); +push @cases, qw( SubPackage ); + +# using PP because PS:XS and PS:PP return undef or empty string depending on which you get ... +my ( $ps1, $ps2 ) = ( Package::Stash::PP->new('Foo'), Package::Stash::PP->new('Foo') ); + +for my $case (@cases) { + note("$case"); + + # Note, its important we run first, because Package::Stash vivifies slots into globs + # in order to get the symbol. + # + # We will try not to do this one day, but until then, we have to run first + # to make sure the "not a glob" path is exercised. + my $local_result = get_package_sub( 'Foo', $case ); + + # We do this twice for consistency, in the event Package::Stash ever ends up returning + # different things between runs. + # + # Explicit has_symbol is used to try (and fail) to guard against symtable changes. + my $ps1_result = $ps1->has_symbol( '&' . $case ) ? $ps1->get_symbol( '&' . $case ) : undef; + my $ps2_result = $ps2->has_symbol( '&' . $case ) ? $ps2->get_symbol( '&' . $case ) : undef; + + if ( 0 == grep { defined } ( $ps1_result, $ps2_result, $local_result ) ) { + pass("Package::Stash and _MRO agree, \&$case is undefined"); + next; + } + if ( 3 == grep { defined } ( $ps1_result, $ps2_result, $local_result ) ) { + pass("Package::Stash and _MRO agree, \&$case is defined"); + } + else { + fail("Missmatch on definedness for \&$case"); + next; + } + if ( 2 == grep { reftype $ps1_result eq reftype $_ } ( $ps2_result, $local_result ) ) { + pass( "PS and _MRO agree, \&$case is a " . reftype $ps1_result ); + } + else { + fail("PS and _MRO agree on reftype of \&$case"); + diag("PS and _MRO reftypes disagree"); + + diag explain { + ps_1 => reftype $ps1_result, + ps_2 => reftype $ps2_result, + _mro => reftype $local_result, + }; + } + if ( 2 == grep { refaddr $ps1_result eq refaddr $_ } ( $ps2_result, $local_result ) ) { + pass( "PS and _MRO agree, \&$case has refaddr " . refaddr $ps1_result ); + } + else { + fail("PS and _MRO agree on refaddr of \&$case"); + diag("PS and _MRO refaddrs disagree"); + diag explain { + ps_1 => refaddr $ps1_result, + ps_2 => refaddr $ps2_result, + _mro => refaddr $local_result, + }; + } + if ( 'CODE' eq reftype $ps1_result ) { + if ( $case =~ /stub/ ) { + ok( !defined &$ps1_result, "&$case is a stub" ); + } + elsif ( $case =~ /normal/ ) { + ok( defined &$ps1_result, "&$case is not a stub" ); + } + } +} + +done_testing; From 50371defffec9a3fa2aa42f859a515b6e4dc3ab2 Mon Sep 17 00:00:00 2001 From: Kent Fredric Date: Sun, 26 Jun 2016 00:48:14 +1200 Subject: [PATCH 08/16] Remove deduplicating logic. The neeed for deduplicating was an auxilliary side effect of looking up MRO wrong with ->can(); When not using ->can(), any subs that appear directly in a package stash do appear exactly where they seem to appear in the MRO list. Thus, any exact duplicates of a sub in the heirarchy will in fact **call themselves** when ascending up the method resolution table. However, there is presently no useful way for this to work, as a subref calling itself on a higher inheritance level invokes a perpetual loop due to next::method assuming the "sub name" to be enough to determine the calling level. hence, sub Foo::A::meth { $_[0]->next::method } *Bar::Baz::meth = \*Foo::A::meth Bar::Baz->meth Will end up with Bar::Baz::meth Assuming it is actually Foo::A::meth And trying to enter the parent of Foo::A ... So we're going to just keep the subs in place to help you see something like that could happen if you're careful enough See $#10 for details. --- Changes | 5 +++- Makefile.PL | 2 -- lib/Devel/Isa/Explainer.pm | 40 ++++++++----------------- lib/Devel/Isa/Explainer/_MRO.pm | 42 +++++++++++++++++++++++++++ misc/Changes.deps | 3 ++ misc/Changes.deps.all | 3 ++ t/internals/02-isacache-hide.t | 2 +- t/internals/mro/03-get-package-subs.t | 38 ++++++++++++++++++++++++ 8 files changed, 103 insertions(+), 32 deletions(-) create mode 100644 t/internals/mro/03-get-package-subs.t diff --git a/Changes b/Changes index 01e915b..26015a0 100644 --- a/Changes +++ b/Changes @@ -6,10 +6,13 @@ Release history for Devel-Isa-Explainer leads to over-zealous de-duplication, and additional appearances of shadowing where no actual shadowing was happening. ( #10 ) - blessed coderefs no longer misunderstood. + - deduplicating subs now entirely removed, subs that are actually there in the package must always be displayed as + they are either injected by roles or importing, and can actually end up calling themselves under inheritance. ( This + however is highly prone to explosions because MRO core sucks ) ( Related to #10 ) [Dependencies::Stats] - Dependencies changed since 0.002001, see misc/*.deps* for details - - runtime: +1 + - runtime: +1 -1 - test: +2 [Documentation] diff --git a/Makefile.PL b/Makefile.PL index 72a0437..0527fb3 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -24,7 +24,6 @@ my %WriteMakefileArgs = ( "Exporter" => 0, "MRO::Compat" => 0, "Module::Load" => 0, - "Package::Stash" => 0, "Scalar::Util" => 0, "Term::ANSIColor" => "3.00", "constant" => "1.03", @@ -55,7 +54,6 @@ my %FallbackPrereqs = ( "File::Spec" => 0, "MRO::Compat" => 0, "Module::Load" => 0, - "Package::Stash" => 0, "Scalar::Util" => 0, "Term::ANSIColor" => "3.00", "Test::Builder" => 0, diff --git a/lib/Devel/Isa/Explainer.pm b/lib/Devel/Isa/Explainer.pm index bb58c6d..df6816b 100644 --- a/lib/Devel/Isa/Explainer.pm +++ b/lib/Devel/Isa/Explainer.pm @@ -12,10 +12,9 @@ our $VERSION = '0.002002'; use Exporter (); use Term::ANSIColor 3.00 ('colored'); # bright_ -use Carp ('croak'); -use Package::Stash (); -use MRO::Compat (); -use Devel::Isa::Explainer::_MRO qw( get_linear_isa get_package_sub ); +use Carp ('croak'); +use MRO::Compat (); +use Devel::Isa::Explainer::_MRO qw( get_linear_isa get_package_subs ); # Perl critic is broken. This is not a void context. @@ -225,30 +224,15 @@ sub _extract_subs { # Discover all subs and compute full MRO every time a new sub-name # is found - for my $isa (@isa) { - for my $sub ( Package::Stash->new($isa)->list_all_symbols('CODE') ) { - next if exists $seen_subs->{$sub}; - - # Compute the full sub->package MRO table bottom up - $seen_subs->{$sub} = []; - my $currently_visible; - for my $class ( reverse @isa ) { - my $coderef = get_package_sub( $class, $sub ) or next; - - # Record the frame where the first new instance is seen. - if ( not defined $currently_visible or $currently_visible != $coderef ) { - - # note: we're working bottom-up - - unshift @{ $seen_subs->{$sub} }, $class; - - # UNIVERSAL is not interesting, it is always present, - # but if any parents turn up with subs? Interested - $found_interesting++ unless 'UNIVERSAL' eq $class; - $currently_visible = $coderef; - next; - } - } + for my $isa ( reverse @isa ) { + my $subs = get_package_subs($isa); + for my $sub ( keys %{$subs} ) { + $seen_subs->{$sub} = [] unless exists $seen_subs->{$sub}; + unshift @{ $seen_subs->{$sub} }, $isa; + + # UNIVERSAL is not interesting, it is always present, + # but if any parents turn up with subs? Interested + $found_interesting++ unless 'UNIVERSAL' eq $isa; } } return ( $found_interesting, $seen_subs ); diff --git a/lib/Devel/Isa/Explainer/_MRO.pm b/lib/Devel/Isa/Explainer/_MRO.pm index bc92e98..0e07ed9 100644 --- a/lib/Devel/Isa/Explainer/_MRO.pm +++ b/lib/Devel/Isa/Explainer/_MRO.pm @@ -27,6 +27,7 @@ our @EXPORT_OK = qw( is_mro_proxy get_linear_isa get_package_sub + get_package_subs ); BEGIN { @@ -132,4 +133,45 @@ sub get_package_sub { return \&{"${package}::${sub}"}; } +=func get_package_subs + + my $hashref = get_package_subs( $packagename ); + +Returns a hash of the packages directly defined C's. + + $result = { SUBNAME => CODEREF, ... }; + +=cut + +# like get_package_sub, but does a whole class at once and returns a hashref +# of { name => CODEREF } +sub get_package_subs { + my ($package) = @_; + my ($namespace) = do { + no strict 'refs'; + \%{"${package}::"}; + }; + my (@symnames) = do { + no strict 'refs'; + keys %{"${package}::"}; + }; + my $subs = {}; + for my $symname (@symnames) { + + my $reftype = reftype \$namespace->{$symname}; + + # Globs are only subs if they contain a CODE slot + # all non-globs vivify to subs. + # Order can't be changed though, because the second test requires the + # first to be true to test, so defined is only tested when eq. + next if ( 'GLOB' eq $reftype ) and not defined *{ \$namespace->{$symname} }{'CODE'}; + next if MRO_PROXIES and is_mro_proxy( $package, $symname ); + $subs->{$symname} = + 'GLOB' eq $reftype + ? *{ \$namespace->{$symname} }{'CODE'} + : \&{"${package}::${symname}"}; + } + $subs; +} + 1; diff --git a/misc/Changes.deps b/misc/Changes.deps index 737116e..70728b5 100644 --- a/misc/Changes.deps +++ b/misc/Changes.deps @@ -8,6 +8,9 @@ This file contains changes in REQUIRED dependencies for standard CPAN phases (co - B - Test::Differences + [Removed / runtime requires] + - Package::Stash + 0.002001 2016-05-19T14:07:12Z 0.002000 2016-05-19T12:30:00Z diff --git a/misc/Changes.deps.all b/misc/Changes.deps.all index b13cca4..9a2eccc 100644 --- a/misc/Changes.deps.all +++ b/misc/Changes.deps.all @@ -8,6 +8,9 @@ This file contains ALL changes in dependencies in both REQUIRED / OPTIONAL depen - B - Test::Differences + [Removed / runtime requires] + - Package::Stash + 0.002001 2016-05-19T14:07:12Z 0.002000 2016-05-19T12:30:00Z diff --git a/t/internals/02-isacache-hide.t b/t/internals/02-isacache-hide.t index b0eed02..0b3c822 100644 --- a/t/internals/02-isacache-hide.t +++ b/t/internals/02-isacache-hide.t @@ -24,7 +24,7 @@ $INC{ 'Class' . $_ . q[.pm] } = 1 for qw( A B C ); my @errors; for my $class ( grep { $_->{class} eq 'ClassA' } @{$mro} ) { - eval { $oks-- if ok( !scalar keys %{ $class->{subs} }, 'ClassA has no subs' ) } or push @errors, $@; + eval { $oks-- if ok( scalar keys %{ $class->{subs} }, 'ClassA has subs' ) } or push @errors, $@; } for my $class ( grep { $_->{class} eq 'ClassB' } @{$mro} ) { eval { $oks-- if ok( !scalar keys %{ $class->{subs} }, 'ClassB has no subs' ) } or push @errors, $@; diff --git a/t/internals/mro/03-get-package-subs.t b/t/internals/mro/03-get-package-subs.t new file mode 100644 index 0000000..9053ce7 --- /dev/null +++ b/t/internals/mro/03-get-package-subs.t @@ -0,0 +1,38 @@ +use strict; +use warnings; + +use Test::More; +use Devel::Isa::Explainer::_MRO; + +BEGIN { + *getsubs = sub { + Devel::Isa::Explainer::_MRO::get_package_subs('KENTNL::Example'); + }; +} + +{ + package # hide + KENTNL::Example; + + sub foo { 'foo' } + sub bar { 'bar' } + sub indef; + + our %HASHV; + our @ARRAYV; + our $SCALARV; + *SYMV = *SYMV; +} + +my $hash = getsubs(); + +ok( defined( my $foo = delete $hash->{'foo'} ), 'Got foo' ); +ok( defined( my $bar = delete $hash->{'bar'} ), 'Got bar' ); +ok( defined( my $indef = delete $hash->{'indef'} ), 'Got indef' ); +is( $bar->(), 'bar', 'Bar runs' ); +is( $foo->(), 'foo', 'Foo runs' ); +ok( !defined &$indef, 'indef is a stub' ); +ok( !keys %{$hash}, "No residual keys in hash" ) or diag explain $hash; + +done_testing; + From d97586ea18d1d9a226c33fcfa86a2a30e6374626 Mon Sep 17 00:00:00 2001 From: Kent Fredric Date: Sun, 26 Jun 2016 16:30:44 +1200 Subject: [PATCH 09/16] Extract Method-Resolution + Class-Shadow computation. --- lib/Devel/Isa/Explainer.pm | 63 ++++------------ lib/Devel/Isa/Explainer/_MRO.pm | 50 +++++++++++++ t/internals/mro/04-get-linear-class-shadows.t | 73 +++++++++++++++++++ 3 files changed, 138 insertions(+), 48 deletions(-) create mode 100644 t/internals/mro/04-get-linear-class-shadows.t diff --git a/lib/Devel/Isa/Explainer.pm b/lib/Devel/Isa/Explainer.pm index df6816b..4764ef1 100644 --- a/lib/Devel/Isa/Explainer.pm +++ b/lib/Devel/Isa/Explainer.pm @@ -14,7 +14,7 @@ use Exporter (); use Term::ANSIColor 3.00 ('colored'); # bright_ use Carp ('croak'); use MRO::Compat (); -use Devel::Isa::Explainer::_MRO qw( get_linear_isa get_package_subs ); +use Devel::Isa::Explainer::_MRO qw( get_linear_class_shadows ); # Perl critic is broken. This is not a void context. @@ -217,59 +217,26 @@ sub _pp_class { return $out; } -sub _extract_subs { - my (@isa) = @_; - my $seen_subs = {}; - my $found_interesting = 0; - - # Discover all subs and compute full MRO every time a new sub-name - # is found - for my $isa ( reverse @isa ) { - my $subs = get_package_subs($isa); - for my $sub ( keys %{$subs} ) { - $seen_subs->{$sub} = [] unless exists $seen_subs->{$sub}; - unshift @{ $seen_subs->{$sub} }, $isa; - - # UNIVERSAL is not interesting, it is always present, - # but if any parents turn up with subs? Interested - $found_interesting++ unless 'UNIVERSAL' eq $isa; - } - } - return ( $found_interesting, $seen_subs ); -} - sub _extract_mro { my ($class) = @_; - ## no critic (ProhibitCallsToUnexportedSubs) - my (@isa) = @{ get_linear_isa($class) }; - - my ( $found_interesting, $seen_subs ) = _extract_subs(@isa); - - my $class_data = {}; - - # Group "seen subs" into class oriented structures, - # and classify them. - for my $sub ( keys %{$seen_subs} ) { - my @classes = @{ $seen_subs->{$sub} }; + my (@mro_order) = @{ get_linear_class_shadows($class) }; - for my $isa ( @{ $seen_subs->{$sub} } ) { - - # mark all subs both shadowing and shadowed until proven otherwise - $class_data->{$isa}->{$sub} = { shadowed => 1, shadowing => 1 }; + my $found_interesting = 0; + for my $isa_entry (@mro_order) { + + # Universal will always be present, but parents/children + # of UNIVERSAL are "interesting" + next if 'UNIVERSAL' eq $isa_entry->{class}; + next unless keys %{ $isa_entry->{subs} }; + $found_interesting++; + last; + } + for my $isa_entry (@mro_order) { + for my $sub ( keys %{ $isa_entry->{subs} } ) { + delete $isa_entry->{subs}->{$sub}->{ref}; } - - # mark top-most sub unshadowed - $class_data->{ $classes[0] }->{$sub}->{shadowed} = 0; - - # mark bottom-most sub unshadowing - $class_data->{ $classes[-1] }->{$sub}->{shadowing} = 0; - } - - # Order class structures by MRO order - my (@mro_order) = map { { class => $_, subs => $class_data->{$_} || {} } } @isa; - if ( not $found_interesting ) { # Huh, No inheritance, and no subs. K. diff --git a/lib/Devel/Isa/Explainer/_MRO.pm b/lib/Devel/Isa/Explainer/_MRO.pm index 0e07ed9..c0311bd 100644 --- a/lib/Devel/Isa/Explainer/_MRO.pm +++ b/lib/Devel/Isa/Explainer/_MRO.pm @@ -28,6 +28,7 @@ our @EXPORT_OK = qw( get_linear_isa get_package_sub get_package_subs + get_linear_class_shadows ); BEGIN { @@ -174,4 +175,53 @@ sub get_package_subs { $subs; } +=func get_linear_class_shadows + + my $arrayref = get_linear_class_shadows( $classname ) + +Combines C and C, +traversing the inheritance bottom up, computing shadowing +as it goes. + +Returns: + + $result = [ $hashref, $hashref, $hashref, ... ] + $hashrefref = { class => CLASSNAME, subs => $submap } + $submap = { SUBNAME => $subrecord, ... } + $subrecord = { shadowing => BOOLEAN, + shadowed => BOOLEAN, + ref => CODEREF, } + +=cut + +sub get_linear_class_shadows { + my ($class) = @_; + + # Contains the "image" made bottom up + # for comparison/detecting shadows. + my $methods = {}; + my @isa_out; + for my $package ( reverse @{ get_linear_isa($class) } ) { + my $subs = get_package_subs($package); + my $node = {}; + for my $subname ( keys %{$subs} ) { + + # first node is never shadowing + if ( not exists $methods->{$subname} ) { + $node->{$subname} = { shadowing => 0, shadowed => 0, ref => $subs->{$subname} }; + + # Contains a reference to the previous incarnation + # for later modification + $methods->{$subname} = $node->{$subname}; + next; + } + $node->{$subname} = { shadowing => 1, shadowed => 0, ref => $subs->{$subname} }; + $methods->{$subname}->{shadowed} = 1; # mark previous version shadowed + $methods->{$subname} = $node->{$subname}; # update current + } + unshift @isa_out, { class => $package, subs => $node }; + } + \@isa_out; +} + 1; diff --git a/t/internals/mro/04-get-linear-class-shadows.t b/t/internals/mro/04-get-linear-class-shadows.t new file mode 100644 index 0000000..1894a7e --- /dev/null +++ b/t/internals/mro/04-get-linear-class-shadows.t @@ -0,0 +1,73 @@ +use strict; +use warnings; + +use Test::More; +use Devel::Isa::Explainer::_MRO; +use Test::Differences qw( eq_or_diff ); + +my $expected_UNIVERSAL = Devel::Isa::Explainer::_MRO::get_package_subs('UNIVERSAL'); +for my $sub ( keys %{$expected_UNIVERSAL} ) { + $expected_UNIVERSAL->{$sub} = { + shadowed => 0, + shadowing => 0, + ref => $expected_UNIVERSAL->{$sub}, + }; +} + +@My::Example::A::ISA = ( 'My::Example::C', 'My::Example::B' ); +@My::Example::B::ISA = ('My::Example::C'); +@My::Example::C::ISA = ('My::Example::D'); +@My::Example::D::ISA = (); +sub My::Example::D::x_meth { 'd' } +sub My::Example::C::y_meth { 'c' } +sub My::Example::A::y_meth { 'a' } + +eq_or_diff( + Devel::Isa::Explainer::_MRO::get_linear_class_shadows('My::Example::A'), + [ + { class => 'My::Example::A', subs => { y_meth => { shadowed => 0, shadowing => 1, ref => \&My::Example::A::y_meth } } }, + { class => 'My::Example::C', subs => { y_meth => { shadowed => 1, shadowing => 0, ref => \&My::Example::C::y_meth } } }, + { class => 'My::Example::D', subs => { x_meth => { shadowed => 0, shadowing => 0, ref => \&My::Example::D::x_meth } } }, + { class => 'My::Example::B', subs => {} }, + { class => 'UNIVERSAL', subs => $expected_UNIVERSAL }, + ], + 'dfs lookup works' +); + +@My::Example::E::ISA = ( 'My::Example::F', 'My::Example::G' ); +@My::Example::F::ISA = ('My::Example::H'); +@My::Example::G::ISA = ('My::Example::H'); +@My::Example::H::ISA = (); +sub My::Example::H::x_meth { 'h' } +sub My::Example::G::y_meth { 'g' } +sub My::Example::E::y_meth { 'e' } + +eq_or_diff( + Devel::Isa::Explainer::_MRO::get_linear_class_shadows('My::Example::E'), + [ + { class => 'My::Example::E', subs => { y_meth => { shadowed => 0, shadowing => 1, ref => \&My::Example::E::y_meth } } }, + { class => 'My::Example::F', subs => {} }, + { class => 'My::Example::H', subs => { x_meth => { shadowed => 0, shadowing => 0, ref => \&My::Example::H::x_meth } } }, + { class => 'My::Example::G', subs => { y_meth => { shadowed => 1, shadowing => 0, ref => \&My::Example::G::y_meth } } }, + { class => 'UNIVERSAL', subs => $expected_UNIVERSAL }, + ], + 'dfs lookup works (v2)' +); + +use MRO::Compat; +mro::set_mro( "My::Example::E", "c3" ); + +eq_or_diff( + Devel::Isa::Explainer::_MRO::get_linear_class_shadows('My::Example::E'), + [ + { class => 'My::Example::E', subs => { y_meth => { shadowed => 0, shadowing => 1, ref => \&My::Example::E::y_meth } } }, + { class => 'My::Example::F', subs => {} }, + { class => 'My::Example::G', subs => { y_meth => { shadowed => 1, shadowing => 0, ref => \&My::Example::G::y_meth } } }, + { class => 'My::Example::H', subs => { x_meth => { shadowed => 0, shadowing => 0, ref => \&My::Example::H::x_meth } } }, + { class => 'UNIVERSAL', subs => $expected_UNIVERSAL }, + ], + 'c3 lookup works' +); + +done_testing; + From 44f5fdbfdc7e03b47e9cbd7ab99f5e63e3bb8f18 Mon Sep 17 00:00:00 2001 From: Kent Fredric Date: Sun, 26 Jun 2016 20:18:18 +1200 Subject: [PATCH 10/16] Add "Parent" data to internal data structure. --- Changes | 1 + lib/Devel/Isa/Explainer.pm | 3 ++- lib/Devel/Isa/Explainer/_MRO.pm | 38 +++++++++++++++++++++++++++++++++ 3 files changed, 41 insertions(+), 1 deletion(-) diff --git a/Changes b/Changes index 26015a0..5b2c4e3 100644 --- a/Changes +++ b/Changes @@ -22,6 +22,7 @@ Release history for Devel-Isa-Explainer [Internals] - Highligher functions now receive all sub metadata directly as a hash, instead of being called with a list of binary flags. + - Parents of classes now recorded in internal data structures, but not yet exposed. 0.002001 2016-05-19T14:07:12Z c167598 [Documentation] diff --git a/lib/Devel/Isa/Explainer.pm b/lib/Devel/Isa/Explainer.pm index 4764ef1..84abc25 100644 --- a/lib/Devel/Isa/Explainer.pm +++ b/lib/Devel/Isa/Explainer.pm @@ -14,7 +14,7 @@ use Exporter (); use Term::ANSIColor 3.00 ('colored'); # bright_ use Carp ('croak'); use MRO::Compat (); -use Devel::Isa::Explainer::_MRO qw( get_linear_class_shadows ); +use Devel::Isa::Explainer::_MRO qw( get_linear_class_shadows get_parents ); # Perl critic is broken. This is not a void context. @@ -233,6 +233,7 @@ sub _extract_mro { last; } for my $isa_entry (@mro_order) { + $isa_entry->{parents} = get_parents( $isa_entry->{class} ); for my $sub ( keys %{ $isa_entry->{subs} } ) { delete $isa_entry->{subs}->{$sub}->{ref}; } diff --git a/lib/Devel/Isa/Explainer/_MRO.pm b/lib/Devel/Isa/Explainer/_MRO.pm index c0311bd..9a41953 100644 --- a/lib/Devel/Isa/Explainer/_MRO.pm +++ b/lib/Devel/Isa/Explainer/_MRO.pm @@ -29,6 +29,7 @@ our @EXPORT_OK = qw( get_package_sub get_package_subs get_linear_class_shadows + get_parents ); BEGIN { @@ -224,4 +225,41 @@ sub get_linear_class_shadows { \@isa_out; } +=func get_parents + + my $parents = get_parents( $package ); + +This utility finds the effective "depth 1" parents of a given class. +That is, in normal conditions, it just returns the contents of C<@ISA> verbatim. + +However, if C<@ISA> is empty, it returns the effective parent, C +unless of course, the given class is a parent of C itself (insert drugs here) +at which point it will return an empty list. + +Because despite the fact a parent of C can call C methods, +reporting C<< UNIVERSAL->parent->parent == UNIVERSAL >> will of course create cycles +for anyone who touches it. + +=cut + +sub get_parents { + my ($package) = @_; + my $namespace = do { + no strict 'refs'; + \%{"${package}::"}; + }; + + if ( exists $namespace->{ISA} ) { + my $entry_ref = \$namespace->{ISA}; + if ( 'GLOB' eq reftype $entry_ref + and defined *{$entry_ref}{ARRAY} + and @{ *{$entry_ref}{ARRAY} } ) + { + return [ @{ *{$entry_ref}{ARRAY} } ]; + } + } + return [] if _mro_is_universal($package); + ['UNIVERSAL']; +} + 1; From 08aee41e6288e59ca0b6958713de8c071501f749 Mon Sep 17 00:00:00 2001 From: Kent Fredric Date: Sun, 26 Jun 2016 20:28:10 +1200 Subject: [PATCH 11/16] Record MRO type in internal data --- Changes | 1 + lib/Devel/Isa/Explainer.pm | 2 ++ 2 files changed, 3 insertions(+) diff --git a/Changes b/Changes index 5b2c4e3..d55befb 100644 --- a/Changes +++ b/Changes @@ -23,6 +23,7 @@ Release history for Devel-Isa-Explainer - Highligher functions now receive all sub metadata directly as a hash, instead of being called with a list of binary flags. - Parents of classes now recorded in internal data structures, but not yet exposed. + - MRO type of classes now recorded in internal data structures. 0.002001 2016-05-19T14:07:12Z c167598 [Documentation] diff --git a/lib/Devel/Isa/Explainer.pm b/lib/Devel/Isa/Explainer.pm index 84abc25..81b3368 100644 --- a/lib/Devel/Isa/Explainer.pm +++ b/lib/Devel/Isa/Explainer.pm @@ -234,6 +234,8 @@ sub _extract_mro { } for my $isa_entry (@mro_order) { $isa_entry->{parents} = get_parents( $isa_entry->{class} ); + ## no critic (Subroutines::ProhibitCallsToUnexportedSubs) + $isa_entry->{mro} = mro::get_mro( $isa_entry->{class} ); for my $sub ( keys %{ $isa_entry->{subs} } ) { delete $isa_entry->{subs}->{$sub}->{ref}; } From a77844e08fc7365ed139a3678dc9e508bb10f8cf Mon Sep 17 00:00:00 2001 From: Kent Fredric Date: Sun, 26 Jun 2016 21:02:23 +1200 Subject: [PATCH 12/16] Export XSUB, Constant, and stub sub metadata in internal sub records. --- Changes | 5 +++-- Makefile.PL | 2 +- lib/Devel/Isa/Explainer.pm | 19 +++++++++++++++-- misc/Changes.deps | 2 +- misc/Changes.deps.all | 2 +- t/02-shadowing.t | 6 +++--- t/internals/01-discover_xsub.t | 32 ++++++++++++++++++++++++++++ t/internals/03-discover-constant.t | 34 ++++++++++++++++++++++++++++++ 8 files changed, 92 insertions(+), 10 deletions(-) create mode 100644 t/internals/01-discover_xsub.t create mode 100644 t/internals/03-discover-constant.t diff --git a/Changes b/Changes index d55befb..261c271 100644 --- a/Changes +++ b/Changes @@ -12,8 +12,8 @@ Release history for Devel-Isa-Explainer [Dependencies::Stats] - Dependencies changed since 0.002001, see misc/*.deps* for details - - runtime: +1 -1 - - test: +2 + - runtime: +2 -1 + - test: +1 [Documentation] - Improve bin/isa-splain's documentation to be more helpful in places where `man isa-splain` might be expected to @@ -24,6 +24,7 @@ Release history for Devel-Isa-Explainer flags. - Parents of classes now recorded in internal data structures, but not yet exposed. - MRO type of classes now recorded in internal data structures. + - XSUB, Constant and stub-subs marked in internal data structures. 0.002001 2016-05-19T14:07:12Z c167598 [Documentation] diff --git a/Makefile.PL b/Makefile.PL index 0527fb3..add0328 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -20,6 +20,7 @@ my %WriteMakefileArgs = ( "MIN_PERL_VERSION" => "5.006", "NAME" => "Devel::Isa::Explainer", "PREREQ_PM" => { + "B" => 0, "Carp" => 0, "Exporter" => 0, "MRO::Compat" => 0, @@ -32,7 +33,6 @@ my %WriteMakefileArgs = ( "warnings" => 0 }, "TEST_REQUIRES" => { - "B" => 0, "ExtUtils::MakeMaker" => 0, "File::Spec" => 0, "Test::Builder" => 0, diff --git a/lib/Devel/Isa/Explainer.pm b/lib/Devel/Isa/Explainer.pm index 81b3368..b5e8579 100644 --- a/lib/Devel/Isa/Explainer.pm +++ b/lib/Devel/Isa/Explainer.pm @@ -12,8 +12,9 @@ our $VERSION = '0.002002'; use Exporter (); use Term::ANSIColor 3.00 ('colored'); # bright_ -use Carp ('croak'); +use Carp ('croak'); use MRO::Compat (); +use B ('svref_2object'); use Devel::Isa::Explainer::_MRO qw( get_linear_class_shadows get_parents ); @@ -21,6 +22,8 @@ use Devel::Isa::Explainer::_MRO qw( get_linear_class_shadows get_parents ); ## no critic (BuiltinFunctions::ProhibitVoidMap) use constant 1.03 ( { map { ( ( sprintf '_E%x', $_ ), ( sprintf ' (id: %s#%d)', __PACKAGE__, $_ ), ) } 1 .. 5 } ); +use constant _HAS_CONST => B::CV->can('CONST'); + use namespace::clean; BEGIN { *import = \&Exporter::import } ## no critic (ProhibitCallsToUnexportedSubs) @@ -237,7 +240,19 @@ sub _extract_mro { ## no critic (Subroutines::ProhibitCallsToUnexportedSubs) $isa_entry->{mro} = mro::get_mro( $isa_entry->{class} ); for my $sub ( keys %{ $isa_entry->{subs} } ) { - delete $isa_entry->{subs}->{$sub}->{ref}; + my $sub_data = $isa_entry->{subs}->{$sub}; + @{$sub_data}{ 'xsub', 'constant', 'stub' } = ( 0, 0, 0 ); + my $ref = delete $sub_data->{ref}; + my $cv = svref_2object($ref); + if ( _HAS_CONST ? $cv->CONST : ref $cv->XSUBANY ) { + $sub_data->{constant} = 1; + } + elsif ( $cv->XSUB ) { + $sub_data->{xsub} = 1; + } + elsif ( not defined &{$ref} ) { + $sub_data->{stub} = 1; + } } } if ( not $found_interesting ) { diff --git a/misc/Changes.deps b/misc/Changes.deps index 70728b5..06f2a48 100644 --- a/misc/Changes.deps +++ b/misc/Changes.deps @@ -2,10 +2,10 @@ This file contains changes in REQUIRED dependencies for standard CPAN phases (co 0.002002 [Added / runtime requires] + - B - Scalar::Util [Added / test requires] - - B - Test::Differences [Removed / runtime requires] diff --git a/misc/Changes.deps.all b/misc/Changes.deps.all index 9a2eccc..54b61a0 100644 --- a/misc/Changes.deps.all +++ b/misc/Changes.deps.all @@ -2,10 +2,10 @@ This file contains ALL changes in dependencies in both REQUIRED / OPTIONAL depen 0.002002 [Added / runtime requires] + - B - Scalar::Util [Added / test requires] - - B - Test::Differences [Removed / runtime requires] diff --git a/t/02-shadowing.t b/t/02-shadowing.t index ea2e9b1..3fea72a 100644 --- a/t/02-shadowing.t +++ b/t/02-shadowing.t @@ -68,17 +68,17 @@ is( scalar keys %{ $mro->[2]->{subs} }, 3, "base class has 3 subs" ); is_deeply( $mro->[0]->{subs}->{three_layer_shadow}, - { shadowing => 1, shadowed => 0 }, + { shadowing => 1, shadowed => 0, xsub => 0, constant => 0, stub => 0 }, "three layer shadow top layer shadowing but not shadowed" ); is_deeply( $mro->[1]->{subs}->{three_layer_shadow}, - { shadowing => 1, shadowed => 1 }, + { shadowing => 1, shadowed => 1, xsub => 0, constant => 0, stub => 0 }, "three layer shadow middle layer shadowing and shadowed" ); is_deeply( $mro->[2]->{subs}->{three_layer_shadow}, - { shadowing => 0, shadowed => 1 }, + { shadowing => 0, shadowed => 1, xsub => 0, constant => 0, stub => 0 }, "three layer shadow bottom layer shadowed but not shadowing" ); diff --git a/t/internals/01-discover_xsub.t b/t/internals/01-discover_xsub.t new file mode 100644 index 0000000..672ed39 --- /dev/null +++ b/t/internals/01-discover_xsub.t @@ -0,0 +1,32 @@ +use strict; +use warnings; + +use Test::More; +use B (); + +use Devel::Isa::Explainer (); + +*extract_mro = \&Devel::Isa::Explainer::_extract_mro; +{ + my $mro = extract_mro("B"); + my $fail = 0; + for my $class ( @{$mro} ) { + next unless $class->{class} eq 'B'; + $fail = 1 unless ok( exists $class->{subs}->{'svref_2object'}, "svref_2object discovered in class" ); + $fail = 1 unless ok( $class->{subs}->{'svref_2object'}->{xsub}, "svref_2object is an XSUB" ); + } + diag explain $mro if $fail; + +} +{ + my $mro = extract_mro("Devel::Isa::Explainer"); + my $fail = 0; + for my $class ( @{$mro} ) { + next unless $class->{class} eq 'Devel::Isa::Explainer'; + $fail = 1 unless ok( exists $class->{subs}->{'explain_isa'}, "explain_isa discovered in class" ); + $fail = 1 unless ok( !$class->{subs}->{'explain_isa'}->{xsub}, "explain_isa is NOT an XSUB" ); + } + diag explain $mro if $fail; +} + +done_testing; diff --git a/t/internals/03-discover-constant.t b/t/internals/03-discover-constant.t new file mode 100644 index 0000000..40811db --- /dev/null +++ b/t/internals/03-discover-constant.t @@ -0,0 +1,34 @@ +use strict; +use warnings; + +use Test::More; +{ + package My::Test; + sub constant_sub() { 'Hello' } +} +use Devel::Isa::Explainer (); + +*extract_mro = \&Devel::Isa::Explainer::_extract_mro; +{ + my $mro = extract_mro("My::Test"); + my $fail = 0; + for my $class ( @{$mro} ) { + next unless $class->{class} eq 'My::Test'; + $fail = 1 unless ok( exists $class->{subs}->{'constant_sub'}, "constant_sub discovered in class" ); + $fail = 1 unless ok( $class->{subs}->{'constant_sub'}->{constant}, "constant_sub is a constant sub" ); + } + diag explain $mro if $fail; + +} +{ + my $mro = extract_mro("Devel::Isa::Explainer"); + my $fail = 0; + for my $class ( @{$mro} ) { + next unless $class->{class} eq 'Devel::Isa::Explainer'; + $fail = 1 unless ok( exists $class->{subs}->{'explain_isa'}, "explain_isa discovered in class" ); + $fail = 1 unless ok( !$class->{subs}->{'explain_isa'}->{constant}, "explain_isa is NOT a constant sub" ); + } + diag explain $mro if $fail; +} + +done_testing; From 74d1604c00cfc0d0ae90ea3991113e5a0b1e326f Mon Sep 17 00:00:00 2001 From: Kent Fredric Date: Wed, 8 Jun 2016 09:43:43 +1200 Subject: [PATCH 13/16] Add --help and --version. Closes #9 --- Changes | 1 + lib/App/Isa/Splain.pm | 34 ++++++++++++++++++++++++++++++++-- 2 files changed, 33 insertions(+), 2 deletions(-) diff --git a/Changes b/Changes index 261c271..95e4c2f 100644 --- a/Changes +++ b/Changes @@ -9,6 +9,7 @@ Release history for Devel-Isa-Explainer - deduplicating subs now entirely removed, subs that are actually there in the package must always be displayed as they are either injected by roles or importing, and can actually end up calling themselves under inheritance. ( This however is highly prone to explosions because MRO core sucks ) ( Related to #10 ) + - isa-splain now supports --help and --version ( Closes #9 ) [Dependencies::Stats] - Dependencies changed since 0.002001, see misc/*.deps* for details diff --git a/lib/App/Isa/Splain.pm b/lib/App/Isa/Splain.pm index ea9d232..e482f38 100644 --- a/lib/App/Isa/Splain.pm +++ b/lib/App/Isa/Splain.pm @@ -61,9 +61,18 @@ sub new_from_ARGV { push @load_modules, $1; next; } - croak 'Unexpected argument ' . $argument . _E3; + ## no critic (RequireCheckedSyscalls) + if( '--help' eq $argument) { + print _help(); + exit; + } + if( '--version' eq $argument ) { + print _version(); + exit; + } + croak 'Unexpected argument ' . $argument . _E3 . qq[\nSee $0 --help for more information]; } - defined $module or croak 'Expected a module name, got none' . _E1; + defined $module or croak 'Expected a module name, got none' . _E1 . qq[\nSee $0 --help for more information]; return $_[0]->new( module => $module, load_modules => [ @load_modules ? @load_modules : $module ] ); } @@ -86,6 +95,27 @@ sub run { return 0; } +sub _help { + return <<"EOF"; +Usage: $0 [OPTIONS] MODNAME +Load and inspect MODNAME's ISA Inheritance. + +OPTIONS: + -MLoad::Module - Load "Load::Module" instead of MODNAME ( May be + specified multiple times ) + + --help - Show this help and exit + --version - Show version and exit +EOF +} + +sub _version { + my $pkg = __PACKAGE__; + return <<"EOF"; +$0 ($pkg) $VERSION +EOF +} + 1; =head1 SYNOPSIS From 2cdc6cad6bdaf52d5ebef3e1093c2deeffedfed2 Mon Sep 17 00:00:00 2001 From: Kent Fredric Date: Sun, 26 Jun 2016 22:13:16 +1200 Subject: [PATCH 14/16] Add get-linear-method-map and get-linear-class-map --- lib/Devel/Isa/Explainer/_MRO.pm | 40 +++++++++ t/internals/mro/05-get-linear-method-map.t | 97 ++++++++++++++++++++++ t/internals/mro/06-get-linear-class-map.t | 65 +++++++++++++++ t/internals/mro/07-hostile-method-maps.t | 80 ++++++++++++++++++ 4 files changed, 282 insertions(+) create mode 100644 t/internals/mro/05-get-linear-method-map.t create mode 100644 t/internals/mro/06-get-linear-class-map.t create mode 100644 t/internals/mro/07-hostile-method-maps.t diff --git a/lib/Devel/Isa/Explainer/_MRO.pm b/lib/Devel/Isa/Explainer/_MRO.pm index 9a41953..79f703d 100644 --- a/lib/Devel/Isa/Explainer/_MRO.pm +++ b/lib/Devel/Isa/Explainer/_MRO.pm @@ -30,6 +30,8 @@ our @EXPORT_OK = qw( get_package_subs get_linear_class_shadows get_parents + get_linear_method_map + get_linear_class_map ); BEGIN { @@ -262,4 +264,42 @@ sub get_parents { ['UNIVERSAL']; } +=func get_linear_method_map + + my $arrayref = get_linear_method_map( $classname, $method ) + +Returns an C describing the vertical stack of a given method. + +C levels without defined C are represented as C + + $result = [ $arrayref, $arrayref, $arrayref, ... ] + $arrayref = [ CLASSNAME, undef / CODEREF ] + +=cut + +sub get_linear_method_map { + my ( $class, $method ) = @_; + return [ map { [ $_, get_package_sub( $_, $method ) ] } @{ get_linear_isa($class) } ]; +} + +=func get_linear_class_map + + my $arrayref = get_linear_class_map( $classname ) + +Returns C stashes for all packages in C<$classname>'s inheritance (including Cs) +in method-resolution-order. + +Returns: + + $result = [ $arrayref, $arrayref, $arrayref, ... ] + $arrayref = [ CLASSNAME, $submap ] + $submap = { SUBNAME => CODEREF, ... } + +=cut + +sub get_linear_class_map { + my ($class) = @_; + [ map { [ $_, get_package_subs($_) ] } @{ get_linear_isa($class) } ]; +} + 1; diff --git a/t/internals/mro/05-get-linear-method-map.t b/t/internals/mro/05-get-linear-method-map.t new file mode 100644 index 0000000..9f41647 --- /dev/null +++ b/t/internals/mro/05-get-linear-method-map.t @@ -0,0 +1,97 @@ +use strict; +use warnings; + +use Test::More; +use Devel::Isa::Explainer::_MRO; +use Test::Differences qw( eq_or_diff ); + +@My::Example::A::ISA = ( 'My::Example::C', 'My::Example::B' ); +@My::Example::B::ISA = ('My::Example::C'); +@My::Example::C::ISA = ('My::Example::D'); +@My::Example::D::ISA = (); +sub My::Example::D::x_meth { 'd' } +sub My::Example::C::y_meth { 'c' } +sub My::Example::A::y_meth { 'a' } + +eq_or_diff( + Devel::Isa::Explainer::_MRO::get_linear_method_map( 'My::Example::A', 'y_meth' ), + [ + [ 'My::Example::A', \&My::Example::A::y_meth ], + [ 'My::Example::C', \&My::Example::C::y_meth ], + [ 'My::Example::D', undef ], + [ 'My::Example::B', undef ], + [ 'UNIVERSAL', undef ], + ], + 'dfs lookup works for y_meth' +); +eq_or_diff( + Devel::Isa::Explainer::_MRO::get_linear_method_map( 'My::Example::A', 'x_meth' ), + [ + [ 'My::Example::A', undef ], + [ 'My::Example::C', undef ], + [ 'My::Example::D', \&My::Example::D::x_meth ], + [ 'My::Example::B', undef ], + [ 'UNIVERSAL', undef ], + ], + 'dfs lookup works for x_meth' +); + +@My::Example::E::ISA = ( 'My::Example::F', 'My::Example::G' ); +@My::Example::F::ISA = ('My::Example::H'); +@My::Example::G::ISA = ('My::Example::H'); +@My::Example::H::ISA = (); +sub My::Example::H::x_meth { 'h' } +sub My::Example::G::y_meth { 'g' } +sub My::Example::E::y_meth { 'e' } + +eq_or_diff( + Devel::Isa::Explainer::_MRO::get_linear_method_map( 'My::Example::E', 'y_meth' ), + [ + [ 'My::Example::E', \&My::Example::E::y_meth ], + [ 'My::Example::F', undef ], + [ 'My::Example::H', undef ], + [ 'My::Example::G', \&My::Example::G::y_meth ], + [ 'UNIVERSAL', undef ], + ], + 'dfs lookup works for y_meth (v2)' +); +eq_or_diff( + Devel::Isa::Explainer::_MRO::get_linear_method_map( 'My::Example::E', 'x_meth' ), + [ + [ 'My::Example::E', undef ], + [ 'My::Example::F', undef ], + [ 'My::Example::H', \&My::Example::H::x_meth ], + [ 'My::Example::G', undef ], + [ 'UNIVERSAL', undef ], + ], + 'dfs lookup works for x_meth (v2)' +); + +use MRO::Compat; +mro::set_mro( "My::Example::E", "c3" ); + +eq_or_diff( + Devel::Isa::Explainer::_MRO::get_linear_method_map( 'My::Example::E', 'y_meth' ), + [ + [ 'My::Example::E', \&My::Example::E::y_meth ], + [ 'My::Example::F', undef ], + [ 'My::Example::G', \&My::Example::G::y_meth ], + [ 'My::Example::H', undef ], + [ 'UNIVERSAL', undef ], + ], + 'c3 lookup works for y_meth' +); +eq_or_diff( + Devel::Isa::Explainer::_MRO::get_linear_method_map( 'My::Example::E', 'x_meth' ), + [ + [ 'My::Example::E', undef ], + [ 'My::Example::F', undef ], + [ 'My::Example::G', undef ], + [ 'My::Example::H', \&My::Example::H::x_meth ], + [ 'UNIVERSAL', undef ], + ], + 'c3 lookup works for x_meth' +); + +done_testing; + diff --git a/t/internals/mro/06-get-linear-class-map.t b/t/internals/mro/06-get-linear-class-map.t new file mode 100644 index 0000000..305214e --- /dev/null +++ b/t/internals/mro/06-get-linear-class-map.t @@ -0,0 +1,65 @@ +use strict; +use warnings; + +use Test::More; +use Devel::Isa::Explainer::_MRO; +use Test::Differences qw( eq_or_diff ); + +@My::Example::A::ISA = ( 'My::Example::C', 'My::Example::B' ); +@My::Example::B::ISA = ('My::Example::C'); +@My::Example::C::ISA = ('My::Example::D'); +@My::Example::D::ISA = (); +sub My::Example::D::x_meth { 'd' } +sub My::Example::C::y_meth { 'c' } +sub My::Example::A::y_meth { 'a' } + +eq_or_diff( + Devel::Isa::Explainer::_MRO::get_linear_class_map('My::Example::A'), + [ + [ 'My::Example::A', { y_meth => \&My::Example::A::y_meth } ], + [ 'My::Example::C', { y_meth => \&My::Example::C::y_meth } ], + [ 'My::Example::D', { x_meth => \&My::Example::D::x_meth } ], + [ 'My::Example::B', {} ], + [ 'UNIVERSAL', Devel::Isa::Explainer::_MRO::get_package_subs('UNIVERSAL') ], + ], + 'dfs lookup works' +); + +@My::Example::E::ISA = ( 'My::Example::F', 'My::Example::G' ); +@My::Example::F::ISA = ('My::Example::H'); +@My::Example::G::ISA = ('My::Example::H'); +@My::Example::H::ISA = (); +sub My::Example::H::x_meth { 'h' } +sub My::Example::G::y_meth { 'g' } +sub My::Example::E::y_meth { 'e' } + +eq_or_diff( + Devel::Isa::Explainer::_MRO::get_linear_class_map('My::Example::E'), + [ + [ 'My::Example::E', { y_meth => \&My::Example::E::y_meth } ], + [ 'My::Example::F', {} ], + [ 'My::Example::H', { x_meth => \&My::Example::H::x_meth } ], + [ 'My::Example::G', { y_meth => \&My::Example::G::y_meth } ], + [ 'UNIVERSAL', Devel::Isa::Explainer::_MRO::get_package_subs('UNIVERSAL') ] + ], + 'dfs lookup works (v2)' +); + +use MRO::Compat; +mro::set_mro( "My::Example::E", "c3" ); + +eq_or_diff( + Devel::Isa::Explainer::_MRO::get_linear_class_map('My::Example::E'), + [ + [ 'My::Example::E', { y_meth => \&My::Example::E::y_meth } ], + [ 'My::Example::F', {} ], + [ 'My::Example::G', { y_meth => \&My::Example::G::y_meth } ], + [ 'My::Example::H', { x_meth => \&My::Example::H::x_meth } ], + [ 'UNIVERSAL', Devel::Isa::Explainer::_MRO::get_package_subs('UNIVERSAL') ] + + ], + 'c3 lookup works' +); + +done_testing; + diff --git a/t/internals/mro/07-hostile-method-maps.t b/t/internals/mro/07-hostile-method-maps.t new file mode 100644 index 0000000..2cc0b95 --- /dev/null +++ b/t/internals/mro/07-hostile-method-maps.t @@ -0,0 +1,80 @@ +use strict; +use warnings; + +use Test::More; +use Test::Differences qw( eq_or_diff ); +use MRO::Compat qw(); + +# DFS shadow stack +@Foo::ISA = ('Foo::Parent'); +@Foo::Parent::ISA = ('Foo::Grandparent'); +@Foo::Grandparent::ISA = ('Foo::GreatGrandparent'); + +sub Foo::GreatGrandparent::meth { } +sub Foo::Grandparent::meth { } +sub Foo::Parent::meth { } + +BEGIN { + *Foo::meth = *Foo::meth = \&Foo::Grandparent::meth; +} + +use Devel::Isa::Explainer::_MRO qw(get_linear_method_map); +{ + my $methods = get_linear_method_map( 'Foo', 'meth' ); + + eq_or_diff( + [ map { [ $_->[0], defined $_->[1] ? 1 : 0 ] } @{$methods} ], # + [ # + [ 'Foo', 1 ], + [ 'Foo::Parent', 1 ], + [ 'Foo::Grandparent', 1 ], + [ 'Foo::GreatGrandparent', 1 ], # + [ 'UNIVERSAL', 0 ], + ], # + 'Prelinearised isa with subs at every level show' + ); +} +{ + my $methods = get_linear_method_map( 'Foo', 'can' ); + + eq_or_diff( + [ map { [ $_->[0], defined $_->[1] ? 1 : 0 ] } @{$methods} ], # + [ # + [ 'Foo', 0 ], + [ 'Foo::Parent', 0 ], + [ 'Foo::Grandparent', 0 ], + [ 'Foo::GreatGrandparent', 0 ], # + [ 'UNIVERSAL', 1 ], + ], # + 'can is only found in universal in a prelinearised graph' + ); +} + +# C3 Torture case +@Consumer::ISA = ( 'SomeParentClass', 'AnotherParentClass' ); +@SomeParentClass::ISA = ('BaseOfBases'); +@AnotherParentClass::ISA = ('BaseOfBases'); +@BaseOfBases::ISA = (); + +sub AnotherParentClass::meth { 1 } +sub BaseOfBases::meth { 0 } + +mro::set_mro( 'Consumer', 'c3' ); + +{ + my $methods = get_linear_method_map( 'Consumer', 'meth' ); + + eq_or_diff( + [ map { [ $_->[0], defined $_->[1] ? 1 : 0 ] } @{$methods} ], # + [ # + [ 'Consumer', 0 ], + [ 'SomeParentClass', 0 ], + [ 'AnotherParentClass', 1 ], + [ 'BaseOfBases', 1 ], # + [ 'UNIVERSAL', 0 ], + ], + 'C3 MRO + Confusing graph reports only subs where they should be' # + ); +} +done_testing; + From 69d89b5aa0e01c942aa79e51f901048028707c12 Mon Sep 17 00:00:00 2001 From: Kent Fredric Date: Mon, 27 Jun 2016 06:09:22 +1200 Subject: [PATCH 15/16] Add class-flattening util --- lib/Devel/Isa/Explainer/_MRO.pm | 36 ++++++++ t/internals/mro/08-get-flattened-class.t | 103 +++++++++++++++++++++++ 2 files changed, 139 insertions(+) create mode 100644 t/internals/mro/08-get-flattened-class.t diff --git a/lib/Devel/Isa/Explainer/_MRO.pm b/lib/Devel/Isa/Explainer/_MRO.pm index 79f703d..bef45af 100644 --- a/lib/Devel/Isa/Explainer/_MRO.pm +++ b/lib/Devel/Isa/Explainer/_MRO.pm @@ -32,6 +32,7 @@ our @EXPORT_OK = qw( get_parents get_linear_method_map get_linear_class_map + get_flattened_class ); BEGIN { @@ -302,4 +303,39 @@ sub get_linear_class_map { [ map { [ $_, get_package_subs($_) ] } @{ get_linear_isa($class) } ]; } +=func get_flattened_class + + my $hashref = get_flattened_class( $class_name ); + +Returns a fully expanded "Flat" representation of a classes hierarchy, +with still enough data present to trace method resolution. + +Returns: + + $result = { SUBNAME => $entry, ... } + $entry = { ref => CODEREF, + via => CLASSNAME, + parents => $parentrefs, } + + $parentrefs = [ $parentref_entry, ... ] + $parentref_entry = [ CLASSNAME, CODEREF ] + +=cut + +sub get_flattened_class { + my ($class) = @_; + my $methods = {}; + for my $package ( reverse @{ get_linear_isa($class) } ) { + my $subs = get_package_subs($package); + for my $subname ( keys %{$subs} ) { + $methods->{$subname}->{parents} ||= []; + unshift @{ $methods->{$subname}->{parents} }, [ $methods->{$subname}->{via}, $methods->{$subname}->{ref} ] + if exists $methods->{$subname}->{ref}; + $methods->{$subname}->{ref} = $subs->{$subname}; + $methods->{$subname}->{via} = $package; + } + } + $methods; +} + 1; diff --git a/t/internals/mro/08-get-flattened-class.t b/t/internals/mro/08-get-flattened-class.t new file mode 100644 index 0000000..fdfddb6 --- /dev/null +++ b/t/internals/mro/08-get-flattened-class.t @@ -0,0 +1,103 @@ +use strict; +use warnings; + +use Test::More; +use Devel::Isa::Explainer::_MRO; +use Test::Differences qw( eq_or_diff ); + +sub deq_diff { + + # Make Test::Differences deeply compare subs. + + local $Data::Dumper::Deparse = 1; + local $Test::Builder::Level = $Test::Builder::Level + 1; + eq_or_diff(@_); +} + +my $unikeys = Devel::Isa::Explainer::_MRO::get_package_subs('UNIVERSAL'); +my $unihash = {}; +{ + for my $key ( keys %{$unikeys} ) { + $unihash->{$key} = { + parents => [], + ref => $unikeys->{$key}, + via => 'UNIVERSAL', + }; + } +} + +@My::Example::A::ISA = ( 'My::Example::C', 'My::Example::B' ); +@My::Example::B::ISA = ('My::Example::C'); +@My::Example::C::ISA = ('My::Example::D'); +@My::Example::D::ISA = (); +sub My::Example::D::x_meth { 'd' } +sub My::Example::C::y_meth { 'c' } +sub My::Example::A::y_meth { 'a' } + +deq_diff( + Devel::Isa::Explainer::_MRO::get_flattened_class('My::Example::A'), + { + y_meth => { + ref => \&My::Example::A::y_meth, + via => 'My::Example::A', + parents => [ [ 'My::Example::C' => \&My::Example::C::y_meth ] ], + }, + x_meth => { + ref => \&My::Example::D::x_meth, + via => 'My::Example::D', + parents => [], + }, + %{$unihash}, + }, + 'dfs lookup works' +); +@My::Example::E::ISA = ( 'My::Example::F', 'My::Example::G' ); +@My::Example::F::ISA = ('My::Example::H'); +@My::Example::G::ISA = ('My::Example::H'); +@My::Example::H::ISA = (); +sub My::Example::H::x_meth { 'h' } +sub My::Example::G::x_meth { 'g' } +sub My::Example::G::y_meth { 'g' } +sub My::Example::E::y_meth { 'e' } + +deq_diff( + Devel::Isa::Explainer::_MRO::get_flattened_class('My::Example::E'), + { + y_meth => { + ref => \&My::Example::E::y_meth, + via => 'My::Example::E', + parents => [ [ 'My::Example::G' => \&My::Example::G::y_meth ] ], + }, + x_meth => { + ref => \&My::Example::H::x_meth, + via => 'My::Example::H', + parents => [ [ 'My::Example::G' => \&My::Example::G::x_meth ] ], + }, + %{$unihash}, + }, + 'dfs lookup works (v2)' +); + +use MRO::Compat; +mro::set_mro( "My::Example::E", "c3" ); + +deq_diff( + Devel::Isa::Explainer::_MRO::get_flattened_class('My::Example::E'), + { + y_meth => { + ref => \&My::Example::E::y_meth, + via => 'My::Example::E', + parents => [ [ 'My::Example::G' => \&My::Example::G::y_meth ] ], + }, + x_meth => { + ref => \&My::Example::G::x_meth, + via => 'My::Example::G', + parents => [ [ 'My::Example::H' => \&My::Example::H::x_meth ] ], + }, + %{$unihash} + }, + 'c3 lookup works' +); + +done_testing; + From 7405ed09d2e6d1ee7abe61a14c9f8c8e7fa909f3 Mon Sep 17 00:00:00 2001 From: Kent Fredric Date: Mon, 27 Jun 2016 07:35:43 +1200 Subject: [PATCH 16/16] Set V=0.002900 --- Makefile.PL | 2 +- README.mkdn | 2 +- lib/Devel/Isa/Explainer.pm | 2 +- misc/Changes.deps | 2 +- misc/Changes.deps.all | 2 +- misc/Changes.deps.dev | 2 +- misc/Changes.deps.opt | 2 +- 7 files changed, 7 insertions(+), 7 deletions(-) diff --git a/Makefile.PL b/Makefile.PL index add0328..680d98f 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -39,7 +39,7 @@ my %WriteMakefileArgs = ( "Test::Differences" => 0, "Test::More" => "0.89" }, - "VERSION" => "0.002002", + "VERSION" => "0.002900", "test" => { "TESTS" => "t/*.t t/00-compile/*.t t/cli/*.t t/internals/*.t t/internals/mro/*.t" } diff --git a/README.mkdn b/README.mkdn index fce9e4d..3cba45f 100644 --- a/README.mkdn +++ b/README.mkdn @@ -4,7 +4,7 @@ Devel::Isa::Explainer - Pretty Print Hierarchies of Subs in Packages # VERSION -version 0.002002 +version 0.002900 # SYNOPSIS diff --git a/lib/Devel/Isa/Explainer.pm b/lib/Devel/Isa/Explainer.pm index b5e8579..082a1b6 100644 --- a/lib/Devel/Isa/Explainer.pm +++ b/lib/Devel/Isa/Explainer.pm @@ -4,7 +4,7 @@ use warnings; package Devel::Isa::Explainer; -our $VERSION = '0.002002'; +our $VERSION = '0.002900'; # ABSTRACT: Pretty Print Hierarchies of Subs in Packages diff --git a/misc/Changes.deps b/misc/Changes.deps index 06f2a48..3eb4990 100644 --- a/misc/Changes.deps +++ b/misc/Changes.deps @@ -1,6 +1,6 @@ This file contains changes in REQUIRED dependencies for standard CPAN phases (configure/build/runtime/test) -0.002002 +0.002900 [Added / runtime requires] - B - Scalar::Util diff --git a/misc/Changes.deps.all b/misc/Changes.deps.all index 54b61a0..18fd653 100644 --- a/misc/Changes.deps.all +++ b/misc/Changes.deps.all @@ -1,6 +1,6 @@ This file contains ALL changes in dependencies in both REQUIRED / OPTIONAL dependencies for all phases (configure/build/runtime/test/develop) -0.002002 +0.002900 [Added / runtime requires] - B - Scalar::Util diff --git a/misc/Changes.deps.dev b/misc/Changes.deps.dev index 41cb749..c49ca5f 100644 --- a/misc/Changes.deps.dev +++ b/misc/Changes.deps.dev @@ -1,6 +1,6 @@ This file contains changes to DEVELOPMENT dependencies only ( both REQUIRED and OPTIONAL ) -0.002002 +0.002900 0.002001 2016-05-19T14:07:12Z diff --git a/misc/Changes.deps.opt b/misc/Changes.deps.opt index 0cca7cd..0953efb 100644 --- a/misc/Changes.deps.opt +++ b/misc/Changes.deps.opt @@ -1,6 +1,6 @@ This file contains changes in OPTIONAL dependencies for standard CPAN phases (configure/build/runtime/test) -0.002002 +0.002900 0.002001 2016-05-19T14:07:12Z