File Coverage

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

linestmtbrancondsubtimecode
1package 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
10our $VERSION = '0.06';
11
12# ABSTRACT: Generate some stuff via introspection
13
14with 'Pod::Weaver::Role::Section';
15
16subtype 'Pod::Weaver::Section::ClassMopper::MethodListType'
17   => as 'ArrayRef';
18
19coerce 'Pod::Weaver::Section::ClassMopper::MethodListType'
20   => from 'Str'
21   => via {
22      [split(/\s+/, $_)]
23   };
24
25has '_attrs' => ( is => 'rw' );
26has '_methods' => ( is => 'rw' );
27has '_class' => ( is => 'rw' );
28
29has '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
42has [qw(no_tagline include_private skip_attributes skip_methods)] => (
43   is => 'rw',
44   isa => 'Bool',
45   default => 0
46);
47
48sub 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
89sub _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
102sub _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
116sub _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
157sub _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
224sub _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