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;
use lib 'lib';

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(\"/~/${m}::${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 = Continuity::Widget::DomNode->create(
                        map {
                                ( script => { type => 'text/javascript', src => $_ } )
                        } @javascript
                )->to_string;

                $js .= << '__END_OF_JS__';
<script type="text/javascript">
joose.loadComponents("../lib")

function $(id) {
        return document.getElementById(id)
}

</script>
__END_OF_JS__

                warn "# >>> js\n$js\n";

                my $methods;

                my ( $class, $meta, $is_role );
                eval { $self->load_package(); };
                if ( $@ ) {
                        warn "ERROR: $@";
                        $request->conn->send_status_line( 500, $@ );
                        $request->print( $@ );
                        $request->next;
                        return;
                }

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

                my $attributes = Continuity::Widget::DomNode->create(
                        ul => [
                                map {
                                        my $attr = $class->get_attribute($_);
                                        warn "## $_ ", $attr->is_required ? 'required' : 'optional';
                                        ( li => [ a => { href => '/~/' . $self->package . '/' . $_ } => [ $_, ( $attr->is_required ? ' <b>required</b>' : '' ) ] ] )
                                } $class->get_attribute_list
                        ],
                )->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,
                                ],
                        ]
                );

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