/[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 66 by dpavlin, Wed Jul 9 12:08:07 2008 UTC revision 1133 by dpavlin, Tue Jun 30 15:10:55 2009 UTC
# Line 2  package Frey::Introspect; Line 2  package Frey::Introspect;
2    
3  use Moose;  use Moose;
4  use Carp;  use Carp;
5  use Class::MOP;  #use Moose::Meta::Role;
6  use Moose::Meta::Role;  #use Moose::Meta::Class;
 use Moose::Meta::Class;  
 use Scalar::Util qw/blessed/;  
7  use Data::Dump qw/dump/;  use Data::Dump qw/dump/;
8  use File::Slurp;  use File::Slurp;
9  use List::Util;  use List::Util;
10    
11  use Continuity::Widget::DomNode;  use PPI;
12  use lib 'lib';  use PPI::HTML;
   
 extends 'Frey';  
13    
14  has 'package' => (  use lib 'lib';
15          is => 'rw',  use Frey::Pod;
         isa => 'Str',  
         required => 1,  
 );  
16    
17  has 'path' => (  extends 'Frey::PPI';
18          is => 'rw',  with 'Frey::Web', 'Frey::Storage';
 );  
19    
20  =head2 load_package  =head1 DESCRIPTION
21    
22    my ( $class, $meta, $is_role ) = $o->load_package( 'Some::Package' );  Provide introspection on any perl class installed on system
23    
24  =cut  =cut
25    
26  sub load_package {  has 'class' => (
27          my ( $self ) = @_;          is => 'rw',
28            isa => 'Str',
29          my $package = $self->package;          required => 1,
30    );
         #intercept role application so we can accurately generate  
         #method and attribute information for the parent class.  
         #this is fragile, but there is not better way that i am aware of  
         my $rmeta = Moose::Meta::Role->meta;  
         $rmeta->make_mutable if $rmeta->is_immutable;  
         my $original_apply = $rmeta->get_method("apply")->body;  
         $rmeta->remove_method("apply");  
         my @roles_to_apply;  
         $rmeta->add_method("apply", sub{push(@roles_to_apply, [@_])});  
         #load the package with the hacked Moose::Meta::Role  
   
         #eval { Class::MOP::load_class($package); };  
         #confess "Failed to load package ${package} $@" if $@;  
         Class::MOP::load_class($package);  
   
         my $meta = $package->meta;  
   
         my ($class, $is_role);  
         if($package->meta->isa('Moose::Meta::Role')){  
                 $is_role = 1;  
                 # we need to apply the role to a class to be able to properly introspect it  
                 $class = Moose::Meta::Class->create_anon_class;  
                 $original_apply->($meta, $class);  
         } else {  
                 #roles don't have superclasses ...  
                 $class = $meta;  
         }  
         return ( $class, $meta, $is_role );  
 }  
31    
32  =head2 joose  =head2 joose
33    
34    my $js = $o->joose( 'Some::Package' );    my $js = $o->joose;
35    
36  =cut  =cut
37    
38  sub joose {  sub joose {
39          my ($self) = @_;          my ($self) = @_;
40    
41          my ( $class, $meta, $is_role ) = $self->load_package;          my ( $meta, $is_role ) = $self->class_meta;
42    
43          if ( ! $is_role ) {          if ( ! $is_role ) {
44                  my @superclasses = map{ $_->meta->name }                  my @superclasses = map{ $_->meta->name }
45                          grep { $_ ne 'Moose::Object' } $meta->superclasses;                          grep { $_ ne 'Moose::Object' } $meta->superclasses;
46                  warn "superclasses ",dump( @superclasses );                  warn "superclasses ",dump( @superclasses ) if $self->debug;
47          }          }
48    
49          my $out;          my $out;
50    
51          my ( $m, $c ) = split(/::/, $class->name, 2);          my ( $m, $c ) = split(/::/, $self->class, 2);
52          my $filename = $m . '.' . ( $c ? "$c." : '' ) . 'js';          my $filename = $m . '.' . ( $c ? "$c." : '' ) . 'js';
53    
54            $c ||= '';
55    
56          $out .= "Module(\"$m\", function (m) {\n\tClass(\"$c\", {\n\t\thas: {\n";          $out .= "Module(\"$m\", function (m) {\n\tClass(\"$c\", {\n\t\thas: {\n";
57    
58          foreach ( $class->get_attribute_list ) {          foreach ( $meta->get_attribute_list ) {
59                  $out .= "\t\t\t$_: {\n";                  $out .= "\t\t\t$_: {\n";
60    
61                  my $attr = $class->get_attribute($_);                  my $attr = $meta->get_attribute($_);
62                  my $is = $attr->_is_metadata;                  my $is = eval { $attr->_is_metadata; };
63                    return if $@;
64    
65                  $out .= "\t\t\t\tis: \"$is\",\n" if defined $is;                  $out .= "\t\t\t\tis: \"$is\",\n" if defined $is;
66                  $out .= "\t\t\t\tlazy: true,\n" if $attr->is_lazy;                  $out .= "\t\t\t\tlazy: true,\n" if $attr->is_lazy;
67                  $out .= "\t\t\t\trequired: true,\n" if $attr->is_required;                  $out .= "\t\t\t\trequired: true,\n" if $attr->is_required;
# Line 118  sub joose { Line 85  sub joose {
85          $out .= "\t\t},\n\t\tmeta: Frey.HTML,          $out .= "\t\t},\n\t\tmeta: Frey.HTML,
86                  classMethods: {                  classMethods: {
87                          renderHTML: function () {                          renderHTML: function () {
88                                  return new Joose.SimpleRequest().getText(\"/~/" . $self->package . "\")                                  return new Joose.SimpleRequest().getText(\"/" . $self->class . "\")
89                          },\n";                          },\n";
90    
91          $out .= "\t\t},\n";          $out .= "\t\t},\n";
# Line 128  sub joose { Line 95  sub joose {
95          $out =~ s/,\n$/\n/;          $out =~ s/,\n$/\n/;
96          $out .= "});\n";          $out .= "});\n";
97    
98          $out .= "\nconsole.log( 'loaded " . $class->name . " from $filename' );\n";          $out .= "\nconsole.log( 'loaded " . $self->class . " from $filename' );\n";
   
         warn $class->dump(2);  
99    
100          warn "method_list = ",dump( $class->get_method_list );          warn "method_list = ",dump( $meta->get_method_list ) if $self->debug;
         warn dump( map{ $class->get_method($_)->name } sort $class->get_method_list );  
101    
102  #       print $out;  #       print $out;
103          my $path = "static/blib/$filename";          my $path = "static/blib/$filename";
104          write_file( $path, $out );          write_file( $path, $out );
105          warn "# created $path\n";          warn "# created $path\n";
         $self->path( $path );  
106    
107          return $out;          return $out;
108  }  }
109    
110  =head2 methods  sub as_markup {
111            my ( $self ) = @_;
112    
113    my @methods = $o->methods;          my ( $meta, $is_role ) = $self->class_meta;
114    
115  =cut          my $class = $self->class;
116            $self->title( $class );
117    
118  sub methods {          my $introspect_path = "var/introspect/$class.yaml";
119          my $self = shift;          $self->mkbasepath( $introspect_path );
120            my $introspect; # FIXME update with = $self->load( $introspect_path );
121    
122          my ( $class, $meta, $is_role ) = $self->load_package;          my ( $superclasses, $roles ) = ( '<b>Role</b>', '' );
123            if ( ! $is_role ) {
124                    if ( $meta->superclasses ) {
125                            $superclasses = 'Superclasses: ' .
126                                    join(', ',
127                                            map {
128                                                    my $name = $_->meta->name;
129                                                    $introspect->{superclass}->{$name} = {};
130    
131                                                    qq|<a target="$name" href="/$name" title="introspect $name">$name</a>| .
132                                                    $self->dropdown( qq|<sup>?</sup>|, $_->meta )
133                                            }
134                                            #grep { $_ ne 'Moose::Object' }
135                                            $meta->superclasses
136                                    );
137                    }
138            }
139    
140          my $attr;          my $method_from_role;
141          $attr->{$_}++ foreach $class->get_attribute_list;          my $attribute_from_role;
         my @methods = grep { ! defined($attr->{$_}) } $class->get_method_list;  
         warn "# methods = ",dump( @methods );  
142    
143          return @methods;          if ( $meta->can('roles') ) {
144  }                  my $role_nr = 1;
145                    $roles = join(' ',
146                            grep { ! m/\Q$class\E/ }        # skip me
147                            map {
148                                    my $r = '';
149                                    foreach my $name ( split(/\|/, $_->name) ) {
150                                            $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    
154                                            $r .=
155                                              qq|<a target="$name" href="/$name" title="introspect $name">$name</a>|
156            #                               . qq|<sup>| . $self->dropdown( $role_nr++, $name->meta ) . qq|</sup>|
157                                            . $self->dropdown(
158                                                    qq|<sup>| . $role_nr++ . qq|</sup>|,
159                                                    $name->meta
160                                            )
161                                            ;
162                                    }
163                                    $r;
164                            }
165                            $meta->calculate_all_roles
166                    );
167                    $roles = qq|with roles: $roles| if $roles;
168            }
169            warn "# method_from_role ",dump( $method_from_role );
170    
171  =head1 OUTPUT GENERATION          my @methods;
172            @methods = map {
173                    my $name = $_;
174                    if ( $method_from_role->{$name} ) {
175                            my ( $role_name, $nr ) = each %{ $method_from_role->{$name} };
176                            $introspect->{methods}->{$name}->{role} = $role_name;
177                            $name .= qq|<sup title="$role_name">$nr</sup>|;
178                    } else {
179                            $introspect->{methods}->{$name} = {};
180                    }
181                    qq|<td class="m">$name</td>|
182            } sort {
183                    lc($a) cmp lc($b)      
184            } $self->class_methods( $class );
185    
186            my @attributes;
187            if ( $meta->get_attribute_list ) {
188                    @attributes = map {
189                            my $name = $_;
190                            $introspect->{attribute}->{$name} = {};
191                            my $html_name = $name;
192                            my $attr = $meta->get_attribute($name);
193                            confess "$class attribute $name isn't blessed ",dump( $attr ) unless blessed $attr;
194                            warn "## attr $name ref ",ref( $attr ) if $self->debug;
195    
196                            my ( $title, $properties ) = ( '', '' );
197                            if ( $attr->can('is_required') && $attr->is_required ) {
198                                    ( $html_name, $title ) = ( "<b>$name</b>", ' title="required"' );
199                                    $introspect->{attribute}->{$name}->{required} = 1;
200                            }
201    
202  =head2 html                          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/ ) {
203                                    my $getter;
204                                    
205                                    $getter = $check;
206                                    $getter =~ s/^has_//;
207                                    
208                                    if ( $attr->can($check) && $attr->$check ) {
209                                            $properties .= $check;
210                                            # we need our dump here instead of $attr->$getter->dump because default can return scalar
211                                            my $v = $attr->$getter;
212                                            $properties .= ref($v)
213                                                    ? $self->dropdown( qq|<sup>?</sup>|, $attr->$getter )
214                                                    : qq| <code>$v</code>|
215                                                    ;
216                                    }
217                                    $properties .= ' ';
218                            }
219                            my $type = $attr->can('has_type_constraint') && $attr->has_type_constraint ? $attr->type_constraint->name : '';
220    
221    $o->html( $request );                          if ( $attribute_from_role->{$name} ) {
222                                    my ( $role_name, $nr ) = each %{ $attribute_from_role->{$name} };
223                                    $name .= qq|<sup title="$role_name">$nr</sup>|;
224                            }
225    
226  =cut                          if ( my $doc = eval { $attr->documentation } ) {
227                                    $properties = qq|
228                                            $properties
229                                            <span class="documentation">$doc</span>
230                                    |;
231                                    $self->add_css(qq|
232                                            span.documentation {
233                                                    background: #eee;
234                                                    padding: 0.25em;
235                                                    float: left;
236                                                    clear: left;
237                                            }
238                                    |);
239                                    $introspect->{action}->{$name}->{documentation} = $doc;
240                            }
241    
242  our @javascript = ( qw'                          qq|<td class="a">$html_name</td><td class="t">$type</td><td class="p">$properties</td>|
243  ../lib/Joose.js                  } sort $meta->get_attribute_list
244  ');          }
245    
246  sub html {          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>|;
247          my ( $self, $request ) = @_;          while ( @methods || @attributes ) {
248                    my ($m,$a) = ( shift @methods, shift @attributes );
249                    $m ||= '<td></td>';
250                    $a ||= '<td></td>';
251                    $table .= qq|<tr>$m$a</tr>|;
252            }
253            $table .= qq|</table>|;
254    
255          while (1) {          my $path = $self->class_path( $class );
256    
257                  my $js = Continuity::Widget::DomNode->create(          my ( $pod_toc, $pod ) = Frey::Pod->new( class => $class, request_url => $self->request_url )->as_markup;
258                          map {          return $pod_toc . $pod if $path =~ m{\.pod};
                                 ( script => { type => 'text/javascript', src => $_ } )  
                         } @javascript  
                 )->to_string;  
   
                 $js .= << '__END_OF_JS__';  
 <script type="text/javascript">  
 joose.loadComponents("../lib")  
259    
260  function $(id) {          warn "# ", $pod_toc ? 'toc' : '', ' ', $pod ? 'pod' : '';
         return document.getElementById(id)  
 }  
261    
262  </script>          my $Document = PPI::Document->new( $path );
263  __END_OF_JS__  
264            # Create a reusable syntax highlighter
265            my $Highlight = PPI::HTML->new(
266                    line_numbers => 1,
267    #               page => 1,
268    #               colors => {
269    #                       line_number => '#CCCCCC',
270    #                       number      => '#990000',
271    #               },
272            );
273    
274            # Spit out the HTML
275            my $source = $Highlight->html( $Document );
276    
277            $source =~ s{(<span.*?line_number.*>\s*)(\d+)(:\s*</span>)}{$1<a target="editor" href="/editor+$path+$2">$2</a>$3}g;
278    
279            # strip page html
280    #       $source =~ s{^.*<body[^>]+>}{}s;
281    #       $source =~ s{</body.*$}{}s;
282    
283            my $runnable = join("</dd><dd>",
284                    map {
285                            $introspect->{runnable}->{$_} = {};
286                            my $short = $_;
287                            $short =~ s{_as_(?:markup|data|sponge)$}{};
288                            qq|<a target="$class" href="/$class/$_" title="/$class/$_">$short</a>|
289                    } $self->class_runnable( $class )
290            );
291            $runnable = "<dt>runnable</dt><dd>$runnable</dd>" if $runnable;
292    
293            my $has_tests = '';
294            my @tests = sort { lc($a) cmp lc($b) } grep { defined $_ } $self->has_tests;
295            if ( @tests ) {
296                    $has_tests
297                            = qq|<dt>test|
298                            . ( $#tests > 0 ? 's' : '' )
299                            . qq|<dt><dd>|
300                            . join("</dd><dd>", map {
301                                    qq|<a target="$class" href="/Frey::Test::Runner/as_markup?test=$_">$_</a>|
302                            } @tests )
303                            . qq|</dd>|
304                            ;
305                    $introspect->{tests} = [ @tests ],
306            }
307    
308                  warn "# >>> js\n$js\n" if $self->debug;          my $includes = '';
309            if ( my $inc = $self->includes ) {
310                    $introspect->{includes} = $inc;
311                    foreach my $type ( keys %$inc ) {
312                            $includes
313                                    .= ucfirst($type)
314                                    . qq|: |
315                                    . join("\n",
316                                            map {
317                                                    qq|<a target="$_" href="/$_">$_</a>|
318                                            } @{
319                                                    $inc->{$type}
320                                            }
321                                    )
322                                    ;
323                    }
324            }
325    
326                  my ( $class, $meta, $is_role ) = $self->load_package();          $self->store( $introspect_path, $introspect );
327    
328                  my $methods;          $self->add_css(qq|
329                  if ( $class->can('meta') ) {                  .frey-introspect-right {
330                          $methods = Continuity::Widget::DomNode->create(                          position: fixed;
331                                  ul => [                          top: 1em;
332                                          map { (                          right: 1em;
333                                                  li => [ a => { href => '/~/' . $self->package . '/' . $_ } => [ $_ ] ]                          z-index: 10;
334                                          ) } $self->methods                          background: #ffc;
335                                  ]                          padding: 0.5em;
336                          )->to_string;                          width: 20%;
337                  } else {                          font-size: 80%;
338                          $methods = '<b>not introspectable</b>';                  }
339                    .frey-introspect-right dl dd {
340                            margin-left: 1em;
341                  }                  }
342    
343                  my $attributes = Continuity::Widget::DomNode->create(                  /* fix pod */
344                          ul => [                  .frey-introspect-right dd ul {
345                                  map {                          padding-left: 0;
346                                          my $attr = $class->get_attribute($_);                  }
347                                          warn "## $_ ", $attr->is_required ? 'required' : 'optional';                  .frey-introspect-right dl ul > li {
348                                          ( li => [ a => { href => '/~/' . $self->package . '/' . $_ } => [ $_ ], ( $attr->is_required ? ' <b>required</b>' : '' ) ] )                          list-style: none;
349                                  } $class->get_attribute_list                  }
350                          ],          |);
                 )->to_string;  
   
                 my $doc = Continuity::Widget::DomNode->create(  
                         html => [  
                                 head => [  
                                         link => { rel=>"stylesheet", href=>"/static/app.css", type=>"text/css", media=>"screen" },  
                                         $js,  
                                         title => [ 'Introspect ', $self->package ],  
                                 ],  
                                 body => [  
                                         h1 => [ $self->package ],  
                                         h2 => [ 'Methods' ],  
                                         $methods,  
                                         h2 => [ 'Atrributes' ],  
                                         $attributes,  
                                 ],  
                         ]  
                 );  
351    
352                  $request->print($doc->to_string);          my $has_pod = qq|
353                  warn "# >>> html\n", $doc->to_string, "\n";                  <dt><a href="#___top" title="Skip to POD">pod</a></dt>
354                  $request->next;                  <dd>$pod_toc</dd>
355          }          | if $pod_toc;
356          warn "# exit html";  
357            my $has_source = qq|
358                    <dt><a href="#source" title="Skip to source">source</a></dt>
359            | if $source;
360    
361            my $right = qq|
362                    <dl>
363                    $runnable
364                    $has_tests
365                    $has_pod
366                    $has_source
367                    </dl>
368            |;
369    
370    
371            return
372                    qq|
373                            <h1>$class</h1>
374                            <div class="frey-introspect">
375                                    $superclasses $roles
376                                    <br>$includes
377                            </div>
378                            <div class="frey-introspect-right">
379                                    $right
380                            </div>
381                            $table
382                            $pod
383                            </div>
384    
385                            <h1>Source</h1><a name="source"></a>
386                            <div class="frey-source">$source</div>
387                    |
388                    ;
389  }  }
390    
391  =head1 SEE ALSO  =head1 SEE ALSO
# Line 254  L<MooseX::AutoDoc> on which this code is Line 394  L<MooseX::AutoDoc> on which this code is
394    
395  =cut  =cut
396    
397    __PACKAGE__->meta->make_immutable;
398    no Moose;
399    
400  1;  1;

Legend:
Removed from v.66  
changed lines
  Added in v.1133

  ViewVC Help
Powered by ViewVC 1.1.26