| 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 | ||||||