File Coverage

blib/lib/Meta/Grapher/Moose.pm
Criterion Covered Total %
statement 136 136 100.0
branch 40 48 83.3
condition 15 27 55.5
subroutine 21 21 100.0
pod 1 1 100.0
total 213 233 91.4


line stmt bran cond sub pod time code
1             package Meta::Grapher::Moose;
2              
3 1     1   457787 use strict;
  1         1  
  1         22  
4 1     1   3 use warnings;
  1         2  
  1         17  
5 1     1   3 use namespace::autoclean;
  1         2  
  1         7  
6              
7             our $VERSION = '1.02';
8              
9 1     1   62 use Class::MOP;
  1         1  
  1         18  
10 1     1   343 use Meta::Grapher::Moose::Constants qw( CLASS ROLE P_ROLE ANON_ROLE );
  1         2  
  1         48  
11 1     1   9 use Try::Tiny;
  1         1  
  1         40  
12 1     1   3 use Scalar::Util qw( blessed );
  1         1  
  1         29  
13              
14 1     1   5 use Moose;
  1         1  
  1         6  
15              
16             has package => (
17             is => 'ro',
18             isa => 'Str',
19             required => 1,
20             );
21              
22             has show_meta => (
23             is => 'ro',
24             isa => 'Bool',
25             );
26              
27             has show_new => (
28             is => 'ro',
29             isa => 'Bool',
30             );
31              
32             has show_destroy => (
33             is => 'ro',
34             isa => 'Bool',
35             );
36              
37             has show_moose_object => (
38             is => 'ro',
39             isa => 'Bool',
40             );
41              
42             has _renderer => (
43             is => 'ro',
44             init_arg => 'renderer',
45             does => 'Meta::Grapher::Moose::Role::Renderer',
46             required => 1,
47             );
48              
49             # these are an internal record of what we asked our renderer to render. It's
50             # used for de-duplication purposes (to avoid asking the renderer to render
51             # the same thing twice), but is inaccessible to the renderer that is responsible
52             # for keeping it's own state.
53              
54             has _nodes => (
55             traits => ['Hash'],
56             is => 'ro',
57             isa => 'HashRef[Bool]',
58             default => sub { {} },
59             handles => {
60             _set_node => 'set',
61             _already_seen_node => 'get',
62             },
63             );
64              
65             sub _seen_node {
66 16     16   10 my $self = shift;
67 16         16 my $node = shift;
68 16         438 $self->_set_node( $node => 1 );
69             }
70              
71             has _edges => (
72             traits => ['Hash'],
73             is => 'ro',
74             isa => 'HashRef[Bool]',
75             default => sub { {} },
76             handles => {
77             _set_edge => 'set',
78             _already_seen_edge => 'get',
79             },
80             );
81              
82             sub _seen_edge {
83 18     18   18 my $self = shift;
84 18         14 my $edge = shift;
85 18         522 $self->_set_edge( $edge => 1 );
86             }
87              
88             with 'MooseX::Getopt::Dashes';
89              
90             sub run {
91 1     1 1 1 my $self = shift;
92              
93 1         26 my $package = $self->package;
94              
95             # This just produces a better error message than Module::Runtime or any
96             # other runtime loader.
97             #
98             ## no critic (BuiltinFunctions::ProhibitStringyEval)
99 1 50       62 eval "require $package; 1;"
100             or die $@;
101             ## use critic
102              
103 1         8 $self->_process_package( $package, 2048 );
104 1         23 $self->_renderer->render;
105              
106 1         4 return 0;
107             }
108              
109             sub _get_methods_and_attributes {
110 21     21   20 my $self = shift;
111 21         13 my $meta = shift;
112              
113             # HERE YOU ARE ETHAN
114             # - turn into a for loop, add filtering for meta
115 21         14 my @methods;
116 21         66 for my $method_name ( $meta->get_method_list ) {
117 92 100 66     2283 next if $method_name eq 'meta' && !$self->show_meta;
118 71 100 66     197 next if $method_name eq 'new' && !$self->show_new;
119 67 100 66     204 next if $method_name eq 'DESTROY' && !$self->show_destroy;
120              
121 63         98 my $method = $meta->get_method($method_name);
122              
123             # ignore methods that weren't created in this class (i.e. they
124             # came from a role)
125 63 100       961 next if $method->original_package_name ne $meta->name;
126              
127             # ignore things that are just readers and writers since they're
128             # already listed as attributes (we probably want to add some
129             # configuration on this later)
130             next
131 41 100 66     307 if $method->isa('Class::MOP::Method::Accessor')
132             && $method->accessor_type =~ /^[rw]/;
133              
134 23         40 push @methods, $method_name;
135             }
136              
137 21         93 my @attributes;
138 21         59 ATTRIBUTE: for my $attr_name ( $meta->get_attribute_list ) {
139 38         106 my $attribute = $meta->get_attribute($attr_name);
140              
141             # roles know where they get their attributes from
142 38 100       200 if ( $attribute->can('original_role') ) {
143 20 100       33 if ( $attribute->original_role->name eq $meta->name ) {
144 17         901 push @attributes, $attr_name;
145             }
146 20         108 next ATTRIBUTE;
147             }
148              
149             # otherwise we need to check each of our roles to see if they
150             # have the accessor of the same neme
151 18         28 for my $role ( $self->_roles_from($meta) ) {
152 18 100       100 if ( $role->get_attribute($attr_name) ) {
153 16         93 next ATTRIBUTE;
154             }
155             }
156 2         17 push @attributes, $attr_name;
157             }
158              
159             return (
160 21         94 methods => \@methods,
161             attributes => \@attributes,
162             );
163             }
164              
165             sub _process_package {
166 1     1   3 my $self = shift;
167 1         2 my $package = shift;
168 1         2 my $weight = shift;
169              
170 1     1   20 my $meta = try { $package->meta }
171 1 50       5 or die "$package does not have a ->meta method\n";
172              
173 1 50 33     30 die
      33        
174             "$package->meta is not a Moose::Meta::Class or a Moose::Meta::Role, it's a "
175             . ref($meta) . "\n"
176             unless blessed $meta
177             && ( $meta->isa('Moose::Meta::Class')
178             || $meta->isa('Moose::Meta::Role') );
179              
180 1         5 my $name = $self->_node_label_for($meta);
181 1         6 $self->_maybe_add_node_to_graph(
182             id => $name,
183             label => $name,
184             type => CLASS,
185             $self->_get_methods_and_attributes($meta),
186             );
187              
188             # We halve the weight each time we go up the tree. This makes the graph
189             # cleaner (straighter lines) nearest the node we start from.
190 1 50       7 $self->_follow_parents( $meta, $weight )
191             if $meta->isa('Moose::Meta::Class');
192 1         3 $self->_follow_roles( $meta, $meta, $weight );
193              
194 1         3 return 0;
195             }
196              
197             sub _follow_parents {
198 4     4   5 my $self = shift;
199 4         3 my $meta = shift;
200 4         3 my $weight = shift;
201              
202             ## no critic (Subroutines::ProhibitCallsToUnexportedSubs)
203 4         13 my @parents = map { Class::MOP::class_of($_) } $meta->superclasses;
  3         151  
204             ## use critic
205              
206 4         49 for my $parent (@parents) {
207              
208 3         6 my $name = $self->_node_label_for($parent);
209 3         9 $self->_maybe_add_node_to_graph(
210             id => $name,
211             label => $name,
212             type => CLASS,
213             $self->_get_methods_and_attributes($parent),
214             );
215              
216 3         9 $self->_maybe_add_edge_to_graph(
217             from => $parent,
218             to => $meta,
219             type => CLASS,
220             weight => $weight,
221             );
222              
223 3         7 $self->_follow_roles( $parent, $parent, $weight );
224 3         42 $self->_follow_parents( $parent, $weight / 2 );
225             }
226              
227 4         6 return;
228             }
229              
230             sub _follow_roles {
231 24     24   20 my $self = shift;
232 24         16 my $to_meta = shift;
233 24         12 my $roles_from = shift;
234 24         16 my $weight = shift;
235              
236 24         28 for my $role ( $self->_roles_from($roles_from) ) {
237 20         114 $self->_record_role(
238             $to_meta,
239             $role,
240             $weight / 2
241             );
242             }
243              
244             }
245              
246             sub _roles_from {
247 42     42   32 my $self = shift;
248 42         25 my $roles_from = shift;
249              
250 42 100       117 if ( $roles_from->isa('Moose::Meta::Class') ) {
251 22         79 return map { $_->role } $roles_from->role_applications;
  21         1119  
252             }
253              
254 20         12 return @{ $roles_from->get_roles };
  20         539  
255             }
256              
257             sub _record_role {
258 20     20   17 my $self = shift;
259 20         14 my $to_meta = shift;
260 20         16 my $role = shift;
261 20         10 my $weight = shift;
262              
263             # For the purposes of this graph, Composite roles are essentially an
264             # implementation detail of Moose. We just want to see that Class A
265             # consumes Roles X, Y, & Z. The fact that this was done in a single "with"
266             # (or not) is not going to be included on the graph. We skip composite
267             # roles and simply graph the roles that they are composed of.
268 20 100       82 unless ( $role->isa('Moose::Meta::Role::Composite') ) {
269 17         11 my ( $label, $type );
270 17 100       57 if (
271             $role->isa(
272             'MooseX::Role::Parameterized::Meta::Role::Parameterized')
273             ) {
274 4         124 $label = $self->_node_label_for( $role->genitor );
275 4         10 $type = ANON_ROLE;
276             }
277             else {
278 13         16 $label = $self->_node_label_for($role);
279 13 100 66     36 $type = (
280             $role->meta->can('does_role') && $role->meta->does_role(
281             'MooseX::Role::Parameterized::Meta::Trait::Parameterizable'
282             )
283             ) ? P_ROLE : ROLE;
284             }
285              
286 17         32 $self->_maybe_add_node_to_graph(
287             id => $self->_node_label_for($role),
288             label => $label,
289             type => $type,
290             $self->_get_methods_and_attributes($role),
291             );
292              
293 17         32 $self->_maybe_add_edge_to_graph(
294             from => $role,
295             to => $to_meta,
296             weight => $weight,
297             );
298              
299 17         24 $to_meta = $role;
300             }
301              
302 20         33 $self->_follow_roles( $to_meta, $role, $weight );
303              
304 20         53 return;
305             }
306              
307             # We need to dedeuplicate nodes - obviously more than one thing can point
308             # to any given node!
309             sub _maybe_add_node_to_graph {
310 21     21   17 my $self = shift;
311 21         67 my %p = @_;
312              
313 21 100 66     66 return if $p{id} eq 'Moose::Object' && !$self->show_moose_object;
314 20 100       592 return if $self->_already_seen_node( $p{id} );
315              
316 16         355 $self->_renderer->add_package( map { $_ => $p{$_} }
  80         111  
317             qw( id methods attributes type label ) );
318              
319 16         488 $self->_seen_node( $p{id} );
320              
321 16         24 return;
322             }
323              
324             # We also need to deduplicate edges - it's possible for an edge to appear twice
325             # if something earlier in the graph consumes a role directly that it also
326             # consumes via another role indirectly. For example, if class A consumes roles B
327             # & C, but role B _also_ consumes role C. In that case, we end up visiting role
328             # C twice. That means that if C consumes some roles we'd end up seeing that
329             # relationship twice as well.
330             #
331             # The same could happen with a weird inheritance tree where a class and its
332             # parent both inherit from the same (other) parent class.
333             sub _maybe_add_edge_to_graph {
334 20     20   19 my $self = shift;
335 20         34 my %p = @_;
336              
337             @p{qw( from to )}
338 20         29 = map { $self->_node_label_for($_) } @p{qw( from to )};
  40         48  
339              
340 20 50       530 unless ( $self->show_moose_object ) {
341 20 100       34 return if $p{from} eq 'Moose::Object';
342 19 50       25 return if $p{to} eq 'Moose::Object';
343             }
344              
345             # When a parameterized role consumes role inside its role{} block, we may
346             # end up trying to add an edge from the parameterized role to itself,
347             # which we can just ignore.
348 19 50       28 return if $p{from} eq $p{to};
349              
350 19         38 my $key = join ' - ', @p{qw( from to )};
351 19 100       597 return if $self->_already_seen_edge($key);
352              
353             $self->_renderer->add_edge(
354             from => $p{from},
355             to => $p{to},
356             weight => $p{weight},
357             type => $p{type},
358 18         437 );
359              
360 18         576 $self->_seen_edge($key);
361              
362 18         26 return;
363             }
364              
365             sub _node_label_for {
366 78     78   81 my $self = shift;
367 78         52 my $meta = shift;
368              
369 78 50 33     415 return $meta unless blessed $meta && $meta->can('name');
370 78         196 return $meta->name;
371             }
372              
373             __PACKAGE__->meta->make_immutable;
374              
375             1;
376              
377             # ABSTRACT: Produce graphs showing meta-information about classes and roles
378              
379             __END__
380              
381             =pod
382              
383             =encoding UTF-8
384              
385             =head1 NAME
386              
387             Meta::Grapher::Moose - Produce graphs showing meta-information about classes and roles
388              
389             =head1 VERSION
390              
391             version 1.02
392              
393             =head1 SYNOPSIS
394              
395             From the shell:
396              
397             foo@bar:~/package$ graph-meta.pl --package='My::Package::Name' --output='diagram.png'
398              
399             Or from code:
400              
401             my $grapher = Meta::Grapher::Moose->new(
402             package => 'My::Package::Name',
403             renderer => Meta::Grapher::Moose::Renderer::Plantuml->new(
404             output => 'diagram.png',
405             ),
406             );
407             $grapher->run;
408              
409             =head1 DESCRIPTION
410              
411             STOP: The most common usage for this module is to use the command line
412             F<graph-meta.pl> program. You should read the documentation for
413             F<graph-meta.pl> to see how that works.
414              
415             This module allows you to create graphs of your Moose classes showing a
416             directed graph of the parent classes and roles that your class consumes
417             recursively. In short, it can visually answer the questions like "Why did I
418             end up consuming that role" and, with the right renderer backend, "Where did
419             that method come from?"
420              
421             =head2 Example Output
422              
423             With the GraphViz renderer (no methods/attributes):
424             L<http://st.aticpan.org/source/DROLSKY/Meta-Grapher-Moose-1.00/examples/output/graphviz/example.png>
425              
426             =for html <img src="http://st.aticpan.org/source/DROLSKY/Meta-Grapher-Moose-1.00/examples/output/graphviz/example.png">
427              
428             And with the PlantUML renderer:
429             L<http://st.aticpan.org/source/DROLSKY/Meta-Grapher-Moose-1.00/examples/output/plantuml/example.png>
430              
431             =for html <img src="http://st.aticpan.org/source/DROLSKY/Meta-Grapher-Moose-1.00/examples/output/plantuml/example.png">
432              
433             =head1 ATTRIBUTES
434              
435             This class accepts the following attributes:
436              
437             =head2 package
438              
439             The name of package that we should render a graph for.
440              
441             String. Required.
442              
443             =head2 show_meta
444              
445             Since every Moose class and role normally has a C<meta()> method it is
446             omitted from every class for brevity; Enabling this option causes it to be
447             rendered.
448              
449             =head2 show_new
450              
451             The standard C<new()> constructor is omitted from every class for brevity;
452             Enabling this option causes it to be rendered.
453              
454             =head2 show_destroy
455              
456             The C<DESTROY()> method that Moose installs is omitted from every class for
457             brevity; Enabling this option causes it to be rendered.
458              
459             =head2 show_moose_object
460              
461             The L<Moose::Object> base class is normally omitted from the diagram for
462             brevity. Enabling this option causes it be rendered.
463              
464             =head2 _renderer
465              
466             The renderer instance you want to use to create the graph.
467              
468             Something that consumes L<Meta::Grapher::Moose::Role::Renderer>. Required,
469             should be passed as the C<renderer> argument (without the leading underscore.)
470              
471             =head1 METHODS
472              
473             This class provides the following methods:
474              
475             =head2 run
476              
477             Builds the graph from the source code and tells the renderer to render it.
478              
479             =head1 SUPPORT
480              
481             Bugs may be submitted through L<the RT bug tracker|http://rt.cpan.org/Public/Dist/Display.html?Name=Meta-Grapher-Moose>
482             (or L<bug-meta-grapher-moose@rt.cpan.org|mailto:bug-meta-grapher-moose@rt.cpan.org>).
483              
484             I am also usually active on IRC as 'drolsky' on C<irc://irc.perl.org>.
485              
486             =head1 DONATIONS
487              
488             If you'd like to thank me for the work I've done on this module, please
489             consider making a "donation" to me via PayPal. I spend a lot of free time
490             creating free software, and would appreciate any support you'd care to offer.
491              
492             Please note that B<I am not suggesting that you must do this> in order for me
493             to continue working on this particular software. I will continue to do so,
494             inasmuch as I have in the past, for as long as it interests me.
495              
496             Similarly, a donation made in this way will probably not make me work on this
497             software much more, unless I get so many donations that I can consider working
498             on free software full time (let's all have a chuckle at that together).
499              
500             To donate, log into PayPal and send money to autarch@urth.org, or use the
501             button at L<http://www.urth.org/~autarch/fs-donation.html>.
502              
503             =head1 AUTHOR
504              
505             Dave Rolsky <autarch@urth.org>
506              
507             =head1 CONTRIBUTOR
508              
509             =for stopwords Mark Fowler
510              
511             Mark Fowler <mark@twoshortplanks.com>
512              
513             =head1 COPYRIGHT AND LICENSE
514              
515             This software is Copyright (c) 2016 by Dave Rolsky.
516              
517             This is free software, licensed under:
518              
519             The Artistic License 2.0 (GPL Compatible)
520              
521             =cut