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 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;

        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;
                                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 $method = $_;
                if ( $role_method ) {
                        my ( $name, $nr ) = each %{ $role_method->{$_} };
                        $method .= qq|<sup title="$name">$nr</sup>|;
                }
                qq|<td class="m">$method</td>|
        } $self->methods;

        my @attributes;
        if ( $meta->get_attribute_list ) {
        @attributes = map {
                        my $attr = $meta->get_attribute($_);
                        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 : '';
                        qq|<td class="a">$before $_</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;

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

        my $html = $self->page(
                title => "Introspect $class",
                body => qq|<h1>$class</h1>|
                        . qq|<div class="frey-introspect">$superclasses\n$roles\n$execute\n|
                        . ( $pod ? qq|<a href="#___top" title="Skip to POD" style="font-size: 80%; color: #aaa;">&darr;pod&darr</a>| : '' )
                        . qq|$table\n$pod</div>|

        );

        return $html;
}

=head1 SEE ALSO

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

=cut

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