lib/MooseX/AutoDoc.pm

   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