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(\"/~/${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 ) = $self->load_package();
                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
15	dpavlin	49	extends 'Frey';
16
17			has 'package' => (
18			is => 'rw',
19			isa => 'Str',
20			required => 1,
21			);
22
23	dpavlin	51	has 'path' => (
24			is => 'rw',
25			);
26
27	dpavlin	53	=head2 load_package
28	dpavlin	51
29	dpavlin	53	my ( $class, $meta, $is_role ) = $o->load_package( 'Some::Package' );
30	dpavlin	51
31			=cut
32
33	dpavlin	53	sub load_package {
34			my ( $self ) = @_;
35	dpavlin	49
36			my $package = $self->package;
37
38	dpavlin	50	#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	dpavlin	49
51	dpavlin	50	my $meta = $package->meta;
52	dpavlin	53
53	dpavlin	50	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	dpavlin	53	}
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	dpavlin	50	my @superclasses = map{ $_->meta->name }
79			grep { $_ ne 'Moose::Object' } $meta->superclasses;
80			warn "superclasses ",dump( @superclasses );
81			}
82	dpavlin	49
83			my $out;
84
85			my ( $m, $c ) = split(/::/, $class->name, 2);
86	dpavlin	51	my $filename = $m . '.' . ( $c ? "$c." : '' ) . 'js';
87	dpavlin	49
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	dpavlin	50	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	dpavlin	49	$out .= "\t\t\t},\n";
112
113			}
114
115	dpavlin	51	$out .= "\t\t},\n\t\tmeta: Frey.HTML,
116			classMethods: {
117			renderHTML: function () {
118	dpavlin	54	return new Joose.SimpleRequest().getText(\"/~/${m}::${c}\")
119	dpavlin	51	},\n";
120
121	dpavlin	49	$out .= "\t\t},\n";
122
123			$out .= "\t}),\n";
124	dpavlin	50
125			$out =~ s/,\n$/\n/;
126	dpavlin	49	$out .= "});\n";
127
128			$out .= "\nconsole.log( 'loaded " . $class->name . " from $filename' );\n";
129
130			warn $class->dump(2);
131
132	dpavlin	51	warn "method_list = ",dump( $class->get_method_list );
133			warn dump( map{ $class->get_method($_)->name } sort $class->get_method_list );
134	dpavlin	49
135	dpavlin	51	# print $out;
136	dpavlin	49	my $path = "static/blib/$filename";
137			write_file( $path, $out );
138			warn "# created $path\n";
139	dpavlin	51	$self->path( $path );
140
141			return $out;
142	dpavlin	49	}
143
144	dpavlin	53	=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	dpavlin	54	my $js = Continuity::Widget::DomNode->create(
181			map {
182			( script => { type => 'text/javascript', src => $_ } )
183			} @javascript
184			)->to_string;
185	dpavlin	53
186	dpavlin	54	$js .= << '__END_OF_JS__';
187			<script type="text/javascript">
188			joose.loadComponents("../lib")
189	dpavlin	53
190	dpavlin	54	function $(id) {
191			return document.getElementById(id)
192			}
193
194			</script>
195			__END_OF_JS__
196
197			warn "# >>> js\n$js\n";
198
199			my $methods;
200
201	dpavlin	53	my ( $class, $meta, $is_role ) = $self->load_package();
202			if ( $class->can('meta') ) {
203	dpavlin	54	$methods = Continuity::Widget::DomNode->create(
204	dpavlin	53	ul => [
205			map { (
206	dpavlin	54	li => [ a => { href => '/~/' . $self->package . '/' . $_ } => [ $_ ] ]
207	dpavlin	53	) } $self->methods
208			]
209			)->to_string;
210			} else {
211	dpavlin	54	$methods = '<b>not introspectable</b>';
212	dpavlin	53	}
213
214	dpavlin	54	my $attributes = Continuity::Widget::DomNode->create(
215			ul => [
216			map {
217			my $attr = $class->get_attribute($_);
218			warn "## $_ ", $attr->is_required ? 'required' : 'optional';
219			( li => [ a => { href => '/~/' . $self->package . '/' . $_ } => [ $_, ( $attr->is_required ? ' <b>required</b>' : '' ) ] ] )
220			} $class->get_attribute_list
221			],
222			)->to_string;
223
224	dpavlin	53	my $doc = Continuity::Widget::DomNode->create(
225			html => [
226			head => [
227			link => { rel=>"stylesheet", href=>"/static/app.css", type=>"text/css", media=>"screen" },
228	dpavlin	54	$js,
229			title => [ 'Introspect ', $self->package ],
230	dpavlin	53	],
231			body => [
232	dpavlin	54	h1 => [ $self->package ],
233			h2 => [ 'Methods' ],
234			$methods,
235			h2 => [ 'Atrributes' ],
236			$attributes,
237	dpavlin	53	],
238			]
239			);
240
241			$request->print($doc->to_string);
242	dpavlin	54	warn "# >>> html\n", $doc->to_string, "\n";
243	dpavlin	53	$request->next;
244			}
245			warn "# exit html";
246			}
247
248	dpavlin	49	=head1 SEE ALSO
249
250			L<MooseX::AutoDoc> on which this code is based
251
252			=cut
253
254			1;