Pass @_ from deprecation wrapper
[gitmo/Class-MOP.git] / lib / Class / MOP / Immutable.pm
1
2 package Class::MOP::Immutable;
3
4 use strict;
5 use warnings;
6
7 use Class::MOP::Method::Constructor;
8
9 use Carp         'confess';
10 use Scalar::Util 'blessed';
11
12 our $VERSION   = '0.81';
13 $VERSION = eval $VERSION;
14 our $AUTHORITY = 'cpan:STEVAN';
15
16 use base 'Class::MOP::Object';
17
18 sub new {
19     my ($class, @args) = @_;
20
21     unshift @args, 'metaclass' if @args % 2 == 1;
22
23     my %options = (
24         inline_accessors   => 1,
25         inline_constructor => 1,
26         inline_destructor  => 0,
27         constructor_name   => 'new',
28         constructor_class  => 'Class::MOP::Method::Constructor',
29         debug              => 0,
30         @args,
31     );
32
33     my $self = $class->_new(
34         'metaclass'           => delete $options{metaclass},
35         'options'             => \%options,
36         'immutable_metaclass' => undef,
37         'inlined_constructor' => undef,
38     );
39
40     return $self;
41 }
42
43 sub _new {
44     my $class = shift;
45     my $options = @_ == 1 ? $_[0] : {@_};
46
47     bless $options, $class;
48 }
49
50 sub immutable_metaclass {
51     my $self = shift;
52
53     return $self->{'immutable_metaclass'} ||= $self->_create_immutable_metaclass;
54 }
55
56 sub metaclass           { (shift)->{'metaclass'}           }
57 sub options             { (shift)->{'options'}             }
58 sub inlined_constructor { (shift)->{'inlined_constructor'} }
59
60 sub _create_immutable_metaclass {
61     my $self = shift;
62
63     # NOTE: The immutable version of the metaclass is just a
64     # anon-class which shadows the methods appropriately
65     return Class::MOP::Class->create_anon_class(
66         superclasses => [ blessed($self->metaclass) ],
67         methods      => $self->_create_methods_for_immutable_metaclass,
68     );
69 }
70
71 sub make_metaclass_immutable {
72     my $self = shift;
73
74     $self->_inline_accessors;
75     $self->_inline_constructor;
76     $self->_inline_destructor;
77     $self->_check_memoized_methods;
78
79     my $metaclass = $self->metaclass;
80
81     $metaclass->{'___original_class'} = blessed($metaclass);
82     bless $metaclass => $self->immutable_metaclass->name;
83 }
84
85 sub _inline_accessors {
86     my $self = shift;
87
88     return unless $self->options->{inline_accessors};
89
90     foreach my $attr_name ( $self->metaclass->get_attribute_list ) {
91         $self->metaclass->get_attribute($attr_name)->install_accessors(1);
92     }
93 }
94
95 sub _inline_constructor {
96     my $self = shift;
97
98     return unless $self->options->{inline_constructor};
99
100     unless ($self->options->{replace_constructor}
101          or !$self->metaclass->has_method(
102              $self->options->{constructor_name}
103          )) {
104         my $class = $self->metaclass->name;
105         warn "Not inlining a constructor for $class since it defines"
106            . " its own constructor.\n"
107            . "If you are certain you don't need to inline your"
108            . " constructor, specify inline_constructor => 0 in your"
109            . " call to $class->meta->make_immutable\n";
110         return;
111     }
112
113     my $constructor_class = $self->options->{constructor_class};
114
115     my $constructor = $constructor_class->new(
116         options      => $self->options,
117         metaclass    => $self->metaclass,
118         is_inline    => 1,
119         package_name => $self->metaclass->name,
120         name         => $self->options->{constructor_name},
121     );
122
123     if (   $self->options->{replace_constructor}
124         or $constructor->can_be_inlined ) {
125         $self->metaclass->add_method(
126             $self->options->{constructor_name} => $constructor );
127         $self->{inlined_constructor} = $constructor;
128     }
129 }
130
131 sub _inline_destructor {
132     my $self = shift;
133
134     return unless $self->options->{inline_destructor};
135
136     ( exists $self->options->{destructor_class} )
137         || confess "The 'inline_destructor' option is present, but "
138         . "no destructor class was specified";
139
140     my $destructor_class = $self->options->{destructor_class};
141
142     return unless $destructor_class->is_needed( $self->metaclass );
143
144     my $destructor = $destructor_class->new(
145         options      => $self->options,
146         metaclass    => $self->metaclass,
147         package_name => $self->metaclass->name,
148         name         => 'DESTROY'
149     );
150
151     $self->metaclass->add_method( 'DESTROY' => $destructor );
152 }
153
154 sub _check_memoized_methods {
155     my $self = shift;
156
157     my $memoized_methods = $self->options->{memoize};
158     foreach my $method_name ( keys %{$memoized_methods} ) {
159         my $type = $memoized_methods->{$method_name};
160
161         ( $self->metaclass->can($method_name) )
162             || confess "Could not find the method '$method_name' in "
163             . $self->metaclass->name;
164     }
165 }
166 my %DEFAULT_METHODS = (
167     # I don't really understand this, but removing it breaks tests (groditi)
168     meta => sub {
169         my $self = shift;
170         # if it is not blessed, then someone is asking
171         # for the meta of Class::MOP::Immutable
172         return Class::MOP::Class->initialize($self) unless blessed($self);
173         # otherwise, they are asking for the metaclass
174         # which has been made immutable, which is itself
175         # except in the cases where it is a metaclass itself
176         # that has been made immutable and for that we need 
177         # to dig a bit ...
178         if ($self->isa('Class::MOP::Class')) {
179             return Class::MOP::class_of($self->{'___original_class'});
180         }
181         else {
182             return $self;
183         }
184     },
185     is_mutable     => sub { 0  },
186     is_immutable   => sub { 1  },
187     make_immutable => sub { () },
188 );
189
190 sub _create_methods_for_immutable_metaclass {
191     my $self = shift;
192
193     my $metaclass = $self->metaclass;
194     my $meta      = Class::MOP::class_of($metaclass);
195
196     return {
197         %DEFAULT_METHODS,
198         $self->_make_read_only_methods,
199         $self->_make_uncallable_methods,
200         $self->_make_memoized_methods,
201         $self->_make_wrapped_methods,
202         get_mutable_metaclass_name => sub { (shift)->{'___original_class'} },
203         immutable_transformer      => sub {$self},
204     };
205 }
206
207 sub _make_read_only_methods {
208     my $self = shift;
209
210     my $metameta = Class::MOP::class_of($self->metaclass);
211
212     my %methods;
213     foreach my $read_only_method ( @{ $self->options->{read_only} } ) {
214         my $method = $metameta->find_method_by_name($read_only_method);
215
216         ( defined $method )
217             || confess "Could not find the method '$read_only_method' in "
218             . $self->metaclass->name;
219
220         $methods{$read_only_method} = sub {
221             confess "This method is read-only" if scalar @_ > 1;
222             goto &{ $method->body };
223         };
224     }
225
226     return %methods;
227 }
228
229 sub _make_uncallable_methods {
230     my $self = shift;
231
232     my %methods;
233     foreach my $cannot_call_method ( @{ $self->options->{cannot_call} } ) {
234         $methods{$cannot_call_method} = sub {
235             confess
236                 "This method ($cannot_call_method) cannot be called on an immutable instance";
237         };
238     }
239
240     return %methods;
241 }
242
243 sub _make_memoized_methods {
244     my $self = shift;
245
246     my %methods;
247
248     my $metameta = Class::MOP::class_of($self->metaclass);
249
250     my $memoized_methods = $self->options->{memoize};
251     foreach my $method_name ( keys %{$memoized_methods} ) {
252         my $type   = $memoized_methods->{$method_name};
253         my $key    = '___' . $method_name;
254         my $method = $metameta->find_method_by_name($method_name);
255
256         if ( $type eq 'ARRAY' ) {
257             $methods{$method_name} = sub {
258                 @{ $_[0]->{$key} } = $method->execute( $_[0] )
259                     if !exists $_[0]->{$key};
260                 return @{ $_[0]->{$key} };
261             };
262         }
263         elsif ( $type eq 'HASH' ) {
264             $methods{$method_name} = sub {
265                 %{ $_[0]->{$key} } = $method->execute( $_[0] )
266                     if !exists $_[0]->{$key};
267                 return %{ $_[0]->{$key} };
268             };
269         }
270         elsif ( $type eq 'SCALAR' ) {
271             $methods{$method_name} = sub {
272                 $_[0]->{$key} = $method->execute( $_[0] )
273                     if !exists $_[0]->{$key};
274                 return $_[0]->{$key};
275             };
276         }
277     }
278
279     return %methods;
280 }
281
282 sub _make_wrapped_methods {
283     my $self = shift;
284
285     my %methods;
286
287     my $wrapped_methods = $self->options->{wrapped};
288
289     my $metameta = Class::MOP::class_of($self->metaclass);
290
291     foreach my $method_name ( keys %{$wrapped_methods} ) {
292         my $method = $metameta->find_method_by_name($method_name);
293
294         ( defined $method )
295             || confess "Could not find the method '$method_name' in "
296             . $self->metaclass->name;
297
298         my $wrapper = $wrapped_methods->{$method_name};
299
300         $methods{$method_name} = sub { $wrapper->( $method, @_ ) };
301     }
302
303     return %methods;
304 }
305
306 sub make_metaclass_mutable {
307     my $self = shift;
308
309     my $metaclass = $self->metaclass;
310
311     my $original_class = $metaclass->get_mutable_metaclass_name;
312     delete $metaclass->{'___original_class'};
313     bless $metaclass => $original_class;
314
315     my $memoized_methods = $self->options->{memoize};
316     foreach my $method_name ( keys %{$memoized_methods} ) {
317         my $type = $memoized_methods->{$method_name};
318
319         ( $metaclass->can($method_name) )
320             || confess "Could not find the method '$method_name' in "
321             . $metaclass->name;
322         if ( $type eq 'SCALAR' || $type eq 'ARRAY' || $type eq 'HASH' ) {
323             delete $metaclass->{ '___' . $method_name };
324         }
325     }
326
327     if (   $self->options->{inline_destructor}
328         && $metaclass->has_method('DESTROY') ) {
329         $metaclass->remove_method('DESTROY')
330             if blessed( $metaclass->get_method('DESTROY') ) eq
331                 $self->options->{destructor_class};
332     }
333
334     # NOTE:
335     # 14:01 <@stevan> nah,. you shouldnt
336     # 14:01 <@stevan> they are just inlined
337     # 14:01 <@stevan> which is the default in Moose anyway
338     # 14:02 <@stevan> and adding new attributes will just DWIM
339     # 14:02 <@stevan> and you really cant change an attribute anyway
340     # if ($options{inline_accessors}) {
341     #     foreach my $attr_name ($immutable->get_attribute_list) {
342     #         my $attr = $immutable->get_attribute($attr_name);
343     #         $attr->remove_accessors;
344     #         $attr->install_accessors(0);
345     #     }
346     # }
347
348     # 14:26 <@stevan> the only user of ::Method::Constructor is immutable
349     # 14:27 <@stevan> if someone uses it outside of immutable,.. they are either: mst or groditi
350     # 14:27 <@stevan> so I am not worried
351     if (   $self->options->{inline_constructor}
352         && $metaclass->has_method( $self->options->{constructor_name} ) ) {
353         my $constructor_class = $self->options->{constructor_class}
354             || 'Class::MOP::Method::Constructor';
355
356         if (
357             blessed(
358                 $metaclass->get_method( $self->options->{constructor_name} )
359             ) eq $constructor_class
360             ) {
361             $metaclass->remove_method( $self->options->{constructor_name} );
362             $self->{inlined_constructor} = undef;
363         }
364     }
365 }
366
367 1;
368
369 __END__
370
371 =pod
372
373 =head1 NAME
374
375 Class::MOP::Immutable - A class to transform Class::MOP::Class metaclasses
376
377 =head1 SYNOPSIS
378
379     use Class::MOP::Immutable;
380
381     my $immutable_metaclass = Class::MOP::Immutable->new($metaclass, {
382         read_only   => [qw/superclasses/],
383         cannot_call => [qw/
384             add_method
385             alias_method
386             remove_method
387             add_attribute
388             remove_attribute
389             add_package_symbol
390             remove_package_symbol
391         /],
392         memoize     => {
393             class_precedence_list => 'ARRAY',
394             get_all_attributes    => 'ARRAY',
395             get_meta_instance     => 'SCALAR',
396             get_method_map        => 'SCALAR',
397         }
398     });
399
400     $immutable_metaclass->make_metaclass_immutable;
401
402 =head1 DESCRIPTION
403
404 This class encapsulates the logic behind immutabilization.
405
406 This class provides generic immutabilization logic. Decisions about
407 I<what> gets transformed are up to the caller.
408
409 Immutabilization allows for a number of transformations. It can ask
410 the calling metaclass to inline methods such as the constructor,
411 destructor, or accessors. It can memoize metaclass accessors
412 themselves. It can also turn read-write accessors in the metaclass
413 into read-only methods, and make attempting to set these values an
414 error. Finally, it can make some methods throw an exception when they
415 are called. This is used to disable methods that can alter the class.
416
417 =head1 METHODS
418
419 =over 4
420
421 =item B<< Class::MOP::Immutable->new($metaclass, %options) >>
422
423 This method takes a metaclass object (typically a L<Class::MOP::Class>
424 object) and a hash of options.
425
426 It returns a new transformer, but does not actually do any
427 transforming yet.
428
429 This method accepts the following options:
430
431 =over 8
432
433 =item * inline_accessors
434
435 =item * inline_constructor
436
437 =item * inline_destructor
438
439 These are all booleans indicating whether the specified method(s)
440 should be inlined.
441
442 By default, accessors and the constructor are inlined, but not the
443 destructor.
444
445 =item * replace_constructor
446
447 This is a boolean indicating whether an existing constructor should be
448 replaced when inlining a constructor. This defaults to false.
449
450 =item * constructor_name
451
452 This is the constructor method name. This defaults to "new".
453
454 =item * constructor_class
455
456 The name of the method metaclass for constructors. It will be used to
457 generate the inlined constructor. This defaults to
458 "Class::MOP::Method::Constructor".
459
460 =item * destructor_class
461
462 The name of the method metaclass for destructors. It will be used to
463 generate the inlined destructor. This defaults to
464 "Class::MOP::Method::Denstructor".
465
466 =item * memoize
467
468 This option takes a hash reference. They keys are method names to be
469 memoized, and the values are the type of data the method returns. This
470 can be one of "SCALAR", "ARRAY", or "HASH".
471
472 =item * read_only
473
474 This option takes an array reference of read-write methods which will
475 be made read-only. After they are transformed, attempting to set them
476 will throw an error.
477
478 =item * cannot_call
479
480 This option takes an array reference of methods which cannot be called
481 after immutabilization. Attempting to call these methods will throw an
482 error.
483
484 =item * wrapped
485
486 This option takes a hash reference. The keys are method names and the
487 body is a subroutine reference which will wrap the named method. This
488 allows you to do some sort of custom transformation to a method.
489
490 =back
491
492 =item B<< $transformer->options >>
493
494 Returns a hash reference of the options passed to C<new>.
495
496 =item B<< $transformer->metaclass >>
497
498 Returns the metaclass object passed to C<new>.
499
500 =item B<< $transformer->immutable_metaclass >>
501
502 Returns the immutable metaclass object that is created by the
503 transformation process.
504
505 =item B<< $transformer->inlined_constructor >>
506
507 If the constructor was inlined, this returns the constructor method
508 object that was created to do this.
509
510 =item B<< $transformer->make_metaclass_immutable >>
511
512 Makes the transformer's metaclass immutable.
513
514 =item B<< $transformer->make_metaclass_mutable >>
515
516 Makes the transformer's metaclass mutable.
517
518 =back
519
520 =head1 AUTHORS
521
522 Stevan Little E<lt>stevan@iinteractive.comE<gt>
523
524 =head1 COPYRIGHT AND LICENSE
525
526 Copyright 2006-2009 by Infinity Interactive, Inc.
527
528 L<http://www.iinteractive.com>
529
530 This library is free software; you can redistribute it and/or modify
531 it under the same terms as Perl itself.
532
533 =cut