lib/Frey/Introspect.pm

package Frey::Introspect;

use Moose;
use Carp;
#use Moose::Meta::Role;
#use Moose::Meta::Class;
use Data::Dump qw/dump/;
use File::Slurp;
use List::Util;

use PPI;
use PPI::HTML;

use lib 'lib';

extends 'Frey::PPI';
with 'Frey::Web';

has 'class' => (
        is => 'rw',
        isa => 'Str',
        required => 1,
);

=head2 joose

  my $js = $o->joose;

=cut

sub joose {
        my ($self) = @_;

        my ( $meta, $is_role ) = $self->class_meta;

        if ( ! $is_role ) {
                my @superclasses = map{ $_->meta->name }
                        grep { $_ ne 'Moose::Object' } $meta->superclasses;
                warn "superclasses ",dump( @superclasses ) if $self->debug;
        }

        my $out;

        my ( $m, $c ) = split(/::/, $self->class, 2);
        my $filename = $m . '.' . ( $c ? "$c." : '' ) . 'js';

        $c ||= '';

        $out .= "Module(\"$m\", function (m) {\n\tClass(\"$c\", {\n\t\thas: {\n";

        foreach ( $meta->get_attribute_list ) {
                $out .= "\t\t\t$_: {\n";

                my $attr = $meta->get_attribute($_);
                my $is = $attr->_is_metadata;
                $out .= "\t\t\t\tis: \"$is\",\n" if defined $is;
                $out .= "\t\t\t\tlazy: true,\n" if $attr->is_lazy;
                $out .= "\t\t\t\trequired: true,\n" if $attr->is_required;
                $out .= "\t\t\t\tinit: \"" . $attr->init_arg . "\",\n" if $attr->init_arg;      # FIXME

                if( defined(my $isa = $attr->_isa_metadata) ){
                        if( blessed $isa ){
                                while( blessed $isa ){
                                        $isa = $isa->name;
                                }
                        }
                        $isa =~ s/\s+\|\s+undef//gi;
                        $out .= "\t\t\t\tisa: Moose.$isa,\n";
                }


                $out .= "\t\t\t},\n";

        }

        $out .= "\t\t},\n\t\tmeta: Frey.HTML,
                classMethods: {
                        renderHTML: function () {
                                return new Joose.SimpleRequest().getText(\"/" . $self->class . "\")
                        },\n";

        $out .= "\t\t},\n";

        $out .= "\t}),\n";

        $out =~ s/,\n$/\n/;
        $out .= "});\n";

        $out .= "\nconsole.log( 'loaded " . $self->class . " from $filename' );\n";

        warn "method_list = ",dump( $meta->get_method_list ) if $self->debug;

#       print $out;
        my $path = "static/blib/$filename";
        write_file( $path, $out );
        warn "# created $path\n";

        return $out;
}

sub as_markup {
        my ( $self ) = @_;

        $self->add_head( 'static/introspect.css' );

        my ( $meta, $is_role ) = $self->class_meta;

        my $class = $self->class;

        my ( $superclasses, $roles ) = ( '<b>Role</b>', '' );
        if ( ! $is_role ) {
                if ( $meta->superclasses ) {
                        $superclasses = 'Superclasses: ' .
                                join(', ',
                                        map {
                                                my $name = $_->meta->name;
                                                $self->dropdown( $name, $_->meta )
                                        }
                                        #grep { $_ ne 'Moose::Object' }
                                        $meta->superclasses
                                );
                }
        }

        my $role_method;
        my $role_attribute;

        if ( $meta->can('roles') ) {
                my $role_nr = 1;
                $roles = join(' ',
                        grep { ! m/\Q$class\E/ }        # skip me
                        map {
                                my $name = $_->name;
                                $role_method->{    $_ }->{$name} = $role_nr foreach $_->get_method_list;
                                $role_attribute->{ $_ }->{$name} = $role_nr foreach $_->get_attribute_list;
                                $self->dropdown( $name, $name->meta ) . qq|<sup>| . $role_nr++ . qq|</sup>|;
                        }
                        $meta->calculate_all_roles
                );
                $roles = qq| with roles: $roles| if $roles;
        }
        warn "# role_method ",dump( $role_method );

        my @methods;
        @methods = map {
                my $name = $_;
                if ( $role_method->{$name} ) {
                        my ( $role_name, $nr ) = each %{ $role_method->{$name} };
                        $name .= qq|<sup title="$role_name">$nr</sup>|;
                }
                qq|<td class="m">$name</td>|
        } $self->class_methods( $class );

        my @attributes;
        if ( $meta->get_attribute_list ) {
                @attributes = map {
                        my $name = $_;
                        my $html_name = $name;
                        my $attr = $meta->get_attribute($name);
                        confess "$class attribute $name isn't blessed ",dump( $attr ) unless blessed $attr;
                        warn "## attr $name ref ",ref( $attr ) if $self->debug;

                        my ( $title, $properties ) = ( '', '' );
                        ( $html_name, $title ) = ( "<b>$name</b>", ' title="required"' )
                                if $attr->can('is_required') && $attr->is_required;

                        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/ ) {
                                my $getter;
                                
                                $getter = $check;
                                $getter =~ s/^has_//;
                                
                                if ( $attr->can($check) && $attr->$check ) {
                                        if ( $getter eq $check ) {
                                                $properties .= "$check";
                                        } else {
                                                # we need our dump here instead of $attr->$getter->dump because default can return scalar
                                                $properties .= $self->dropdown( $check, $attr->$getter );
                                        }
                                }
                                $properties .= ' ';
                        }
                        my $type = $attr->can('has_type_constraint') && $attr->has_type_constraint ? $attr->type_constraint->name : '';

                        if ( $role_attribute->{$name} ) {
                                my ( $role_name, $nr ) = each %{ $role_attribute->{$name} };
                                $name .= qq|<sup title="$role_name">$nr</sup>|;
                        }

                        eval { $properties = $attr->documentation . ' ' . $properties };

                        qq|<td class="a">$html_name</td><td class="t">$type</td><td>$properties</td>|
                } $meta->get_attribute_list
        }

        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>|;
        while ( @methods || @attributes ) {
                my ($m,$a) = ( shift @methods, shift @attributes );
                $m ||= '<td></td>';
                $a ||= '<td></td>';
                $table .= qq|<tr>$m$a</tr>|;
        }
        $table .= qq|</table>|;

        my $pod = Frey::Pod->new( class => $class )->as_markup;
        $pod = $pod->{body} if ref($pod);

        my $path = $self->class_path( $class );
        my $Document = PPI::Document->new( $path );

        # Create a reusable syntax highlighter
        my $Highlight = PPI::HTML->new(
                line_numbers => 1,
#               page => 1,
#               colors => {
#                       line_number => '#CCCCCC',
#                       number      => '#990000',
#               },
        );

        # Spit out the HTML
        my $source = $Highlight->html( $Document );

        $source =~ s{(<span.*?line_number.*>\s*)(\d+)(:\s*</span>)}{$1<a target="editor" href="/editor+$path+$2">$2</a>$3}g;

        # strip page html
#       $source =~ s{^.*<body[^>]+>}{}s;
#       $source =~ s{</body.*$}{}s;

        my $runnable = join("\n",
                map {
                        qq|<a target="$class" href="/$class/$_">$_</a>|
                } $self->class_runnable( $class )
        );
        $runnable = " runnable: $runnable" if $runnable;

        $self->title( $class );

        my $has_tests = '';
        if ( my @tests = $self->has_tests ) {
                $has_tests = 
                '<br/>test' . ( $#tests > 0 ? 's' : '' ) . ': ' .       
                join("\n", map {
                        qq|<a target="$class" href="/Frey::Test::Runner/as_markup?test=$_">$_</a>|
                } @tests );
        }

        return join("\n",
                qq|<h1>$class</h1>|,
                qq|<div class="frey-introspect">$superclasses\n$roles\n$runnable\n|,
                $pod    ? qq|<a class="frey-skip" href="#___top" title="Skip to POD"    >pod</a>|    : '',
                $source ? qq|<a class="frey-skip" href="#source" title="Skip to source" >source</a>| : '',
                $has_tests,
                qq|$table\n$pod\n</div>\n|,
                qq|<h1>Source</h1><a name="source"></a><div class="frey-source">$source</div>|,
        );
}

=head1 SEE ALSO

L<MooseX::AutoDoc> on which this code is based

=cut

1;
1	package Frey::Introspect;
2
3	use Moose;
4	use Carp;
5	#use Moose::Meta::Role;
6	#use Moose::Meta::Class;
7	use Data::Dump qw/dump/;
8	use File::Slurp;
9	use List::Util;
10
11	use PPI;
12	use PPI::HTML;
13
14	use lib 'lib';
15
16	extends 'Frey::PPI';
17	with 'Frey::Web';
18
19	has 'class' => (
20	is => 'rw',
21	isa => 'Str',
22	required => 1,
23	);
24
25	=head2 joose
26
27	my $js = $o->joose;
28
29	=cut
30
31	sub joose {
32	my ($self) = @_;
33
34	my ( $meta, $is_role ) = $self->class_meta;
35
36	if ( ! $is_role ) {
37	my @superclasses = map{ $_->meta->name }
38	grep { $_ ne 'Moose::Object' } $meta->superclasses;
39	warn "superclasses ",dump( @superclasses ) if $self->debug;
40	}
41
42	my $out;
43
44	my ( $m, $c ) = split(/::/, $self->class, 2);
45	my $filename = $m . '.' . ( $c ? "$c." : '' ) . 'js';
46
47	$c \|\|= '';
48
49	$out .= "Module(\"$m\", function (m) {\n\tClass(\"$c\", {\n\t\thas: {\n";
50
51	foreach ( $meta->get_attribute_list ) {
52	$out .= "\t\t\t$_: {\n";
53
54	my $attr = $meta->get_attribute($_);
55	my $is = $attr->_is_metadata;
56	$out .= "\t\t\t\tis: \"$is\",\n" if defined $is;
57	$out .= "\t\t\t\tlazy: true,\n" if $attr->is_lazy;
58	$out .= "\t\t\t\trequired: true,\n" if $attr->is_required;
59	$out .= "\t\t\t\tinit: \"" . $attr->init_arg . "\",\n" if $attr->init_arg; # FIXME
60
61	if( defined(my $isa = $attr->_isa_metadata) ){
62	if( blessed $isa ){
63	while( blessed $isa ){
64	$isa = $isa->name;
65	}
66	}
67	$isa =~ s/\s+\\|\s+undef//gi;
68	$out .= "\t\t\t\tisa: Moose.$isa,\n";
69	}
70
71
72	$out .= "\t\t\t},\n";
73
74	}
75
76	$out .= "\t\t},\n\t\tmeta: Frey.HTML,
77	classMethods: {
78	renderHTML: function () {
79	return new Joose.SimpleRequest().getText(\"/" . $self->class . "\")
80	},\n";
81
82	$out .= "\t\t},\n";
83
84	$out .= "\t}),\n";
85
86	$out =~ s/,\n$/\n/;
87	$out .= "});\n";
88
89	$out .= "\nconsole.log( 'loaded " . $self->class . " from $filename' );\n";
90
91	warn "method_list = ",dump( $meta->get_method_list ) if $self->debug;
92
93	# print $out;
94	my $path = "static/blib/$filename";
95	write_file( $path, $out );
96	warn "# created $path\n";
97
98	return $out;
99	}
100
101	sub as_markup {
102	my ( $self ) = @_;
103
104	$self->add_head( 'static/introspect.css' );
105
106	my ( $meta, $is_role ) = $self->class_meta;
107
108	my $class = $self->class;
109
110	my ( $superclasses, $roles ) = ( '<b>Role</b>', '' );
111	if ( ! $is_role ) {
112	if ( $meta->superclasses ) {
113	$superclasses = 'Superclasses: ' .
114	join(', ',
115	map {
116	my $name = $_->meta->name;
117	$self->dropdown( $name, $_->meta )
118	}
119	#grep { $_ ne 'Moose::Object' }
120	$meta->superclasses
121	);
122	}
123	}
124
125	my $role_method;
126	my $role_attribute;
127
128	if ( $meta->can('roles') ) {
129	my $role_nr = 1;
130	$roles = join(' ',
131	grep { ! m/\Q$class\E/ } # skip me
132	map {
133	my $name = $_->name;
134	$role_method->{ $_ }->{$name} = $role_nr foreach $_->get_method_list;
135	$role_attribute->{ $_ }->{$name} = $role_nr foreach $_->get_attribute_list;
136	$self->dropdown( $name, $name->meta ) . qq\|<sup>\| . $role_nr++ . qq\|</sup>\|;
137	}
138	$meta->calculate_all_roles
139	);
140	$roles = qq\| with roles: $roles\| if $roles;
141	}
142	warn "# role_method ",dump( $role_method );
143
144	my @methods;
145	@methods = map {
146	my $name = $_;
147	if ( $role_method->{$name} ) {
148	my ( $role_name, $nr ) = each %{ $role_method->{$name} };
149	$name .= qq\|<sup title="$role_name">$nr</sup>\|;
150	}
151	qq\|<td class="m">$name</td>\|
152	} $self->class_methods( $class );
153
154	my @attributes;
155	if ( $meta->get_attribute_list ) {
156	@attributes = map {
157	my $name = $_;
158	my $html_name = $name;
159	my $attr = $meta->get_attribute($name);
160	confess "$class attribute $name isn't blessed ",dump( $attr ) unless blessed $attr;
161	warn "## attr $name ref ",ref( $attr ) if $self->debug;
162
163	my ( $title, $properties ) = ( '', '' );
164	( $html_name, $title ) = ( "<b>$name</b>", ' title="required"' )
165	if $attr->can('is_required') && $attr->is_required;
166
167	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/ ) {
168	my $getter;
169
170	$getter = $check;
171	$getter =~ s/^has_//;
172
173	if ( $attr->can($check) && $attr->$check ) {
174	if ( $getter eq $check ) {
175	$properties .= "$check";
176	} else {
177	# we need our dump here instead of $attr->$getter->dump because default can return scalar
178	$properties .= $self->dropdown( $check, $attr->$getter );
179	}
180	}
181	$properties .= ' ';
182	}
183	my $type = $attr->can('has_type_constraint') && $attr->has_type_constraint ? $attr->type_constraint->name : '';
184
185	if ( $role_attribute->{$name} ) {
186	my ( $role_name, $nr ) = each %{ $role_attribute->{$name} };
187	$name .= qq\|<sup title="$role_name">$nr</sup>\|;
188	}
189
190	eval { $properties = $attr->documentation . ' ' . $properties };
191
192	qq\|<td class="a">$html_name</td><td class="t">$type</td><td>$properties</td>\|
193	} $meta->get_attribute_list
194	}
195
196	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>\|;
197	while ( @methods \|\| @attributes ) {
198	my ($m,$a) = ( shift @methods, shift @attributes );
199	$m \|\|= '<td></td>';
200	$a \|\|= '<td></td>';
201	$table .= qq\|<tr>$m$a</tr>\|;
202	}
203	$table .= qq\|</table>\|;
204
205	my $pod = Frey::Pod->new( class => $class )->as_markup;
206	$pod = $pod->{body} if ref($pod);
207
208	my $path = $self->class_path( $class );
209	my $Document = PPI::Document->new( $path );
210
211	# Create a reusable syntax highlighter
212	my $Highlight = PPI::HTML->new(
213	line_numbers => 1,
214	# page => 1,
215	# colors => {
216	# line_number => '#CCCCCC',
217	# number => '#990000',
218	# },
219	);
220
221	# Spit out the HTML
222	my $source = $Highlight->html( $Document );
223
224	$source =~ s{(<span.?line_number.>\s)(\d+)(:\s</span>)}{$1<a target="editor" href="/editor+$path+$2">$2</a>$3}g;
225
226	# strip page html
227	# $source =~ s{^.*<body[^>]+>}{}s;
228	# $source =~ s{</body.*$}{}s;
229
230	my $runnable = join("\n",
231	map {
232	qq\|<a target="$class" href="/$class/$_">$_</a>\|
233	} $self->class_runnable( $class )
234	);
235	$runnable = " runnable: $runnable" if $runnable;
236
237	$self->title( $class );
238
239	my $has_tests = '';
240	if ( my @tests = $self->has_tests ) {
241	$has_tests =
242	'<br/>test' . ( $#tests > 0 ? 's' : '' ) . ': ' .
243	join("\n", map {
244	qq\|<a target="$class" href="/Frey::Test::Runner/as_markup?test=$_">$_</a>\|
245	} @tests );
246	}
247
248	return join("\n",
249	qq\|<h1>$class</h1>\|,
250	qq\|<div class="frey-introspect">$superclasses\n$roles\n$runnable\n\|,
251	$pod ? qq\|<a class="frey-skip" href="#___top" title="Skip to POD" >pod</a>\| : '',
252	$source ? qq\|<a class="frey-skip" href="#source" title="Skip to source" >source</a>\| : '',
253	$has_tests,
254	qq\|$table\n$pod\n</div>\n\|,
255	qq\|<h1>Source</h1><a name="source"></a><div class="frey-source">$source</div>\|,
256	);
257	}
258
259	=head1 SEE ALSO
260
261	L<MooseX::AutoDoc> on which this code is based
262
263	=cut
264
265	1;