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::ClassLoader';
with 'Frey::Web';

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

has 'path' => (
        is => 'rw',
);

=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";
        $self->path( $path );

        return $out;
}

=head2 methods

  my @methods = $o->methods;

=cut

sub methods {
        my $self = shift;

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

        my $attr;
        $attr->{$_}++ foreach $meta->get_attribute_list;
        my @methods = grep { ! defined($attr->{$_}) } $meta->get_method_list;
        warn "# methods = ",dump( @methods ) if $self->debug;

        return sort @methods;
}

=head1 OUTPUT GENERATION

=head2 markup

  $o->markup;

=cut

sub 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;
                                                qq|<a class="frey-popdown" href="/$name">$name<code>| . $_->meta->dump(2) . qq|</code></a>|;
                                        }
                                        #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;
                                qq|<a class="frey-popdown" href="/$name">$name<code>| . $name->meta->dump(2) . qq|</code></a><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->methods;

        my @attributes;
        if ( $meta->get_attribute_list ) {
        @attributes = map {
                        my $name = $_;
                        my $attr = $meta->get_attribute($name);
                        warn "## ref attr: ",ref( $attr );
                        my ( $before, $title, $after ) = ( '', '', '' );
                        ( $before, $title, $after ) = ( '<b>', ' title="required"', '</b>' ) if $attr->is_required;
warn $attr->dump(3);
                        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_documentation has_applied_traits/ ) {
                                my $getter;
                                
                                $getter = $check;
                                $getter =~ s/^has_//;
                                
                                if ( $attr->$check ) {
                                        if ( $getter eq $check ) {
                                                $after .= "$check";
                                        } else {
                                                $after .= qq{<span class="frey-popdown">$check};
                                                # we need dump here instead of $attr->$getter->dump because default can return scalar
                                                $after .= '<code>' . dump( $attr->$getter ) . '</code>' if $getter ne $check;
                                                $after .= '</span>';
                                        }
                                }
                                $after .= ' ';
                        }
                        my $type = $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>|;
                        }

                        qq|<td class="a">$before $name</td><td class="t">$type</td><td>$after</td>|
                } sort $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 )->markup;
        $pod = $pod->{body} if ref($pod);

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

        # 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{^.*<body[^>]+>}{}s;
#       $source =~ s{</body.*$}{}s;

        use Frey::Run;
        my $runnable = join("\n", map { qq|<a href="/$class/$_">$_</a>| } grep { $class->can($_) } Frey::Run->runnable );
        $runnable = " runnable: $runnable" if $runnable;

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

        return $html;
}

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