File Coverage: lib/Pod/Weaver/Section/ClassMopper.pm

# File Coverage

File: | lib/Pod/Weaver/Section/ClassMopper.pm
Coverage: | 78.6%

line | stmt | bran | cond | sub | time | code
--- | --- | --- | --- | --- | --- | ---
1 |  |  |  |  |  | package Pod::Weaver::Section::ClassMopper;
2 | 2 2 2 |  |  | 2 | 369628 3 11 | use Moose;
3 | 2 2 2 |  |  | 2 | 6982 2 12 | use Moose::Util::TypeConstraints;
4 | 2 2 2 |  |  | 2 | 2021 1 198 | use Class::Load ':all';
5 | 2 2 2 |  |  | 2 | 6 2 31 | use Pod::Elemental::Element::Pod5::Command;
6 | 2 2 2 |  |  | 2 | 4 10 22 | use Pod::Elemental::Element::Pod5::Ordinary;
7 | 2 2 2 |  |  | 2 | 6 1 28 | use Pod::Elemental::Element::Nested;
8 | 2 2 2 |  |  | 2 | 5 4 10 | use List::Util qw(first);
9 |
10 |  |  |  |  |  | our $VERSION = '0.06';
11 |
12 |  |  |  |  |  | # ABSTRACT: Generate some stuff via introspection
13 |
14 |  |  |  |  |  | with 'Pod::Weaver::Role::Section';
15 |
16 |  |  |  |  |  | subtype 'Pod::Weaver::Section::ClassMopper::MethodListType'
17 |  |  |  |  |  | => as 'ArrayRef';
18 |
19 |  |  |  |  |  | coerce 'Pod::Weaver::Section::ClassMopper::MethodListType'
20 |  |  |  |  |  | => from 'Str'
21 |  |  |  |  |  | => via {
22 |  |  |  |  |  | [split(/\s+/, $_)]
23 |  |  |  |  |  | };
24 |
25 |  |  |  |  |  | has '_attrs' => ( is => 'rw' );
26 |  |  |  |  |  | has '_methods' => ( is => 'rw' );
27 |  |  |  |  |  | has '_class' => ( is => 'rw' );
28 |
29 |  |  |  |  |  | has 'skip_method_list' => (
30 |  |  |  |  |  | is => 'ro',
31 |  |  |  |  |  | isa => 'Pod::Weaver::Section::ClassMopper::MethodListType',
32 |  |  |  |  |  | coerce => 1,
33 |  |  |  |  |  | default => sub {
34 |  |  |  |  |  | my @list = Moose::Object->meta->get_all_method_names;
35 |  |  |  |  |  | push @list, 'can';
36 |  |  |  |  |  | return \@list;
37 |  |  |  |  |  | }
38 |  |  |  |  |  | );
39 |
40 |
41 |
42 |  |  |  |  |  | has [qw(no_tagline include_private skip_attributes skip_methods)] => (
43 |  |  |  |  |  | is => 'rw',
44 |  |  |  |  |  | isa => 'Bool',
45 |  |  |  |  |  | default => 0
46 |  |  |  |  |  | );
47 |
48 |  |  |  |  |  | sub weave_section {
49 | 2 |  |  | 2 | 23027 | my $self = shift;
50 | 2 |  |  |  | 4 | my( $document, $input ) = @_;
51 |
52 | 2 |  |  |  | 10 | $self->_get_classname( $input );
53 |
54 | 2 | 50 |  |  | 7 | if( $input->{mopper}->{include_private} ) {
55 | 0 |  |  |  | 0 | $self->include_private( 1 );
56 |  |  |  |  |  | }
57 |
58 | 2 | 50 |  |  | 4 | if( $input->{mopper}->{no_tagline} ) {
59 | 0 |  |  |  | 0 | $self->no_tagline( 1 );
60 |  |  |  |  |  | }
61 |
62 | 2 | 50 |  |  | 4 | if( $input->{mopper}->{skip_method_list} ) {
63 | 0 |  |  |  | 0 | $self->skip_method_list( $input->{mopper}->{skip_method_list} );
64 |  |  |  |  |  | }
65 |
66 | 2 | 50 | 33 |  | 40 | unless( $input->{mopper}->{skip_attributes} || $self->skip_attributes ) {
67 | 2 |  |  |  | 5 | $self->_build_attributes( );
68 | 2 | 50 |  |  | 54 | if( $self->_attrs ) {
69 | 2 2 |  |  |  | 4 58 | push @{$document->children}, Pod::Elemental::Element::Nested->new({
70 |  |  |  |  |  | command => 'head1',
71 |  |  |  |  |  | content => 'ATTRIBUTES',
72 |  |  |  |  |  | children => $self->_attrs }
73 |  |  |  |  |  | );
74 |  |  |  |  |  | }
75 |  |  |  |  |  | }
76 |
77 | 2 | 50 | 33 |  | 5550 | unless( $input->{mopper}->{skip_methods} || $self->skip_methods ) {
78 | 2 |  |  |  | 5 | $self->_build_methods( );
79 | 2 | 50 |  |  | 31 | if( $self->_methods ) {
80 | 2 2 |  |  |  | 3 42 | push @{$document->children}, Pod::Elemental::Element::Nested->new({
81 |  |  |  |  |  | command => 'head1',
82 |  |  |  |  |  | content => 'METHODS',
83 |  |  |  |  |  | children => $self->_methods }
84 |  |  |  |  |  | );
85 |  |  |  |  |  | }
86 |  |  |  |  |  | }
87 |  |  |  |  |  | }
88 |
89 |  |  |  |  |  | sub _build_attributes {
90 | 2 |  |  | 2 | 2 | my $self = shift;
91 | 2 |  |  |  | 31 | my $meta = $self->_class;
92 | 2 | 50 |  |  | 6 | return unless ref $meta;
93 | 2 | 50 |  |  | 28 | return if $meta->isa('Moose::Meta::Role');
94 | 2 |  |  |  | 7 | my @attributes = $meta->get_all_attributes;
95 | 2 | 50 |  |  | 83 | if( @attributes ) {
96 | 4 2 |  |  |  | 11 6 | my @chunks = map { $self->_build_attribute_paragraph( $_ ) }
97 | 2 |  |  |  | 6 | sort { $a->{'name'} cmp $b->{'name'} } @attributes;
98 | 2 |  |  |  | 47 | $self->_attrs( \@chunks );
99 |  |  |  |  |  | }
100 |  |  |  |  |  | }
101 |
102 |  |  |  |  |  | sub _build_methods {
103 | 2 |  |  | 2 | 2 | my $self = shift;
104 | 2 |  |  |  | 34 | my $meta = $self->_class;
105 | 2 | 50 |  |  | 6 | return unless ref $meta;
106 | 2 | 50 |  |  | 19 | return if $meta->isa('Moose::Meta::Role');
107 | 2 |  |  |  | 8 | my @methods = $meta->get_all_methods;
108 |
109 | 2 | 50 |  |  | 1127 | if( @methods ) {
110 | 32 93 |  |  |  | 33 65 | my @chunks = map { $self->_build_method_paragraph( $_ ) }
111 | 2 |  |  |  | 7 | sort { $a->{'name'} cmp $b->{'name'} } @methods;
112 | 2 |  |  |  | 35 | $self->_methods( \@chunks );
113 |  |  |  |  |  | }
114 |  |  |  |  |  | }
115 |
116 |  |  |  |  |  | sub _build_method_paragraph {
117 |  |  |  |  |  | # Generate a pod section for a method.
118 | 32 |  |  | 32 | 22 | my $self = shift;
119 | 32 |  |  |  | 15 | my $method = shift;
120 | 32 | 50 |  |  | 45 | return unless ref $method;
121 | 32 |  |  |  | 36 | my $name = $method->name;
122 |
123 | 32 260 32 | 100 |  | 260 | 49 137 498 | if( first { $_ eq $name } @{$self->skip_method_list} ) {
124 | 24 |  |  |  | 33 | return; # Skip over some of the more .. UNIVERSAL methods..
125 |  |  |  |  |  | }
126 |
127 | 8 | 50 |  |  | 37 | if( $method->original_package_name =~ /^Moose::Object/ ) {
128 | 0 |  |  |  | 0 | return; # No one wants to see that shit
129 |  |  |  |  |  | }
130 |
131 | 8 | 100 |  |  | 66 | if( $name =~ /^_/ ) {
132 | 2 | 50 |  |  | 35 | return unless $self->include_private; # skip over privates, unless we don't.
133 |  |  |  |  |  | }
134 |
135 | 6 |  |  |  | 11 | my $bits = [];
136 | 6 | 50 |  |  | 98 | if( $self->_class ne $method->original_package_name ) {
137 | 6 |  |  |  | 34 | push @$bits, Pod::Elemental::Element::Pod5::Ordinary->new({
138 |  |  |  |  |  | content => 'Method originates in ' . $method->original_package_name . '.'
139 |  |  |  |  |  | });
140 |  |  |  |  |  | }
141 |
142 | 6 | 50 |  |  | 8744 | unless( $self->no_tagline ) {
143 | 0 |  |  |  | 0 | push @$bits, Pod::Elemental::Element::Pod5::Ordinary->new({
144 |  |  |  |  |  | content => 'This documentation was automatically generated.'
145 |  |  |  |  |  | });
146 |  |  |  |  |  | }
147 |
148 | 6 |  |  |  | 31 | my $meth = Pod::Elemental::Element::Nested->new( {
149 |  |  |  |  |  | command => 'head2',
150 |  |  |  |  |  | content => $method->name,
151 |  |  |  |  |  | children => $bits
152 |  |  |  |  |  | } );
153 | 6 |  |  |  | 14561 | return $meth;
154 |
155 |  |  |  |  |  | }
156 |
157 |  |  |  |  |  | sub _build_attribute_paragraph {
158 | 4 |  |  | 4 | 5 | my $self = shift;
159 | 4 |  |  |  | 4 | my $attribute = shift;
160 | 4 | 50 |  |  | 10 | return unless ref $attribute;
161 |
162 | 4 | 50 |  |  | 14 | if( $attribute->name =~ /^_/ ) {
163 |  |  |  |  |  | # Skip the _methods unless we shouldn't.
164 | 0 | 0 |  |  | 0 | return unless $self->include_private;
165 |  |  |  |  |  | }
166 |
167 | 4 |  |  |  | 4 | my $bits = [];
168 |
169 | 4 | 50 |  |  | 12 | if( $attribute->has_read_method ) {
170 |  |  |  |  |  | # is => 'r..'
171 | 4 |  |  |  | 34 | my $reader = $attribute->get_read_method;
172 | 4 |  |  |  | 51 | push @$bits, Pod::Elemental::Element::Pod5::Ordinary->new({
173 |  |  |  |  |  | content => 'Reader: ' . $reader
174 |  |  |  |  |  | });
175 |  |  |  |  |  | }
176 |
177 | 4 | 100 |  |  | 6283 | if( $attribute->has_write_method ) {
178 |  |  |  |  |  | # is => '..w'
179 | 2 |  |  |  | 22 | my $writer = $attribute->get_write_method;
180 | 2 |  |  |  | 25 | push @$bits, Pod::Elemental::Element::Pod5::Ordinary->new({
181 |  |  |  |  |  | content => 'Writer: ' . $writer
182 |  |  |  |  |  | });
183 |  |  |  |  |  | }
184 |
185 |  |  |  |  |  | # Moose has typecontraints, not Class::MOP.
186 | 4 | 50 |  |  | 3224 | if( $attribute->has_type_constraint ) {
187 |  |  |  |  |  | # has an 'isa => ...'
188 | 4 |  |  |  | 121 | push @$bits, Pod::Elemental::Element::Pod5::Ordinary->new({
189 |  |  |  |  |  | content => 'Type: ' . $attribute->type_constraint->name
190 |  |  |  |  |  | });
191 |  |  |  |  |  | }
192 |
193 |  |  |  |  |  | # Moose only, again.
194 | 4 | 50 |  |  | 6559 | if( $attribute->is_required ) {
195 | 0 |  |  |  | 0 | push @$bits, Pod::Elemental::Element::Pod5::Ordinary->new({
196 |  |  |  |  |  | content => 'This attribute is required.'
197 |  |  |  |  |  | });
198 |  |  |  |  |  | }
199 |
200 | 4 | 100 |  |  | 160 | if( $attribute->has_documentation ) {
201 |  |  |  |  |  | # Moose's 'docmentation' option.
202 | 2 |  |  |  | 102 | push @$bits, Pod::Elemental::Element::Pod5::Ordinary->new({
203 |  |  |  |  |  | content => 'Additional documentation: ' . $attribute->documentation
204 |  |  |  |  |  | });
205 |  |  |  |  |  | }
206 |
207 | 4 | 50 |  |  | 3193 | unless( $self->no_tagline ) {
208 |  |  |  |  |  | # Adds the 'auto generated' tagline, unless not.
209 | 0 |  |  |  | 0 | push @$bits, Pod::Elemental::Element::Pod5::Ordinary->new({
210 |  |  |  |  |  | content => 'This documentation was automatically generated.'
211 |  |  |  |  |  | });
212 |  |  |  |  |  | }
213 |
214 |  |  |  |  |  | # build up our element, send it on its way.
215 | 4 |  |  |  | 37 | my $a = Pod::Elemental::Element::Nested->new({
216 |  |  |  |  |  | command => 'head2',
217 |  |  |  |  |  | content => $attribute->name,
218 |  |  |  |  |  | children => $bits
219 |  |  |  |  |  | });
220 | 4 |  |  |  | 13609 | return $a;
221 |
222 |  |  |  |  |  | }
223 |
224 |  |  |  |  |  | sub _get_classname {
225 | 2 |  |  | 2 | 2 | my( $self, $input ) = @_;
226 |
227 |  |  |  |  |  | # Do some fiddling here, see what sort of crap we have, and
228 |  |  |  |  |  | # try to return a package name.
229 | 2 |  |  |  | 3 | my $classname;
230 |
231 | 2 |  |  |  | 3 | my $ppi = $input->{ppi_document};
232 | 2 | 50 |  |  | 8 | unless( ref $ppi eq 'PPI::Document' ) {
233 | 0 |  |  |  | 0 | return;
234 |  |  |  |  |  | }
235 | 2 |  |  |  | 8 | my $node = $ppi->find_first('PPI::Statement::Package');
236 | 2 | 50 |  |  | 331 | if( $node ) {
237 | 2 |  |  |  | 8 | $classname = $node->namespace;
238 |  |  |  |  |  | } else {
239 |  |  |  |  |  | # parsing comments. WHAT COULD GO WRONG.
240 |  |  |  |  |  | # Shamelessly stolen from Pod::Weaver::Section::Name. Thanks rjbs!
241 | 0 |  |  |  | 0 | ($classname) = $ppi->serialize =~ /^\s*#+\s*PODNAME:\s*(.+)$/m;
242 |  |  |  |  |  | }
243 | 2 |  |  |  | 65 | load_class( $classname );
244 |  |  |  |  |  | # Class::MOP::load_class( $classname ); # So the meta has .. something.
245 | 2 |  |  |  | 469 | my $meta = Class::MOP::Class->initialize( $classname );
246 | 2 |  |  |  | 49 | $self->_class( $meta );
247 | 2 |  |  |  | 3 | return $classname;
248 |  |  |  |  |  | }
249 |
250 |
251 |
252 |  |  |  |  |  | __PACKAGE__->meta->make_immutable;
253 |