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 $@;
        Class::MOP::load_class($package);

        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(\"/~/" . $self->package . "\")
                        },\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" if $self->debug;

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

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