lib/Frey/Introspect.pm

package Frey::Introspect;

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

use Continuity::Widget::DomNode;

extends 'Frey';

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

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

=head2 load_package

  my ( $class, $meta, $is_role ) = $o->load_package( 'Some::Package' );

=cut

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

        my $package = $self->package;

        #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 $@;

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

=head2 joose

  my $js = $o->joose( 'Some::Package' );

=cut

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

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

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

        my $out;

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

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

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

                my $attr = $class->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(\"inspect?module=$m;class=$c\")
                        },\n";

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

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

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

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

        warn $class->dump(2);

        warn "method_list = ",dump( $class->get_method_list );
        warn dump( map{ $class->get_method($_)->name } sort $class->get_method_list );

#       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 ( $class, $meta, $is_role ) = $self->load_package;

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

        return @methods;
}

=head1 OUTPUT GENERATION

=head2 html

  $o->html( $request );

=cut

our @javascript = ( qw'
../lib/Joose.js
');

sub html {
        my ( $self, $request ) = @_;

        while (1) {

                my $js = [ map {
                        ( script => { type => 'text/javascript', src => $_ } )
                } @javascript ];
                warn "# js = ",dump( $js );

                my $o;

                my ( $class, $meta, $is_role ) = $self->load_package();
                if ( $class->can('meta') ) {
                        $o = Continuity::Widget::DomNode->create(
                                ul => [
                                        map { (
                                                li => [ a => { href => $_ } => [ $_ ] ]
                                        ) } $self->methods
                                ]
                        )->to_string;
                } else {
                        $o = '<b>not introspectable</b>';
                }

                warn "# o = ",dump( $o );
                
                my $doc = Continuity::Widget::DomNode->create(
                        html => [
                                head => [
                                        link => { rel=>"stylesheet", href=>"/static/app.css", type=>"text/css", media=>"screen" },
#                                       $js,
                                ],
                                body => [
                                        h1 => [ 'Introspect ', $self->package ],
                                        $o,
                                ],
                        ]
                );

                $request->print($doc->to_string);
                warn "# html = ", $doc->to_string;
                $request->next;
        }
        warn "# exit 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 Class::MOP;
6	use Moose::Meta::Role;
7	use Moose::Meta::Class;
8	use Scalar::Util qw/blessed/;
9	use Data::Dump qw/dump/;
10	use File::Slurp;
11	use List::Util;
12
13	use Continuity::Widget::DomNode;
14
15	extends 'Frey';
16
17	has 'package' => (
18	is => 'rw',
19	isa => 'Str',
20	required => 1,
21	);
22
23	has 'path' => (
24	is => 'rw',
25	);
26
27	=head2 load_package
28
29	my ( $class, $meta, $is_role ) = $o->load_package( 'Some::Package' );
30
31	=cut
32
33	sub load_package {
34	my ( $self ) = @_;
35
36	my $package = $self->package;
37
38	#intercept role application so we can accurately generate
39	#method and attribute information for the parent class.
40	#this is fragile, but there is not better way that i am aware of
41	my $rmeta = Moose::Meta::Role->meta;
42	$rmeta->make_mutable if $rmeta->is_immutable;
43	my $original_apply = $rmeta->get_method("apply")->body;
44	$rmeta->remove_method("apply");
45	my @roles_to_apply;
46	$rmeta->add_method("apply", sub{push(@roles_to_apply, [@_])});
47	#load the package with the hacked Moose::Meta::Role
48	eval { Class::MOP::load_class($package); };
49	confess "Failed to load package ${package} $@" if $@;
50
51	my $meta = $package->meta;
52
53	my ($class, $is_role);
54	if($package->meta->isa('Moose::Meta::Role')){
55	$is_role = 1;
56	# we need to apply the role to a class to be able to properly introspect it
57	$class = Moose::Meta::Class->create_anon_class;
58	$original_apply->($meta, $class);
59	} else {
60	#roles don't have superclasses ...
61	$class = $meta;
62	}
63	return ( $class, $meta, $is_role );
64	}
65
66	=head2 joose
67
68	my $js = $o->joose( 'Some::Package' );
69
70	=cut
71
72	sub joose {
73	my ($self) = @_;
74
75	my ( $class, $meta, $is_role ) = $self->load_package;
76
77	if ( ! $is_role ) {
78	my @superclasses = map{ $_->meta->name }
79	grep { $_ ne 'Moose::Object' } $meta->superclasses;
80	warn "superclasses ",dump( @superclasses );
81	}
82
83	my $out;
84
85	my ( $m, $c ) = split(/::/, $class->name, 2);
86	my $filename = $m . '.' . ( $c ? "$c." : '' ) . 'js';
87
88	$out .= "Module(\"$m\", function (m) {\n\tClass(\"$c\", {\n\t\thas: {\n";
89
90	foreach ( $class->get_attribute_list ) {
91	$out .= "\t\t\t$_: {\n";
92
93	my $attr = $class->get_attribute($_);
94	my $is = $attr->_is_metadata;
95	$out .= "\t\t\t\tis: \"$is\",\n" if defined $is;
96	$out .= "\t\t\t\tlazy: true,\n" if $attr->is_lazy;
97	$out .= "\t\t\t\trequired: true,\n" if $attr->is_required;
98	$out .= "\t\t\t\tinit: \"" . $attr->init_arg . "\",\n" if $attr->init_arg; # FIXME
99
100	if( defined(my $isa = $attr->_isa_metadata) ){
101	if( blessed $isa ){
102	while( blessed $isa ){
103	$isa = $isa->name;
104	}
105	}
106	$isa =~ s/\s+\\|\s+undef//gi;
107	$out .= "\t\t\t\tisa: Moose.$isa,\n";
108	}
109
110
111	$out .= "\t\t\t},\n";
112
113	}
114
115	$out .= "\t\t},\n\t\tmeta: Frey.HTML,
116	classMethods: {
117	renderHTML: function () {
118	return new Joose.SimpleRequest().getText(\"inspect?module=$m;class=$c\")
119	},\n";
120
121	$out .= "\t\t},\n";
122
123	$out .= "\t}),\n";
124
125	$out =~ s/,\n$/\n/;
126	$out .= "});\n";
127
128	$out .= "\nconsole.log( 'loaded " . $class->name . " from $filename' );\n";
129
130	warn $class->dump(2);
131
132	warn "method_list = ",dump( $class->get_method_list );
133	warn dump( map{ $class->get_method($_)->name } sort $class->get_method_list );
134
135	# print $out;
136	my $path = "static/blib/$filename";
137	write_file( $path, $out );
138	warn "# created $path\n";
139	$self->path( $path );
140
141	return $out;
142	}
143
144	=head2 methods
145
146	my @methods = $o->methods;
147
148	=cut
149
150	sub methods {
151	my $self = shift;
152
153	my ( $class, $meta, $is_role ) = $self->load_package;
154
155	my $attr;
156	$attr->{$_}++ foreach $class->get_attribute_list;
157	my @methods = grep { ! defined($attr->{$_}) } $class->get_method_list;
158	warn "# methods = ",dump( @methods );
159
160	return @methods;
161	}
162
163	=head1 OUTPUT GENERATION
164
165	=head2 html
166
167	$o->html( $request );
168
169	=cut
170
171	our @javascript = ( qw'
172	../lib/Joose.js
173	');
174
175	sub html {
176	my ( $self, $request ) = @_;
177
178	while (1) {
179
180	my $js = [ map {
181	( script => { type => 'text/javascript', src => $_ } )
182	} @javascript ];
183	warn "# js = ",dump( $js );
184
185	my $o;
186
187	my ( $class, $meta, $is_role ) = $self->load_package();
188	if ( $class->can('meta') ) {
189	$o = Continuity::Widget::DomNode->create(
190	ul => [
191	map { (
192	li => [ a => { href => $_ } => [ $_ ] ]
193	) } $self->methods
194	]
195	)->to_string;
196	} else {
197	$o = '<b>not introspectable</b>';
198	}
199
200	warn "# o = ",dump( $o );
201
202	my $doc = Continuity::Widget::DomNode->create(
203	html => [
204	head => [
205	link => { rel=>"stylesheet", href=>"/static/app.css", type=>"text/css", media=>"screen" },
206	# $js,
207	],
208	body => [
209	h1 => [ 'Introspect ', $self->package ],
210	$o,
211	],
212	]
213	);
214
215	$request->print($doc->to_string);
216	warn "# html = ", $doc->to_string;
217	$request->next;
218	}
219	warn "# exit html";
220	}
221
222	=head1 SEE ALSO
223
224	L<MooseX::AutoDoc> on which this code is based
225
226	=cut
227
228	1;