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	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	53	return new Joose.SimpleRequest().getText(\"inspect?module=$m;class=$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			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	dpavlin	49	=head1 SEE ALSO
223
224			L<MooseX::AutoDoc> on which this code is based
225
226			=cut
227
228			1;