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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 943 - (hide annotations)
Tue Jan 6 14:50:30 2009 UTC (15 years, 4 months ago) by dpavlin
File size: 8613 byte(s)
added display of included classes and small re-design
1 dpavlin 49 package Frey::Introspect;
2    
3     use Moose;
4     use Carp;
5 dpavlin 100 #use Moose::Meta::Role;
6     #use Moose::Meta::Class;
7 dpavlin 49 use Data::Dump qw/dump/;
8     use File::Slurp;
9 dpavlin 51 use List::Util;
10 dpavlin 49
11 dpavlin 380 use PPI;
12     use PPI::HTML;
13    
14 dpavlin 733 use lib 'lib';
15 dpavlin 631 use Frey::Pod;
16    
17 dpavlin 496 extends 'Frey::PPI';
18 dpavlin 100 with 'Frey::Web';
19 dpavlin 602 with 'Frey::Storage';
20 dpavlin 49
21 dpavlin 943 =head1 DESCRIPTION
22    
23     Provide introspection on any perl class installed on system
24    
25     =cut
26    
27 dpavlin 270 has 'class' => (
28 dpavlin 49 is => 'rw',
29     isa => 'Str',
30     required => 1,
31     );
32    
33 dpavlin 53 =head2 joose
34    
35 dpavlin 137 my $js = $o->joose;
36 dpavlin 53
37     =cut
38    
39     sub joose {
40     my ($self) = @_;
41    
42 dpavlin 308 my ( $meta, $is_role ) = $self->class_meta;
43 dpavlin 53
44     if ( ! $is_role ) {
45 dpavlin 50 my @superclasses = map{ $_->meta->name }
46     grep { $_ ne 'Moose::Object' } $meta->superclasses;
47 dpavlin 100 warn "superclasses ",dump( @superclasses ) if $self->debug;
48 dpavlin 50 }
49 dpavlin 49
50     my $out;
51    
52 dpavlin 270 my ( $m, $c ) = split(/::/, $self->class, 2);
53 dpavlin 51 my $filename = $m . '.' . ( $c ? "$c." : '' ) . 'js';
54 dpavlin 49
55 dpavlin 137 $c ||= '';
56    
57 dpavlin 49 $out .= "Module(\"$m\", function (m) {\n\tClass(\"$c\", {\n\t\thas: {\n";
58    
59 dpavlin 137 foreach ( $meta->get_attribute_list ) {
60 dpavlin 49 $out .= "\t\t\t$_: {\n";
61    
62 dpavlin 137 my $attr = $meta->get_attribute($_);
63 dpavlin 50 my $is = $attr->_is_metadata;
64     $out .= "\t\t\t\tis: \"$is\",\n" if defined $is;
65     $out .= "\t\t\t\tlazy: true,\n" if $attr->is_lazy;
66     $out .= "\t\t\t\trequired: true,\n" if $attr->is_required;
67     $out .= "\t\t\t\tinit: \"" . $attr->init_arg . "\",\n" if $attr->init_arg; # FIXME
68    
69     if( defined(my $isa = $attr->_isa_metadata) ){
70     if( blessed $isa ){
71     while( blessed $isa ){
72     $isa = $isa->name;
73     }
74     }
75     $isa =~ s/\s+\|\s+undef//gi;
76     $out .= "\t\t\t\tisa: Moose.$isa,\n";
77     }
78    
79    
80 dpavlin 49 $out .= "\t\t\t},\n";
81    
82     }
83    
84 dpavlin 51 $out .= "\t\t},\n\t\tmeta: Frey.HTML,
85     classMethods: {
86     renderHTML: function () {
87 dpavlin 292 return new Joose.SimpleRequest().getText(\"/" . $self->class . "\")
88 dpavlin 51 },\n";
89    
90 dpavlin 49 $out .= "\t\t},\n";
91    
92     $out .= "\t}),\n";
93 dpavlin 50
94     $out =~ s/,\n$/\n/;
95 dpavlin 49 $out .= "});\n";
96    
97 dpavlin 270 $out .= "\nconsole.log( 'loaded " . $self->class . " from $filename' );\n";
98 dpavlin 49
99 dpavlin 137 warn "method_list = ",dump( $meta->get_method_list ) if $self->debug;
100 dpavlin 49
101 dpavlin 51 # print $out;
102 dpavlin 49 my $path = "static/blib/$filename";
103     write_file( $path, $out );
104     warn "# created $path\n";
105 dpavlin 51
106     return $out;
107 dpavlin 49 }
108    
109 dpavlin 455 sub as_markup {
110 dpavlin 269 my ( $self ) = @_;
111 dpavlin 53
112 dpavlin 160 $self->add_head( 'static/introspect.css' );
113 dpavlin 139
114 dpavlin 308 my ( $meta, $is_role ) = $self->class_meta;
115 dpavlin 53
116 dpavlin 270 my $class = $self->class;
117 dpavlin 802 $self->title( $class );
118 dpavlin 54
119 dpavlin 602 my $introspect_path = "var/introspect/$class.yaml";
120     $self->mkbasepath( $introspect_path );
121 dpavlin 735 my $introspect; # FIXME update with = $self->load( $introspect_path );
122 dpavlin 602
123 dpavlin 310 my ( $superclasses, $roles ) = ( '<b>Role</b>', '' );
124     if ( ! $is_role ) {
125     if ( $meta->superclasses ) {
126     $superclasses = 'Superclasses: ' .
127     join(', ',
128     map {
129     my $name = $_->meta->name;
130 dpavlin 733 $introspect->{superclass}->{$name} = {};
131 dpavlin 943
132     qq|<a target="$name" href="/$name" title="introspect $name">$name</a>| .
133     $self->dropdown( qq|<sup>?</sup>|, $_->meta )
134 dpavlin 310 }
135     #grep { $_ ne 'Moose::Object' }
136     $meta->superclasses
137     );
138     }
139     }
140    
141 dpavlin 733 my $method_from_role;
142     my $attribute_from_role;
143 dpavlin 310
144     if ( $meta->can('roles') ) {
145     my $role_nr = 1;
146     $roles = join(' ',
147     grep { ! m/\Q$class\E/ } # skip me
148     map {
149     my $name = $_->name;
150 dpavlin 733 $introspect->{roles}->{$name} = {};
151     $method_from_role->{ $_ }->{$name} = $role_nr foreach $_->get_method_list;
152     $attribute_from_role->{ $_ }->{$name} = $role_nr foreach $_->get_attribute_list;
153 dpavlin 943
154     qq|<a target="$name" href="/$name" title="introspect $name">$name</a>|
155     # . qq|<sup>| . $self->dropdown( $role_nr++, $name->meta ) . qq|</sup>|
156     . $self->dropdown(
157     qq|<sup>| . $role_nr++ . qq|</sup>|,
158     $name->meta
159     )
160     ;
161 dpavlin 310 }
162     $meta->calculate_all_roles
163     );
164 dpavlin 943 $roles = qq|with roles: $roles| if $roles;
165 dpavlin 310 }
166 dpavlin 733 warn "# method_from_role ",dump( $method_from_role );
167 dpavlin 310
168 dpavlin 269 my @methods;
169 dpavlin 310 @methods = map {
170 dpavlin 313 my $name = $_;
171 dpavlin 733 if ( $method_from_role->{$name} ) {
172     my ( $role_name, $nr ) = each %{ $method_from_role->{$name} };
173     $introspect->{methods}->{$name}->{role} = $role_name;
174 dpavlin 313 $name .= qq|<sup title="$role_name">$nr</sup>|;
175 dpavlin 733 } else {
176     $introspect->{methods}->{$name} = {};
177 dpavlin 310 }
178 dpavlin 313 qq|<td class="m">$name</td>|
179 dpavlin 884 } sort {
180     lc($a) cmp lc($b)
181     } $self->class_methods( $class );
182 dpavlin 53
183 dpavlin 269 my @attributes;
184     if ( $meta->get_attribute_list ) {
185 dpavlin 409 @attributes = map {
186 dpavlin 313 my $name = $_;
187 dpavlin 733 $introspect->{attribute}->{$name} = {};
188 dpavlin 582 my $html_name = $name;
189 dpavlin 313 my $attr = $meta->get_attribute($name);
190 dpavlin 416 confess "$class attribute $name isn't blessed ",dump( $attr ) unless blessed $attr;
191 dpavlin 393 warn "## attr $name ref ",ref( $attr ) if $self->debug;
192 dpavlin 582
193     my ( $title, $properties ) = ( '', '' );
194 dpavlin 733 if ( $attr->can('is_required') && $attr->is_required ) {
195     ( $html_name, $title ) = ( "<b>$name</b>", ' title="required"' );
196     $introspect->{attribute}->{$name}->{required} = 1;
197     }
198 dpavlin 582
199     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/ ) {
200 dpavlin 269 my $getter;
201    
202     $getter = $check;
203     $getter =~ s/^has_//;
204    
205 dpavlin 416 if ( $attr->can($check) && $attr->$check ) {
206 dpavlin 943 $properties .= $check;
207     # we need our dump here instead of $attr->$getter->dump because default can return scalar
208     my $v = $attr->$getter;
209     $properties .= ref($v)
210     ? $self->dropdown( qq|<sup>?</sup>|, $attr->$getter )
211     : qq| <code>$v</code>|
212     ;
213 dpavlin 197 }
214 dpavlin 582 $properties .= ' ';
215 dpavlin 269 }
216 dpavlin 416 my $type = $attr->can('has_type_constraint') && $attr->has_type_constraint ? $attr->type_constraint->name : '';
217 dpavlin 313
218 dpavlin 733 if ( $attribute_from_role->{$name} ) {
219     my ( $role_name, $nr ) = each %{ $attribute_from_role->{$name} };
220 dpavlin 313 $name .= qq|<sup title="$role_name">$nr</sup>|;
221     }
222    
223 dpavlin 735 if ( my $doc = eval { $attr->documentation } ) {
224     $properties = qq|
225     $properties
226     <span class="documentation">$doc</span>
227     |;
228     $self->add_css(qq|
229     span.documentation {
230     background: #eee;
231     padding: 0.25em;
232 dpavlin 736 float: left;
233     clear: left;
234 dpavlin 735 }
235     |);
236     $introspect->{action}->{$name}->{documentation} = $doc;
237     }
238 dpavlin 582
239 dpavlin 943 qq|<td class="a">$html_name</td><td class="t">$type</td><td class="p">$properties</td>|
240 dpavlin 727 } sort $meta->get_attribute_list
241 dpavlin 269 }
242 dpavlin 54
243 dpavlin 312 my $table = qq|<table class="frey-introspect"><tr><th class="m">Methods</th><th class="a">Attributes</th><th>Type</th><th class="p">Properties</th></tr>|;
244 dpavlin 269 while ( @methods || @attributes ) {
245     my ($m,$a) = ( shift @methods, shift @attributes );
246     $m ||= '<td></td>';
247     $a ||= '<td></td>';
248     $table .= qq|<tr>$m$a</tr>|;
249     }
250     $table .= qq|</table>|;
251    
252 dpavlin 688 my $path = $self->class_path( $class );
253    
254 dpavlin 635 my $pod = Frey::Pod->new( class => $class, request_url => $self->request_url )->as_markup;
255 dpavlin 688 return $pod if $path =~ m{\.pod};
256 dpavlin 134
257 dpavlin 406 my $Document = PPI::Document->new( $path );
258 dpavlin 380
259     # Create a reusable syntax highlighter
260     my $Highlight = PPI::HTML->new(
261 dpavlin 406 line_numbers => 1,
262 dpavlin 380 # page => 1,
263     # colors => {
264     # line_number => '#CCCCCC',
265     # number => '#990000',
266     # },
267     );
268    
269     # Spit out the HTML
270     my $source = $Highlight->html( $Document );
271    
272 dpavlin 407 $source =~ s{(<span.*?line_number.*>\s*)(\d+)(:\s*</span>)}{$1<a target="editor" href="/editor+$path+$2">$2</a>$3}g;
273 dpavlin 406
274     # strip page html
275 dpavlin 380 # $source =~ s{^.*<body[^>]+>}{}s;
276     # $source =~ s{</body.*$}{}s;
277    
278 dpavlin 409 my $runnable = join("\n",
279 dpavlin 458 map {
280 dpavlin 733 $introspect->{runnable}->{$_} = {};
281 dpavlin 662 my $short = $_;
282     $short =~ s{_as_(?:markup|data|sponge)$}{};
283     qq|<a target="$class" href="/$class/$_" title="/$class/$_">$short</a>|
284 dpavlin 458 } $self->class_runnable( $class )
285 dpavlin 409 );
286 dpavlin 943 $runnable = "Runnable: $runnable" if $runnable;
287 dpavlin 128
288 dpavlin 496 my $has_tests = '';
289 dpavlin 635 my @tests = grep { defined $_ } $self->has_tests;
290     if ( @tests ) {
291 dpavlin 496 $has_tests =
292 dpavlin 943 'Test' . ( $#tests > 0 ? 's' : '' ) . ': ' .
293 dpavlin 496 join("\n", map {
294 dpavlin 534 qq|<a target="$class" href="/Frey::Test::Runner/as_markup?test=$_">$_</a>|
295 dpavlin 496 } @tests );
296 dpavlin 943 $introspect->{tests} = [ @tests ],
297 dpavlin 496 }
298    
299 dpavlin 943 my $includes = '';
300     if ( my $inc = $self->includes ) {
301     $introspect->{includes} = $inc;
302     foreach my $type ( keys %$inc ) {
303     $includes
304     .= ucfirst($type)
305     . qq|: |
306     . join("\n",
307     map {
308     qq|<a target="$_" href="/$_">$_</a>|
309     } @{
310     $inc->{$type}
311     }
312     )
313     ;
314     }
315     }
316    
317     $self->store( $introspect_path, $introspect );
318    
319 dpavlin 418 return join("\n",
320     qq|<h1>$class</h1>|,
321 dpavlin 943 qq|<div class="frey-introspect">
322     $superclasses $roles
323     <br>
324     $includes
325     <br>
326     $runnable
327     |,
328 dpavlin 717 $has_tests,
329 dpavlin 418 $pod ? qq|<a class="frey-skip" href="#___top" title="Skip to POD" >pod</a>| : '',
330     $source ? qq|<a class="frey-skip" href="#source" title="Skip to source" >source</a>| : '',
331     qq|$table\n$pod\n</div>\n|,
332     qq|<h1>Source</h1><a name="source"></a><div class="frey-source">$source</div>|,
333     );
334 dpavlin 53 }
335    
336 dpavlin 49 =head1 SEE ALSO
337    
338     L<MooseX::AutoDoc> on which this code is based
339    
340     =cut
341    
342     1;

  ViewVC Help
Powered by ViewVC 1.1.26