From c60a04f530fecad3068d940975985a9303e75106 Mon Sep 17 00:00:00 2001 From: Oliver Gorwits Date: Thu, 19 Jun 2014 15:46:42 +0100 Subject: [PATCH] Add method resolution discovery in SNMP::Info::MRO helper module --- Info/MRO.pm | 380 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 380 insertions(+) create mode 100644 Info/MRO.pm diff --git a/Info/MRO.pm b/Info/MRO.pm new file mode 100644 index 00000000..64ae6f1a --- /dev/null +++ b/Info/MRO.pm @@ -0,0 +1,380 @@ +package SNMP::Info::MRO; + +use warnings; +use strict; + +use PPI; +use Class::ISA; +use Module::Info; +use Module::Load (); +# use Data::Printer; + +sub _walk_global_data { + my $self = shift; + my $class = (ref $self ? ref $self : $self); + + my $ppi = PPI::Document->new( file($class) ); + my $name = shift or die "name (e.g. GLOBALS) required"; + my $results = shift || {}; + my $subref = \&_walk_global_data; + + # get the hash declaration + my $declaration = $ppi->find_first(sub { + my ($doc, $tok) = @_; + return ($tok->isa('PPI::Token::Symbol') + and $tok->symbol eq "\%$name"); + }); + + # get the hash content + my $content = $declaration->snext_sibling->snext_sibling; + + # get relevant tokens in the hash content + my @tokens = $content->find(sub { + my ($doc, $tok) = @_; + return ($tok->isa('PPI::Token::Symbol') + or $tok->isa('PPI::Token::Quote')); + }); + + return $results unless scalar @tokens and ref $tokens[0] eq ref []; + @tokens = @{ $tokens[0] }; + + # walk tokens and build final result + while (my $tok = splice(@tokens, 0, 1)) { + if ($tok->isa('PPI::Token::Quote')) { + my $token = $tok->string; + my $leaf = splice(@tokens, 0, 1); + my $extract = (($leaf =~ m/^&/) ? 'symbol' : 'string'); + + unshift @{ $results->{$token} }, + { $class => $leaf->$extract } + # we can sometimes see the same package twice + unless scalar grep { $_ eq $class } + map { keys %{ $_ } } + @{ $results->{$token} }; + } + elsif ($tok->isa('PPI::Token::Symbol')) { + # recurse to get the results of the mentioned package + (my $otherpkg = $tok->symbol) =~ s/^\%(.+)::$name$/$1/; + $results = $subref->($otherpkg, $name, $results); + } + } + + return $results; +} + +sub _print_global_data { + my $results = _walk_global_data(@_); + + foreach my $key (sort keys %$results) { + print $key, "\n"; + my @defs = @{ $results->{$key} }; + + my $first = 0; + while (my $classdef = splice(@defs, 0, 1)) { + my ($class) = keys %$classdef; + my ($meth) = values %$classdef; + + if ($first) { + printf " %s ( %s )\n", $meth, $class; + } + else { + printf " `-- %s ( %s )\n", $meth, $class; + $first = 1; + } + } + } +} + +=head1 NAME + +SNMP::Info::MRO - Method resolution introspection for SNMP::Info + +=head1 DESCRIPTION + +This is a set of helpers to show where a given method in SNMP::Info has been +implemented, and which implementation is being used at runtime. + +The following distributions are I to run this code: + +=over 4 + +=item * + +PPI + +=item * + +Class::ISA + +=item * + +Module::Info + +=item * + +Module::Load + +=back + +=head1 FUNCTIONS + +None of the functions are exported. For all helper functions, you can pass +either the name of a Perl module, or an object instance of SNMP::Info. + +=over 4 + +=item all_methods( $module ) + +Returns the set of methods defined in C<$module> and all its ancestor +classes (superclasses), either as Perl subroutines or via C<%GLOBALS> +and C<%MUNGE> configuration. The data structure looks like: + + { + method_name => [ + 'Package::Name', + 'Other::Package::Name', + ], + other_method_name => [ + 'Package::Name', + ], + } + +If a method has been defined as a Perl subroutine, you'll see the list of +classes where this was done, with the package used at runtime being first. +If the method is created via C<%GLOBALS> or C<%MUNGE> then in a similar way +you'll see the list of modules where this was done. However if a method +is defined I ways, then only the Perl subroutine definitions are shown. +Therefore, the defining class or module at runtime is always: + + $data->{method_name}->[0]; + +=cut + +sub all_methods { + my $self = shift; + my $class = (ref $self ? ref $self : $self); + + my $results = subroutines( $class ); + + my $globals = globals( $class ); + foreach my $key (keys %$globals) { + next if exists $results->{$key}; + $results->{$key} = [ map { keys %$_ } @{ $globals->{$key} } ]; + } + + my $funcs = funcs( $class ); + foreach my $key (keys %$funcs) { + next if exists $results->{$key}; + $results->{$key} = [ map { keys %$_ } @{ $funcs->{$key} } ]; + } + + return $results; +} + +=item subroutines( $module ) + +Returns the set of subroutines defined in C<$module> and all its ancestor +classes (superclasses). The data structure looks like: + + { + method_name => [ + 'Package::Name', + 'Other::Package::Name', + ], + other_method_name => [ + 'Package::Name', + ], + } + +Should a subroutine have been defined more than once, +the defining classes are listed in reverse order, such that the definition +used at runtime is always: + + $data->{method_name}->[0]; + +=cut + +sub subroutines { + my $self = shift; + my $class = (ref $self ? ref $self : $self); + my $results = {}; + + my @super = superclasses($class); + foreach my $parent (reverse @super) { + my %sh = Module::Info->new_from_module( $parent )->subroutines; + my @subs = grep { $_ !~ m/^_/ } + map { $_ =~ s/^.+:://; $_ } + keys %sh; + + foreach my $sub (@subs) { + unshift @{ $results->{$sub} }, $parent; + } + } + + return $results; +} + +=item globals( $module || $object ) + +Returns a data structure showing how L will resolve MIB Leaf +Nodes configured through the C<%GLOBALS> hashes in C<$module>. + +The data structure looks like: + + { + method_name => [ + { Package::Name => 'mib_leaf_name' }, + { Other::Package::Name => '1.3.6.1.4.1.9.2.1.58.0' }, + ], + other_method_name => [ + { Package::Name => 'mib_leaf.0' }, + ], + } + +Where a method has been defined in different packages, then they are listed in +reverse order, such that the mapping used by SNMP::Info is always: + + $data->{method_name}->[0]; + +=cut + +sub globals { _walk_global_data(shift, 'GLOBALS') } + +=item funcs( $module || $object ) + +Returns a data structure showing how L will resolve MIB Tables +configured through the C<%FUNCS> hashes in C<$module>. + +See L for further detail. + +=cut + +sub funcs { _walk_global_data(shift, 'FUNCS') } + +=item munge( $module || $object ) + +Returns a data structure showing the subroutines used for munging returned +values for any method defined in C<%FUNCS> or C<%GLOBALS>. + +The data structure looks like: + + { + method_name => [ + { Package::Name => '&subroutine' }, + { Other::Package::Name => '&Other::Package::subroutine' }, + ], + other_method_name => [ + { Package::Name => '&subroutine' }, + ], + } + +Where a mapping has been defined in different packages, then they are listed +in reverse order, such that the munge subroutine used by SNMP::Info is always: + + $data->{method_name}->[0]; + +=cut + +sub munge { _walk_global_data(shift, 'MUNGE') } + +=item file( $module ) + +Returns the filename from which Perl will load the given module. + +=cut + +sub file { + my $self = shift; + my $class = (ref $self ? ref $self : $self); + + return Module::Info->new_from_module( $class )->file; +} + +=item superclasses( $class || $object ) + +Returns the list (in order) of the names of classes Perl will search to find +methods for this SNMP::Info class or object instance. + +Note this B the L distribution to be installed. + +=cut + +sub superclasses { + my $self = shift; + my $class = (ref $self ? ref $self : $self); + + Module::Load::load( $class ); + return Class::ISA::self_and_super_path( $class ); +} + +=item print_globals( $module || $object ) + +Pretty print the output of C. + +=cut + +sub print_globals { _print_global_data(shift, 'GLOBALS') } + +=item print_funcs( $module || $object ) + +Pretty print the output of C. + +=cut + +sub print_funcs { _print_global_data(shift, 'FUNCS') } + +=item print_munge( $module || $object ) + +Pretty print the output of C. + +=cut + +sub print_munge { _print_global_data(shift, 'MUNGE') } + +=item print_superclasses( $class || $object ) + +Pretty print the output of C. + +=cut + +sub print_superclasses { + print join ("\n", (shift)->superclasses), "\n"; +} + +=back + +=head1 AUTHOR + +Oliver Gorwits + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2014 by The Netdisco Project. + + # Redistribution and use in source and binary forms, with or without + # modification, are permitted provided that the following conditions are met: + # + # * Redistributions of source code must retain the above copyright notice, + # this list of conditions and the following disclaimer. + # * Redistributions in binary form must reproduce the above copyright + # notice, this list of conditions and the following disclaimer in the + # documentation and/or other materials provided with the distribution. + # * Neither the name of the University of California, Santa Cruz nor the + # names of its contributors may be used to endorse or promote products + # derived from this software without specific prior written permission. + # + # THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + # AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + # IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + # ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + # LIABLE FOR # ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + # CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + # SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + # INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + # CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + # ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + # POSSIBILITY OF SUCH DAMAGE. + +=cut + +1;