/[Frey]/trunk/lib/Frey/Introspect.pm
This is repository of my old source code which isn't updated any more. Go to git.rot13.org for current projects!
ViewVC logotype

Diff of /trunk/lib/Frey/Introspect.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 732 by dpavlin, Fri Dec 5 17:34:42 2008 UTC revision 733 by dpavlin, Sat Dec 6 00:43:28 2008 UTC
# Line 11  use List::Util; Line 11  use List::Util;
11  use PPI;  use PPI;
12  use PPI::HTML;  use PPI::HTML;
13    
 use Frey::Pod;  
   
14  use lib 'lib';  use lib 'lib';
15    use Frey::Pod;
16    
17  extends 'Frey::PPI';  extends 'Frey::PPI';
18  with 'Frey::Web';  with 'Frey::Web';
# Line 121  sub as_markup { Line 120  sub as_markup {
120                                  join(', ',                                  join(', ',
121                                          map {                                          map {
122                                                  my $name = $_->meta->name;                                                  my $name = $_->meta->name;
123                                                  $introspect->{superclass}->{$name}++;                                                  $introspect->{superclass}->{$name} = {};
124                                                  $self->dropdown( $name, $_->meta )                                                  $self->dropdown( $name, $_->meta )
125                                          }                                          }
126                                          #grep { $_ ne 'Moose::Object' }                                          #grep { $_ ne 'Moose::Object' }
# Line 130  sub as_markup { Line 129  sub as_markup {
129                  }                  }
130          }          }
131    
132          my $role_method;          my $method_from_role;
133          my $role_attribute;          my $attribute_from_role;
134    
135          if ( $meta->can('roles') ) {          if ( $meta->can('roles') ) {
136                  my $role_nr = 1;                  my $role_nr = 1;
# Line 139  sub as_markup { Line 138  sub as_markup {
138                          grep { ! m/\Q$class\E/ }        # skip me                          grep { ! m/\Q$class\E/ }        # skip me
139                          map {                          map {
140                                  my $name = $_->name;                                  my $name = $_->name;
141                                  $introspect->{role}->{$name}++;                                  $introspect->{roles}->{$name} = {};
142                                  $role_method->{    $_ }->{$name} = $role_nr foreach $_->get_method_list;                                  $method_from_role->{    $_ }->{$name} = $role_nr foreach $_->get_method_list;
143                                  $role_attribute->{ $_ }->{$name} = $role_nr foreach $_->get_attribute_list;                                  $attribute_from_role->{ $_ }->{$name} = $role_nr foreach $_->get_attribute_list;
144                                  $self->dropdown( $name, $name->meta ) . qq|<sup>| . $role_nr++ . qq|</sup>|;                                  $self->dropdown( $name, $name->meta ) . qq|<sup>| . $role_nr++ . qq|</sup>|;
145                          }                          }
146                          $meta->calculate_all_roles                          $meta->calculate_all_roles
147                  );                  );
148                  $roles = qq| with roles: $roles| if $roles;                  $roles = qq| with roles: $roles| if $roles;
149          }          }
150          warn "# role_method ",dump( $role_method );          warn "# method_from_role ",dump( $method_from_role );
151    
152          my @methods;          my @methods;
153          @methods = map {          @methods = map {
154                  my $name = $_;                  my $name = $_;
155                  $introspect->{method}->{$name}++;                  if ( $method_from_role->{$name} ) {
156                  if ( $role_method->{$name} ) {                          my ( $role_name, $nr ) = each %{ $method_from_role->{$name} };
157                          my ( $role_name, $nr ) = each %{ $role_method->{$name} };                          $introspect->{methods}->{$name}->{role} = $role_name;
158                          $name .= qq|<sup title="$role_name">$nr</sup>|;                          $name .= qq|<sup title="$role_name">$nr</sup>|;
159                    } else {
160                            $introspect->{methods}->{$name} = {};
161                  }                  }
162                  qq|<td class="m">$name</td>|                  qq|<td class="m">$name</td>|
163          } sort $self->class_methods( $class );          } sort $self->class_methods( $class );
# Line 165  sub as_markup { Line 166  sub as_markup {
166          if ( $meta->get_attribute_list ) {          if ( $meta->get_attribute_list ) {
167                  @attributes = map {                  @attributes = map {
168                          my $name = $_;                          my $name = $_;
169                          $introspect->{attribute}->{$name}++;                          $introspect->{attribute}->{$name} = {};
170                          my $html_name = $name;                          my $html_name = $name;
171                          my $attr = $meta->get_attribute($name);                          my $attr = $meta->get_attribute($name);
172                          confess "$class attribute $name isn't blessed ",dump( $attr ) unless blessed $attr;                          confess "$class attribute $name isn't blessed ",dump( $attr ) unless blessed $attr;
173                          warn "## attr $name ref ",ref( $attr ) if $self->debug;                          warn "## attr $name ref ",ref( $attr ) if $self->debug;
174    
175                          my ( $title, $properties ) = ( '', '' );                          my ( $title, $properties ) = ( '', '' );
176                          ( $html_name, $title ) = ( "<b>$name</b>", ' title="required"' )                          if ( $attr->can('is_required') && $attr->is_required ) {
177                                  if $attr->can('is_required') && $attr->is_required;                                  ( $html_name, $title ) = ( "<b>$name</b>", ' title="required"' );
178                                    $introspect->{attribute}->{$name}->{required} = 1;
179                            }
180    
181                          foreach my $check ( qw/has_type_constraint has_handles is_weak_ref is_required is_lazy should_coerce should_auto_deref has_default has_trigger has_applied_traits/ ) {                          foreach my $check ( qw/has_type_constraint has_handles is_weak_ref is_required is_lazy should_coerce should_auto_deref has_default has_trigger has_applied_traits/ ) {
182                                  my $getter;                                  my $getter;
# Line 193  sub as_markup { Line 196  sub as_markup {
196                          }                          }
197                          my $type = $attr->can('has_type_constraint') && $attr->has_type_constraint ? $attr->type_constraint->name : '';                          my $type = $attr->can('has_type_constraint') && $attr->has_type_constraint ? $attr->type_constraint->name : '';
198    
199                          if ( $role_attribute->{$name} ) {                          if ( $attribute_from_role->{$name} ) {
200                                  my ( $role_name, $nr ) = each %{ $role_attribute->{$name} };                                  my ( $role_name, $nr ) = each %{ $attribute_from_role->{$name} };
201                                  $name .= qq|<sup title="$role_name">$nr</sup>|;                                  $name .= qq|<sup title="$role_name">$nr</sup>|;
202                          }                          }
203    
# Line 241  sub as_markup { Line 244  sub as_markup {
244    
245          my $runnable = join("\n",          my $runnable = join("\n",
246                  map {                  map {
247                          $introspect->{runnable}->{$_}++;                          $introspect->{runnable}->{$_} = {};
248                          my $short = $_;                          my $short = $_;
249                          $short =~ s{_as_(?:markup|data|sponge)$}{};                          $short =~ s{_as_(?:markup|data|sponge)$}{};
250                          qq|<a target="$class" href="/$class/$_" title="/$class/$_">$short</a>|                          qq|<a target="$class" href="/$class/$_" title="/$class/$_">$short</a>|
Legend:
Removed from v.732  
changed lines
  Added in v.733
  ViewVC Help
Powered by ViewVC 1.1.26