Commit | Line | Data |
3890b670 |
1 | package MooseX::AutoDoc; |
2 | |
3 | use Moose; |
4 | use Carp; |
5 | use Class::MOP; |
6 | use Moose::Meta::Role; |
7 | use Moose::Meta::Class; |
8 | use Scalar::Util qw/blessed/; |
9 | |
10 | # Create a special TypeConstraint for the View so you can just set it |
11 | # with a class name and it'll DWIM |
12 | { |
13 | use Moose::Util::TypeConstraints; |
14 | |
15 | subtype 'AutoDocView' |
16 | => as 'Object' |
17 | => where { $_->isa('MooseX::AutoDoc::View') } |
18 | => message { "Value should be a subclass of MooseX::AutoDoc::View" } ; |
19 | |
20 | coerce 'AutoDocView' |
21 | => from 'Str' |
22 | => via { Class::MOP::load_class($_); $_->new }; |
23 | |
24 | no Moose::Util::TypeConstraints; |
25 | } |
26 | |
27 | #view object |
28 | has view => (is => 'rw', isa => 'AutoDocView', coerce => 1, lazy_build => 1); |
29 | |
30 | #type constraint library to name mapping to make nice links |
31 | has tc_to_lib_map => (is => 'rw', isa => 'HashRef', lazy_build => 1); |
32 | |
33 | #method metaclasses to ignore to avoid documenting some methods |
34 | has ignored_method_metaclasses => (is => 'rw', isa => 'HashRef', lazy_build => 1); |
35 | |
36 | #defaults to artistic... |
37 | has license_text => (is => 'rw', isa => 'Str', lazy_build => 1); |
38 | |
39 | #how can i get the data about the current user? |
40 | has authors => (is => 'rw', isa => 'ArrayRef[HashRef]', |
41 | predicate => 'has_authors'); |
42 | |
43 | sub _build_view { "MooseX::AutoDoc::View::TT" } |
44 | |
45 | sub _build_tc_to_lib_map { |
46 | my %types = map {$_ => 'Moose::Util::TypeConstraints'} |
47 | qw/Any Item Bool Undef Defined Value Num Int Str Role Maybe ClassName Ref |
48 | ScalarRef ArrayRef HashRef CodeRef RegexpRef GlobRef FileHandle Object/; |
49 | return \ %types; |
50 | } |
51 | |
52 | sub _build_ignored_method_metaclasses { |
53 | return { |
54 | 'Moose::Meta::Role::Method' => 1, |
55 | 'Moose::Meta::Method::Accessor' => 1, |
56 | 'Moose::Meta::Method::Constructor' => 1, |
57 | 'Class::MOP::Method::Accessor' => 1, |
58 | 'Class::MOP::Method::Generated' => 1, |
59 | 'Class::MOP::Method::Constructor' => 1, |
60 | }; |
61 | |
62 | # 'Moose::Meta::Method::Overridden' => 1, |
63 | # 'Class::MOP::Method::Wrapped' => 1, |
64 | } |
65 | |
66 | sub _build_license_text { |
67 | "This library is free software; you can redistribute it and/or modify it " |
68 | ."under the same terms as Perl itself."; |
69 | } |
70 | |
71 | #make the actual POD |
72 | sub generate_pod_for_role { |
73 | my ($self, $role, $view_args) = @_; |
74 | |
75 | carp("${role} is already loaded. This will cause inacurate output.". |
76 | "if ${role} is the consumer of any roles.") |
77 | if Class::MOP::is_class_loaded( $role ); |
78 | |
79 | my $spec = $self->role_info($role); |
80 | my $vars = { |
81 | role => $spec, |
82 | license => $self->license_text, |
83 | authors => $self->has_authors ? $self->authors : [], |
84 | }; |
85 | return $self->view->render_role($vars, $view_args); |
86 | } |
87 | |
88 | #make the actual POD |
89 | sub generate_pod_for_class { |
90 | my ($self, $class, $view_args) = @_; |
91 | |
92 | carp("${class} is already loaded. This will cause inacurate output.". |
93 | "if ${class} is the consumer of any roles.") |
94 | if Class::MOP::is_class_loaded( $class ); |
95 | |
96 | my $spec = $self->class_info($class); |
97 | my $vars = { |
98 | class => $spec, |
99 | license => $self->license_text, |
100 | authors => $self->has_authors ? $self->authors : [], |
101 | }; |
102 | |
103 | return $self->view->render_class($vars, $view_args); |
104 | } |
105 | |
106 | |
107 | # *_info methods |
108 | sub role_info { |
109 | my ($self, $role) = @_; |
110 | |
111 | my (@roles_to_apply, $rmeta, $original_apply); |
112 | { #intercept role application so we can accurately generate |
113 | #method and attribute information for the parent class. |
114 | #this is fragile, but there is not better way that i am aware of |
115 | |
116 | $rmeta = Moose::Meta::Role->meta; |
117 | $rmeta->make_mutable if $rmeta->is_immutable; |
118 | $original_apply = $rmeta->get_method("apply")->body; |
119 | $rmeta->remove_method("apply"); |
120 | $rmeta->add_method("apply", sub{push(@roles_to_apply, [@_])}); |
121 | |
122 | eval { Class::MOP::load_class($role); }; |
123 | confess "Failed to load class ${role} $@" if $@; |
124 | } |
125 | |
126 | my $meta = $role->meta; |
127 | my $anon = Moose::Meta::Class->create_anon_class; |
128 | $original_apply->($meta, $anon); |
129 | |
130 | my @attributes = map{ $anon->get_attribute($_) } sort $anon->get_attribute_list; |
131 | |
132 | my %ignored_method_metaclasses = %{ $self->ignored_method_metaclasses }; |
133 | delete $ignored_method_metaclasses{'Moose::Meta::Role::Method'}; |
134 | my @methods = |
135 | grep{ ! exists $ignored_method_metaclasses{$_->meta->name} } |
136 | map { $anon->get_method($_) } |
137 | grep { $_ ne 'meta' } #it wasnt getting filtered on the anon class.. |
138 | sort $anon->get_method_list; |
139 | my @method_specs = map{ $self->method_info($_) } @methods; |
140 | my @attribute_specs = map{ $self->attribute_info($_) } @attributes; |
141 | |
142 | { #fix Moose::Meta::Role and apply the roles that were delayed |
143 | $rmeta->remove_method("apply"); |
144 | $rmeta->add_method("apply", $original_apply); |
145 | $rmeta->make_immutable; |
146 | shift(@$_)->apply(@$_) for @roles_to_apply; |
147 | } |
148 | |
149 | my @roles = |
150 | sort{ $a->name cmp $b->name } |
151 | map { $_->isa("Moose::Meta::Role::Composite") ? @{$_->get_roles} : $_ } |
152 | @{ $meta->get_roles }; |
153 | |
154 | my @role_specs = map{ $self->consumed_role_info($_) } @roles; |
155 | |
156 | my $spec = { |
157 | name => $meta->name, |
158 | roles => \ @role_specs, |
159 | methods => \ @method_specs, |
160 | attributes => \ @attribute_specs, |
161 | }; |
162 | |
163 | return $spec; |
164 | } |
165 | |
166 | |
167 | sub class_info { |
168 | my ($self, $class) = @_; |
169 | |
170 | my (@roles_to_apply, $rmeta, $original_apply); |
171 | { #intercept role application so we can accurately generate |
172 | #method and attribute information for the parent class. |
173 | #this is fragile, but there is not better way that i am aware of |
174 | |
175 | $rmeta = Moose::Meta::Role->meta; |
176 | $rmeta->make_mutable if $rmeta->is_immutable; |
177 | $original_apply = $rmeta->get_method("apply")->body; |
178 | $rmeta->remove_method("apply"); |
179 | $rmeta->add_method("apply", sub{push(@roles_to_apply, [@_])}); |
180 | |
181 | eval { Class::MOP::load_class($class); }; |
182 | confess "Failed to load class ${class} $@" if $@; |
183 | } |
184 | |
185 | my $meta = $class->meta; |
186 | |
187 | my @attributes = map{ $meta->get_attribute($_) } sort $meta->get_attribute_list; |
188 | my @superclasses = map{ $_->meta } |
189 | grep { $_ ne 'Moose::Object' } $meta->superclasses; |
190 | |
191 | my @methods = |
192 | grep{ ! exists $self->ignored_method_metaclasses->{$_->meta->name} } |
193 | map { $meta->get_method($_) } |
194 | grep { $_ ne 'meta' } #it wasnt getting filtered on the anon class.. |
195 | sort $meta->get_method_list; |
196 | |
197 | my @method_specs = map{ $self->method_info($_) } @methods; |
198 | my @attribute_specs = map{ $self->attribute_info($_) } @attributes; |
199 | my @superclass_specs = map{ $self->superclass_info($_) } @superclasses; |
200 | |
201 | { #fix Moose::Meta::Role and apply the roles that were delayed |
202 | $rmeta->remove_method("apply"); |
203 | $rmeta->add_method("apply", $original_apply); |
204 | $rmeta->make_immutable; |
205 | shift(@$_)->apply(@$_) for @roles_to_apply; |
206 | } |
207 | |
208 | my @roles = sort{ $a->name cmp $b->name } |
209 | map { $_->isa("Moose::Meta::Role::Composite") ? @{$_->get_roles} : $_ } |
210 | @{ $meta->roles }; |
211 | my @role_specs = map{ $self->consumed_role_info($_) } @roles; |
212 | |
213 | my $spec = { |
214 | name => $meta->name, |
215 | roles => \ @role_specs, |
216 | methods => \ @method_specs, |
217 | attributes => \ @attribute_specs, |
218 | superclasses => \ @superclass_specs, |
219 | }; |
220 | |
221 | return $spec; |
222 | } |
223 | |
224 | sub attribute_info{ |
225 | my($self, $attr) = @_;; |
226 | my $attr_name = $attr->name; |
227 | my $spec = { name => $attr_name }; |
228 | my $info = $spec->{info} = {}; |
229 | |
230 | $info->{clearer} = $attr->clearer if $attr->has_clearer; |
231 | $info->{builder} = $attr->builder if $attr->has_builder; |
232 | $info->{predicate} = $attr->predicate if $attr->has_predicate; |
233 | |
234 | |
235 | my $description = $attr->is_required ? 'Required ' : 'Optional '; |
236 | if( defined(my $is = $attr->_is_metadata) ){ |
237 | $description .= 'read-only ' if $is eq 'ro'; |
238 | $description .= 'read-write ' if $is eq 'rw'; |
239 | |
240 | #If we have 'is' info only write out this info if it != attr_name |
241 | $info->{writer} = $attr->writer |
242 | if $attr->has_writer && $attr->writer ne $attr_name; |
243 | $info->{reader} = $attr->reader |
244 | if $attr->has_reader && $attr->reader ne $attr_name; |
245 | $info->{accessor} = $attr->accessor |
246 | if $attr->has_accessor && $attr->accessor ne $attr_name; |
247 | } else { |
248 | $info->{writer} = $attr->writer if $attr->has_writer; |
249 | $info->{reader} = $attr->reader if $attr->has_reader; |
250 | $info->{accessor} = $attr->accessor if $attr->has_accessor; |
251 | } |
252 | |
253 | if( defined(my $lazy = $attr->is_lazy) ){ |
254 | $description .= 'lazy-building '; |
255 | } |
256 | $description .= 'value'; |
257 | if( defined(my $isa = $attr->_isa_metadata) ){ |
258 | my $link_to; |
259 | if( blessed $isa ){ |
260 | my $from_type_lib; |
261 | while( blessed $isa ){ |
262 | $isa = $isa->name; |
263 | } |
264 | my @parts = split '::', $isa; |
265 | my $type_name = pop @parts; |
266 | my $type_lib = join "::", @parts; |
267 | if(eval{$type_lib->isa("MooseX::Types::Base")}){ |
268 | $link_to = $type_lib; |
269 | $isa = $type_name; |
270 | } |
271 | } else { |
272 | my ($isa_base) = ($isa =~ /^(.*?)(?:\[.*\])?$/); |
273 | if (exists $self->tc_to_lib_map->{$isa_base}){ |
274 | $link_to = $self->tc_to_lib_map->{$isa_base}; |
275 | } |
276 | my $isa = $isa_base; |
277 | } |
278 | if(defined $link_to){ |
279 | $isa = "L<${isa}|${link_to}>"; |
280 | } |
281 | $description .= " of type ${isa}"; |
282 | } |
283 | if( $attr->should_auto_deref){ |
284 | $description .=" that will be automatically dereferenced by ". |
285 | "the reader / accessor"; |
286 | } |
287 | if( $attr->has_documentation ){ |
288 | $description .= "\n\n" . $attr->documentation; |
289 | } |
290 | $spec->{description} = $description; |
291 | |
292 | return $spec; |
293 | } |
294 | |
295 | sub superclass_info { |
296 | my($self, $superclass) = @_; |
297 | my $spec = { name => $superclass->name }; |
298 | return $spec; |
299 | } |
300 | |
301 | sub method_info { |
302 | my($self, $method) = @_; |
303 | my $spec = { name => $method->name }; |
304 | return $spec; |
305 | } |
306 | |
307 | sub consumed_role_info { |
308 | my($self, $role) = @_;; |
309 | my $spec = { name => $role->name }; |
310 | return $spec; |
311 | } |
312 | |
313 | 1; |
314 | |
315 | __END__; |
316 | |
317 | |
318 | |