/[Frey]/trunk/lib/Frey/Introspect.pm
This is repository of my old source code which isn't updated any more. Go to git.rot13.org for current projects!
ViewVC logotype

Contents of /trunk/lib/Frey/Introspect.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 55 - (show annotations)
Sat Jul 5 19:00:10 2008 UTC (15 years, 8 months ago) by dpavlin
File size: 5637 byte(s)
remove all usage of Template::Declare [0.05]

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

  ViewVC Help
Powered by ViewVC 1.1.26