Commit | Line | Data |
9e60f0d8 |
1 | package MooseX::Compiler; |
2 | |
3 | use strict; |
4 | use warnings; |
5 | |
f56affb6 |
6 | use B; |
5405fa51 |
7 | use Data::Dumper; |
9e60f0d8 |
8 | use Module::Runtime qw( module_notional_filename ); |
9 | use PPI::Document; |
10 | use Scalar::Util qw( blessed ); |
11 | |
12 | use Moose; |
13 | use Moose::Util::TypeConstraints; |
14 | |
15 | my $moose_class = subtype, as 'ClassName', where { |
16 | $_[0]->can('meta') |
17 | && blessed $_[0]->meta() |
18 | && $_[0]->meta()->isa('Moose::Meta::Class'); |
19 | }; |
20 | |
21 | has class => ( |
22 | is => 'ro', |
23 | isa => $moose_class, |
24 | required => 1, |
25 | ); |
26 | |
27543eae |
27 | has rename_to => ( |
28 | is => 'ro', |
29 | isa => 'Str', |
30 | predicate => '_has_rename_to', |
31 | ); |
32 | |
9e60f0d8 |
33 | has _class_meta => ( |
34 | is => 'ro', |
35 | isa => 'Moose::Meta::Class', |
36 | init_arg => undef, |
37 | lazy => 1, |
38 | default => sub { $_[0]->class()->meta() }, |
39 | ); |
40 | |
f56affb6 |
41 | has _ppi_document => ( |
42 | is => 'ro', |
43 | isa => 'PPI::Document', |
44 | init_arg => undef, |
45 | lazy => 1, |
46 | builder => '_build_ppi_document', |
47 | ); |
48 | |
49 | has _package_statement => ( |
50 | is => 'ro', |
51 | isa => 'PPI::Statement::Package', |
52 | init_arg => undef, |
53 | lazy => 1, |
54 | builder => '_build_package_statement', |
27543eae |
55 | clearer => '_clear_package_statement', |
56 | ); |
57 | |
58 | has _end_node => ( |
59 | is => 'ro', |
60 | isa => 'PPI::Statement', |
61 | init_arg => undef, |
62 | lazy => 1, |
63 | builder => '_build_end_node', |
f56affb6 |
64 | ); |
65 | |
9e60f0d8 |
66 | sub compile_class { |
f56affb6 |
67 | my $self = shift; |
9e60f0d8 |
68 | |
27543eae |
69 | $self->_sanity_check_class(); |
f56affb6 |
70 | $self->_modify_class_content(); |
71 | $self->_inline_roles(); |
72 | $self->_inline_constructor(); |
73 | $self->_inline_attributes(); |
9e60f0d8 |
74 | |
f56affb6 |
75 | return $self->_ppi_document()->content(); |
9e60f0d8 |
76 | } |
77 | |
27543eae |
78 | sub _sanity_check_class { |
79 | my $self = shift; |
80 | |
81 | for my $attr ( $self->_class_meta()->get_all_attributes() ) { |
82 | if ( $attr->has_trigger() ) { |
83 | die sprintf( |
84 | 'This class (%s) has an attribute (%s) with a trigger. Triggers cannot be compiled.', |
85 | $self->class(), $attr->name() |
86 | ); |
87 | } |
88 | |
89 | if ( $attr->has_initializer() ) { |
90 | die sprintf( |
91 | 'This class (%s) has an attribute (%s) with an initializer. Initializers cannot be compiled.', |
92 | $self->class(), $attr->name() |
93 | ); |
94 | } |
95 | |
96 | if ( $attr->has_type_constraint() |
97 | && !$attr->type_constraint()->can_be_inlined() ) { |
98 | |
99 | die sprintf( |
100 | 'This class (%s) has an attribute (%s) with a type that cannot be inlined (%s)..', |
101 | $self->class(), $attr->name(), |
102 | $attr->type_constraint()->name() |
103 | ); |
104 | } |
105 | } |
106 | } |
107 | |
f56affb6 |
108 | sub _modify_class_content { |
9e60f0d8 |
109 | my $self = shift; |
110 | |
27543eae |
111 | $self->_maybe_rename_class(); |
f56affb6 |
112 | $self->_fixup_line_numbers(); |
113 | $self->_do_not_use_moose(); |
114 | $self->_inline_parents(); |
115 | $self->_load_required_modules(); |
9e60f0d8 |
116 | |
f56affb6 |
117 | return; |
118 | } |
119 | |
27543eae |
120 | sub _maybe_rename_class { |
121 | my $self = shift; |
122 | |
123 | return unless $self->_has_rename_to(); |
124 | |
125 | $self->_insert_code( |
126 | $self->_package_statement(), |
127 | 'package ' . $self->rename_to() . ';' |
128 | ); |
129 | |
130 | $self->_package_statement()->remove(); |
131 | |
132 | $self->_clear_package_statement(); |
133 | |
134 | return; |
135 | } |
136 | |
f56affb6 |
137 | sub _fixup_line_numbers { |
138 | my $self = shift; |
139 | |
140 | my $code = "#line 3\n"; |
27543eae |
141 | |
142 | $self->_insert_code( |
143 | $self->_package_statement()->snext_sibling(), |
144 | $code, |
145 | 'before', |
146 | ); |
f56affb6 |
147 | |
148 | return; |
149 | } |
150 | |
151 | sub _do_not_use_moose { |
152 | my $self = shift; |
9e60f0d8 |
153 | |
f56affb6 |
154 | my $use_nodes = $self->_ppi_document()->find( |
9e60f0d8 |
155 | sub { |
156 | my $node = $_[1]; |
157 | return undef |
158 | if $node->isa('PPI::Statement') |
159 | && !$node->isa('PPI::Statement::Include'); |
160 | return undef if $node->isa('PPI::Structure'); |
161 | return 1 |
162 | if $node->isa('PPI::Statement::Include') |
163 | && $node->module() =~ /^Moose/; |
164 | return 0; |
165 | } |
166 | ); |
167 | |
168 | for my $node ( @{$use_nodes} ) { |
169 | my $replacement_code .= |
170 | defined $node->module_version() |
171 | ? join( |
172 | q{ }, |
173 | 'use', $node->module(), $node->module_version(), '()', ';', |
174 | ) |
175 | : '# ' . $node->content(); |
176 | |
27543eae |
177 | $self->_insert_code( |
178 | $node, |
179 | $replacement_code, |
180 | ); |
181 | |
9e60f0d8 |
182 | $node->remove(); |
183 | } |
184 | |
f56affb6 |
185 | return; |
9e60f0d8 |
186 | } |
187 | |
f56affb6 |
188 | sub _inline_parents { |
189 | my $self = shift; |
190 | |
191 | my @supers = $self->_class_meta()->superclasses(); |
192 | return unless @supers; |
193 | |
194 | my $code = 'use parent '; |
195 | $code .= join ', ', map { B::perlstring($_) } @supers; |
196 | $code .= ";\n"; |
197 | |
27543eae |
198 | $self->_insert_code( |
199 | $self->_package_statement(), |
200 | $code, |
201 | ); |
f56affb6 |
202 | |
203 | return; |
9e60f0d8 |
204 | } |
205 | |
5405fa51 |
206 | # XXX - replace this with something that looks at all the generated code for |
207 | # calls of the form Foo::Bar::quux(...) - also don't load modules that are |
208 | # already being used. |
f56affb6 |
209 | sub _load_required_modules { |
210 | my $self = shift; |
211 | |
27543eae |
212 | my $code = join q{}, |
213 | map { "use $_ ();\n" } |
214 | qw( Carp Moose::Error::Util Scalar::Util ); |
215 | $code .= "use MooseX::Compiler::FakeMoose;\n"; |
216 | |
217 | $self->_insert_code( |
218 | $self->_package_statement(), |
219 | $code, |
220 | ); |
221 | |
222 | return; |
223 | } |
f56affb6 |
224 | |
27543eae |
225 | sub _insert_code { |
226 | my $self = shift; |
227 | my $statement = shift; |
228 | my $code = shift; |
229 | my $before = shift; |
230 | |
231 | my $method = $before ? 'insert_before' : 'insert_after'; |
232 | $statement->$method( $_->clone() ) |
f56affb6 |
233 | for PPI::Document->new( \$code )->children(); |
234 | |
235 | return; |
236 | } |
237 | |
238 | sub _inline_roles { |
239 | return; |
240 | } |
241 | |
242 | sub _inline_constructor { |
243 | my $self = shift; |
244 | |
5405fa51 |
245 | my $environment = $self->_class_meta()->_eval_environment(); |
27543eae |
246 | |
247 | # This should go away in the next major release of Moose (I hope). |
5405fa51 |
248 | delete $environment->{'$meta'}; |
5405fa51 |
249 | |
27543eae |
250 | # In the future, we need to work with Specio, which should make this |
251 | # simpler (I hope). |
252 | delete $environment->{'@type_constraint_bodies'}; |
5405fa51 |
253 | |
254 | my $body = join "\n", $self->_class_meta()->_inline_new_object(); |
255 | if ( $body =~ /\$meta/ ) { |
256 | die |
257 | 'Cannot compile a class with a constructor that refers to the $meta object'; |
258 | } |
259 | |
260 | my @defs = @{ ${ $environment->{'$defaults'} } }; |
261 | $environment->{'$defaults'} = \( |
262 | [ |
263 | map { ref $defs[$_] ? '$___attributes[' . $_ . ']' : $defs[$_] } |
264 | 0 .. $#defs |
265 | ] |
266 | ); |
267 | |
268 | my $constructor = join "\n", ( |
269 | '{', |
f56affb6 |
270 | ( |
5405fa51 |
271 | map { |
272 | $self->_serialize_assignment( $_, $environment->{$_} ) . ';' |
273 | } |
274 | keys %{$environment} |
275 | ), |
f56affb6 |
276 | 'sub new {', |
5405fa51 |
277 | $body, |
278 | '}', |
279 | '}', |
280 | ); |
f56affb6 |
281 | |
282 | $constructor .= "\n\n"; |
283 | |
284 | $self->_insert_before_end($constructor); |
285 | |
286 | return; |
287 | } |
288 | |
27543eae |
289 | sub _inline_attributes { |
290 | my $self = shift; |
291 | |
292 | my $code; |
293 | for my $attr ( $self->_class_meta()->get_all_attributes() ) { |
294 | for my $method ( $attr->associated_methods() ) { |
295 | # This is super gross, there really should be some sort of generic |
296 | # "inlinable_method" thing |
297 | my $generator_method = join "_" => ( |
298 | '_generate', |
299 | $self->accessor_type, |
300 | 'method_inline', |
301 | ); |
302 | |
303 | $code .= $method->$generator_method(); |
304 | } |
305 | } |
306 | |
307 | $self->_insert_before_end($code); |
308 | |
309 | return; |
310 | } |
311 | |
5405fa51 |
312 | sub _serialize_assignment { |
313 | my $self = shift; |
314 | my $name = shift; |
315 | my $value = shift; |
316 | |
317 | local $Data::Dumper::Terse = 1; |
318 | local $Data::Dumper::Indent = 1; |
319 | local $Data::Dumper::Useqq = 1; |
320 | local $Data::Dumper::Deparse = 1; |
321 | local $Data::Dumper::Quotekeys = 0; |
322 | local $Data::Dumper::Sortkeys = 1; |
323 | |
324 | return |
27543eae |
325 | "my $name = " |
5405fa51 |
326 | . substr( $name, 0, 1 ) . '{ ' |
327 | . Data::Dumper->Dump( [$value] ) . ' }'; |
328 | } |
329 | |
f56affb6 |
330 | sub _insert_before_end { |
331 | my $self = shift; |
332 | my $code = shift; |
333 | |
27543eae |
334 | $self->_insert_code( |
335 | $self->_end_node(), |
336 | $code, |
337 | 'before', |
f56affb6 |
338 | ); |
339 | |
f56affb6 |
340 | return; |
341 | } |
342 | |
343 | sub _build_ppi_document { |
344 | my $self = shift; |
345 | |
346 | my $pm_file = module_notional_filename( $self->class() ); |
347 | my $path_to_class = $INC{$pm_file} |
348 | or die "Cannot find $pm_file in %INC!"; |
349 | |
350 | return PPI::Document->new( $path_to_class->stringify() ) |
351 | or die PPI::Document->errstr(); |
352 | } |
353 | |
354 | sub _build_package_statement { |
355 | my $self = shift; |
356 | |
357 | my $package_stmt = $self->_ppi_document()->find_first( |
358 | sub { |
359 | my $node = $_[1]; |
360 | return 1 if $_[1]->isa('PPI::Statement::Package'); |
361 | return 0; |
362 | } |
363 | ); |
364 | |
365 | die 'Cannot find a package statement in this code' |
366 | unless $package_stmt; |
367 | |
368 | return $package_stmt; |
9e60f0d8 |
369 | } |
370 | |
27543eae |
371 | sub _build_end_node { |
372 | my $self = shift; |
373 | |
374 | my $end_node = $self->_ppi_document()->find_first( |
375 | sub { |
376 | my $node = $_[1]; |
377 | |
378 | return 1 |
379 | if $node->isa('PPI::Statement') && $node->content() =~ /^1;/; |
380 | return 0; |
381 | } |
382 | ); |
383 | |
384 | die 'Cannot find the end of the class (looking for a line match /^1;/)' |
385 | unless $end_node; |
386 | |
387 | return $end_node; |
388 | } |
389 | |
9e60f0d8 |
390 | __PACKAGE__->meta()->make_immutable(); |
391 | |
392 | 1; |