2 package Class::MOP::Immutable;
7 use Class::MOP::Method::Constructor;
10 use Scalar::Util 'blessed';
12 our $VERSION = '0.78';
13 $VERSION = eval $VERSION;
14 our $AUTHORITY = 'cpan:STEVAN';
16 use base 'Class::MOP::Object';
19 my ($class, @args) = @_;
21 my ( $metaclass, $options );
25 ( $metaclass, $options ) = @args;
27 unshift @args, "metaclass" if @args % 2 == 1;
32 $metaclass = $options{metaclass};
35 my $self = $class->_new(
36 'metaclass' => $metaclass,
37 'options' => $options,
38 'immutable_metaclass' => undef,
39 'inlined_constructor' => undef,
47 my $options = @_ == 1 ? $_[0] : {@_};
49 bless $options, $class;
52 sub immutable_metaclass {
55 $self->create_immutable_metaclass unless $self->{'immutable_metaclass'};
57 return $self->{'immutable_metaclass'};
60 sub metaclass { (shift)->{'metaclass'} }
61 sub options { (shift)->{'options'} }
62 sub inlined_constructor { (shift)->{'inlined_constructor'} }
64 sub create_immutable_metaclass {
68 # The immutable version of the
69 # metaclass is just a anon-class
70 # which shadows the methods
72 $self->{'immutable_metaclass'} = Class::MOP::Class->create_anon_class(
73 superclasses => [ blessed($self->metaclass) ],
74 methods => $self->create_methods_for_immutable_metaclass,
79 my %DEFAULT_METHODS = (
80 # I don't really understand this, but removing it breaks tests (groditi)
83 # if it is not blessed, then someone is asking
84 # for the meta of Class::MOP::Immutable
85 return Class::MOP::Class->initialize($self) unless blessed($self);
86 # otherwise, they are asking for the metaclass
87 # which has been made immutable, which is itself
88 # except in the cases where it is a metaclass itself
89 # that has been made immutable and for that we need
91 if ($self->isa('Class::MOP::Class')) {
92 return $self->{'___original_class'}->meta;
98 is_mutable => sub { 0 },
99 is_immutable => sub { 1 },
100 make_immutable => sub { () },
104 # this will actually convert the
105 # existing metaclass to an immutable
107 sub make_metaclass_immutable {
108 my ($self, $metaclass, $options) = @_;
111 inline_accessors => 1,
112 inline_constructor => 1,
113 inline_destructor => 0,
114 constructor_name => 'new',
119 %$options = %options; # FIXME who the hell is relying on this?!? tests fail =(
121 $self->_inline_accessors( $metaclass, \%options );
122 $self->_inline_constructor( $metaclass, \%options );
123 $self->_inline_destructor( $metaclass, \%options );
124 $self->_check_memoized_methods( $metaclass, \%options );
126 $metaclass->{'___original_class'} = blessed($metaclass);
127 bless $metaclass => $self->immutable_metaclass->name;
130 sub _inline_accessors {
131 my ( $self, $metaclass, $options ) = @_;
133 return unless $options->{inline_accessors};
135 foreach my $attr_name ( $metaclass->get_attribute_list ) {
136 $metaclass->get_attribute($attr_name)->install_accessors(1);
140 sub _inline_constructor {
141 my ( $self, $metaclass, $options ) = @_;
143 return unless $options->{inline_constructor};
146 unless $options->{replace_constructor}
147 or !$metaclass->has_method( $options->{constructor_name} );
149 my $constructor_class = $options->{constructor_class}
150 || 'Class::MOP::Method::Constructor';
152 my $constructor = $constructor_class->new(
154 metaclass => $metaclass,
156 package_name => $metaclass->name,
157 name => $options->{constructor_name},
160 if ( $options->{replace_constructor} or $constructor->can_be_inlined ) {
161 $metaclass->add_method( $options->{constructor_name} => $constructor );
162 $self->{inlined_constructor} = $constructor;
166 sub _inline_destructor {
167 my ( $self, $metaclass, $options ) = @_;
169 return unless $options->{inline_destructor};
171 ( exists $options->{destructor_class} )
172 || confess "The 'inline_destructor' option is present, but "
173 . "no destructor class was specified";
175 my $destructor_class = $options->{destructor_class};
177 return unless $destructor_class->is_needed($metaclass);
179 my $destructor = $destructor_class->new(
181 metaclass => $metaclass,
182 package_name => $metaclass->name,
186 return unless $destructor->is_needed;
188 $metaclass->add_method( 'DESTROY' => $destructor )
191 sub _check_memoized_methods {
192 my ( $self, $metaclass, $options ) = @_;
194 my $memoized_methods = $self->options->{memoize};
195 foreach my $method_name ( keys %{$memoized_methods} ) {
196 my $type = $memoized_methods->{$method_name};
198 ( $metaclass->can($method_name) )
199 || confess "Could not find the method '$method_name' in "
204 sub create_methods_for_immutable_metaclass {
207 my %methods = %DEFAULT_METHODS;
208 my $metaclass = $self->metaclass;
209 my $meta = $metaclass->meta;
211 $methods{get_mutable_metaclass_name}
212 = sub { (shift)->{'___original_class'} };
214 $methods{immutable_transformer} = sub {$self};
218 $self->_make_read_only_methods( $metaclass, $meta ),
219 $self->_make_uncallable_methods( $metaclass, $meta ),
220 $self->_make_memoized_methods( $metaclass, $meta ),
221 $self->_make_wrapped_methods( $metaclass, $meta ),
222 get_mutable_metaclass_name => sub { (shift)->{'___original_class'} },
223 immutable_transformer => sub {$self},
227 sub _make_read_only_methods {
228 my ( $self, $metaclass, $meta ) = @_;
231 foreach my $read_only_method ( @{ $self->options->{read_only} } ) {
232 my $method = $meta->find_method_by_name($read_only_method);
235 || confess "Could not find the method '$read_only_method' in "
238 $methods{$read_only_method} = sub {
239 confess "This method is read-only" if scalar @_ > 1;
240 goto &{ $method->body };
247 sub _make_uncallable_methods {
248 my ( $self, $metaclass, $meta ) = @_;
251 foreach my $cannot_call_method ( @{ $self->options->{cannot_call} } ) {
252 $methods{$cannot_call_method} = sub {
254 "This method ($cannot_call_method) cannot be called on an immutable instance";
261 sub _make_memoized_methods {
262 my ( $self, $metaclass, $meta ) = @_;
266 my $memoized_methods = $self->options->{memoize};
267 foreach my $method_name ( keys %{$memoized_methods} ) {
268 my $type = $memoized_methods->{$method_name};
269 my $key = '___' . $method_name;
270 my $method = $meta->find_method_by_name($method_name);
272 if ( $type eq 'ARRAY' ) {
273 $methods{$method_name} = sub {
274 @{ $_[0]->{$key} } = $method->execute( $_[0] )
275 if !exists $_[0]->{$key};
276 return @{ $_[0]->{$key} };
279 elsif ( $type eq 'HASH' ) {
280 $methods{$method_name} = sub {
281 %{ $_[0]->{$key} } = $method->execute( $_[0] )
282 if !exists $_[0]->{$key};
283 return %{ $_[0]->{$key} };
286 elsif ( $type eq 'SCALAR' ) {
287 $methods{$method_name} = sub {
288 $_[0]->{$key} = $method->execute( $_[0] )
289 if !exists $_[0]->{$key};
290 return $_[0]->{$key};
298 sub _make_wrapped_methods {
299 my ( $self, $metaclass, $meta ) = @_;
303 my $wrapped_methods = $self->options->{wrapped};
305 foreach my $method_name ( keys %{$wrapped_methods} ) {
306 my $method = $meta->find_method_by_name($method_name);
309 || confess "Could not find the method '$method_name' in "
312 my $wrapper = $wrapped_methods->{$method_name};
314 $methods{$method_name} = sub { $wrapper->( $method, @_ ) };
320 sub make_metaclass_mutable {
321 my ($self, $immutable, $options) = @_;
323 my %options = %$options;
325 my $original_class = $immutable->get_mutable_metaclass_name;
326 delete $immutable->{'___original_class'} ;
327 bless $immutable => $original_class;
329 my $memoized_methods = $self->options->{memoize};
330 foreach my $method_name (keys %{$memoized_methods}) {
331 my $type = $memoized_methods->{$method_name};
333 ($immutable->can($method_name))
334 || confess "Could not find the method '$method_name' in " . $immutable->name;
335 if ($type eq 'SCALAR' || $type eq 'ARRAY' || $type eq 'HASH' ) {
336 delete $immutable->{'___' . $method_name};
340 if ($options{inline_destructor} && $immutable->has_method('DESTROY')) {
341 $immutable->remove_method('DESTROY')
342 if blessed($immutable->get_method('DESTROY')) eq $options{destructor_class};
346 # 14:01 <@stevan> nah,. you shouldnt
347 # 14:01 <@stevan> they are just inlined
348 # 14:01 <@stevan> which is the default in Moose anyway
349 # 14:02 <@stevan> and adding new attributes will just DWIM
350 # 14:02 <@stevan> and you really cant change an attribute anyway
351 # if ($options{inline_accessors}) {
352 # foreach my $attr_name ($immutable->get_attribute_list) {
353 # my $attr = $immutable->get_attribute($attr_name);
354 # $attr->remove_accessors;
355 # $attr->install_accessors(0);
359 # 14:26 <@stevan> the only user of ::Method::Constructor is immutable
360 # 14:27 <@stevan> if someone uses it outside of immutable,.. they are either: mst or groditi
361 # 14:27 <@stevan> so I am not worried
362 if ($options{inline_constructor} && $immutable->has_method($options{constructor_name})) {
363 my $constructor_class = $options{constructor_class} || 'Class::MOP::Method::Constructor';
365 if ( blessed($immutable->get_method($options{constructor_name})) eq $constructor_class ) {
366 $immutable->remove_method( $options{constructor_name} );
367 $self->{inlined_constructor} = undef;
380 Class::MOP::Immutable - A class to transform Class::MOP::Class metaclasses
384 use Class::MOP::Immutable;
386 my $immutable_metaclass = Class::MOP::Immutable->new($metaclass, {
387 read_only => [qw/superclasses/],
395 remove_package_symbol
398 class_precedence_list => 'ARRAY',
399 compute_all_applicable_attributes => 'ARRAY',
400 get_meta_instance => 'SCALAR',
401 get_method_map => 'SCALAR',
405 $immutable_metaclass->make_metaclass_immutable(@_)
409 This class encapsulates the logic behind immutabilization.
411 This class provides generic immutabilization logic. Decisions about
412 I<what> gets transformed are up to the caller.
414 Immutabilization allows for a number of transformations. It can ask
415 the calling metaclass to inline methods such as the constructor,
416 destructor, or accessors. It can memoize metaclass accessors
417 themselves. It can also turn read-write accessors in the metaclass
418 into read-only methods, and make attempting to set these values an
419 error. Finally, it can make some methods throw an exception when they
420 are called. This is used to disable methods that can alter the class.
426 =item B<< Class::MOP::Immutable->new($metaclass, %options) >>
428 This method takes a metaclass object (typically a L<Class::MOP::Class>
429 object) and a hash of options.
431 It returns a new transformer, but does not actually do any
434 This method accepts the following options:
438 =item * inline_accessors
440 =item * inline_constructor
442 =item * inline_destructor
444 These are all booleans indicating whether the specified method(s)
447 By default, accessors and the constructor are inlined, but not the
450 =item * replace_constructor
452 This is a boolean indicating whether an existing constructor should be
453 replaced when inlining a constructor. This defaults to false.
455 =item * constructor_name
457 This is the constructor method name. This defaults to "new".
459 =item * constructor_class
461 The name of the method metaclass for constructors. It will be used to
462 generate the inlined constructor. This defaults to
463 "Class::MOP::Method::Constructor".
465 =item * destructor_class
467 The name of the method metaclass for destructors. It will be used to
468 generate the inlined destructor. This defaults to
469 "Class::MOP::Method::Denstructor".
473 This option takes a hash reference. They keys are method names to be
474 memoized, and the values are the type of data the method returns. This
475 can be one of "SCALAR", "ARRAY", or "HASH".
479 This option takes an array reference of read-write methods which will
480 be made read-only. After they are transformed, attempting to set them
485 This option takes an array reference of methods which cannot be called
486 after immutabilization. Attempting to call these methods will throw an
491 This option takes a hash reference. The keys are method names and the
492 body is a subroutine reference which will wrap the named method. This
493 allows you to do some sort of custom transformation to a method.
497 =item B<< $transformer->options >>
499 Returns a hash reference of the options passed to C<new>.
501 =item B<< $transformer->metaclass >>
503 Returns the metaclass object passed to C<new>.
505 =item B<< $transformer->immutable_metaclass >>
507 Returns the immutable metaclass object that is created by the
508 transformation process.
510 =item B<< $transformer->inlined_constructor >>
512 If the constructor was inlined, this returns the constructor method
513 object that was created to do this.
519 Stevan Little E<lt>stevan@iinteractive.comE<gt>
521 =head1 COPYRIGHT AND LICENSE
523 Copyright 2006-2009 by Infinity Interactive, Inc.
525 L<http://www.iinteractive.com>
527 This library is free software; you can redistribute it and/or modify
528 it under the same terms as Perl itself.