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 | 369628 3 11 | use Moose; | |||
3 | 2 2 2 | 6982 2 12 | use Moose::Util::TypeConstraints; | |||
4 | 2 2 2 | 2021 1 198 | use Class::Load ':all'; | |||
5 | 2 2 2 | 6 2 31 | use Pod::Elemental::Element::Pod5::Command; | |||
6 | 2 2 2 | 4 10 22 | use Pod::Elemental::Element::Pod5::Ordinary; | |||
7 | 2 2 2 | 6 1 28 | use Pod::Elemental::Element::Nested; | |||
8 | 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 | 23027 | my $self = shift; | |||
50 | 2 | 4 | my( $document, $input ) = @_; | |||
51 | ||||||
52 | 2 | 10 | $self->_get_classname( $input ); | |||
53 | ||||||
54 | 2 | 7 | if( $input->{mopper}->{include_private} ) { | |||
55 | 0 | 0 | $self->include_private( 1 ); | |||
56 | } | |||||
57 | ||||||
58 | 2 | 4 | if( $input->{mopper}->{no_tagline} ) { | |||
59 | 0 | 0 | $self->no_tagline( 1 ); | |||
60 | } | |||||
61 | ||||||
62 | 2 | 4 | if( $input->{mopper}->{skip_method_list} ) { | |||
63 | 0 | 0 | $self->skip_method_list( $input->{mopper}->{skip_method_list} ); | |||
64 | } | |||||
65 | ||||||
66 | 2 | 40 | unless( $input->{mopper}->{skip_attributes} || $self->skip_attributes ) { | |||
67 | 2 | 5 | $self->_build_attributes( ); | |||
68 | 2 | 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 | 5550 | unless( $input->{mopper}->{skip_methods} || $self->skip_methods ) { | |||
78 | 2 | 5 | $self->_build_methods( ); | |||
79 | 2 | 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 | my $self = shift; | |||
91 | 2 | 31 | my $meta = $self->_class; | |||
92 | 2 | 6 | return unless ref $meta; | |||
93 | 2 | 28 | return if $meta->isa('Moose::Meta::Role'); | |||
94 | 2 | 7 | my @attributes = $meta->get_all_attributes; | |||
95 | 2 | 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 | my $self = shift; | |||
104 | 2 | 34 | my $meta = $self->_class; | |||
105 | 2 | 6 | return unless ref $meta; | |||
106 | 2 | 19 | return if $meta->isa('Moose::Meta::Role'); | |||
107 | 2 | 8 | my @methods = $meta->get_all_methods; | |||
108 | ||||||
109 | 2 | 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 | 22 | my $self = shift; | |||
119 | 32 | 15 | my $method = shift; | |||
120 | 32 | 45 | return unless ref $method; | |||
121 | 32 | 36 | my $name = $method->name; | |||
122 | ||||||
123 | 32 260 32 | 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 | 37 | if( $method->original_package_name =~ /^Moose::Object/ ) { | |||
128 | 0 | 0 | return; # No one wants to see that shit | |||
129 | } | |||||
130 | ||||||
131 | 8 | 66 | if( $name =~ /^_/ ) { | |||
132 | 2 | 35 | return unless $self->include_private; # skip over privates, unless we don't. | |||
133 | } | |||||
134 | ||||||
135 | 6 | 11 | my $bits = []; | |||
136 | 6 | 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 | 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 | 5 | my $self = shift; | |||
159 | 4 | 4 | my $attribute = shift; | |||
160 | 4 | 10 | return unless ref $attribute; | |||
161 | ||||||
162 | 4 | 14 | if( $attribute->name =~ /^_/ ) { | |||
163 | # Skip the _methods unless we shouldn't. | |||||
164 | 0 | 0 | return unless $self->include_private; | |||
165 | } | |||||
166 | ||||||
167 | 4 | 4 | my $bits = []; | |||
168 | ||||||
169 | 4 | 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 | 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 | 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 | 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 | 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 | 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 | 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 | 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 | 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 |