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 unshift @args, 'metaclass' if @args % 2 == 1;
24 inline_accessors => 1,
25 inline_constructor => 1,
26 inline_destructor => 0,
27 constructor_name => 'new',
28 constructor_class => 'Class::MOP::Method::Constructor',
33 my $self = $class->_new(
34 'metaclass' => delete $options{metaclass},
35 'options' => \%options,
36 'immutable_metaclass' => undef,
37 'inlined_constructor' => undef,
45 my $options = @_ == 1 ? $_[0] : {@_};
47 bless $options, $class;
50 sub immutable_metaclass {
53 return $self->{'immutable_metaclass'} ||= $self->_create_immutable_metaclass;
56 sub metaclass { (shift)->{'metaclass'} }
57 sub options { (shift)->{'options'} }
58 sub inlined_constructor { (shift)->{'inlined_constructor'} }
60 sub _create_immutable_metaclass {
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,
71 sub make_metaclass_immutable {
74 $self->_inline_accessors;
75 $self->_inline_constructor;
76 $self->_inline_destructor;
77 $self->_check_memoized_methods;
79 my $metaclass = $self->metaclass;
81 $metaclass->{'___original_class'} = blessed($metaclass);
82 bless $metaclass => $self->immutable_metaclass->name;
85 sub _inline_accessors {
88 return unless $self->options->{inline_accessors};
90 foreach my $attr_name ( $self->metaclass->get_attribute_list ) {
91 $self->metaclass->get_attribute($attr_name)->install_accessors(1);
95 sub _inline_constructor {
98 return unless $self->options->{inline_constructor};
101 unless $self->options->{replace_constructor}
102 or !$self->metaclass->has_method(
103 $self->options->{constructor_name}
106 my $constructor_class = $self->options->{constructor_class};
108 my $constructor = $constructor_class->new(
109 options => $self->options,
110 metaclass => $self->metaclass,
112 package_name => $self->metaclass->name,
113 name => $self->options->{constructor_name},
116 if ( $self->options->{replace_constructor}
117 or $constructor->can_be_inlined ) {
118 $self->metaclass->add_method(
119 $self->options->{constructor_name} => $constructor );
120 $self->{inlined_constructor} = $constructor;
124 sub _inline_destructor {
127 return unless $self->options->{inline_destructor};
129 ( exists $self->options->{destructor_class} )
130 || confess "The 'inline_destructor' option is present, but "
131 . "no destructor class was specified";
133 my $destructor_class = $self->options->{destructor_class};
135 return unless $destructor_class->is_needed( $self->metaclass );
137 my $destructor = $destructor_class->new(
138 options => $self->options,
139 metaclass => $self->metaclass,
140 package_name => $self->metaclass->name,
144 return unless $destructor->is_needed;
146 $self->metaclass->add_method( 'DESTROY' => $destructor );
149 sub _check_memoized_methods {
152 my $memoized_methods = $self->options->{memoize};
153 foreach my $method_name ( keys %{$memoized_methods} ) {
154 my $type = $memoized_methods->{$method_name};
156 ( $self->metaclass->can($method_name) )
157 || confess "Could not find the method '$method_name' in "
158 . $self->metaclass->name;
161 my %DEFAULT_METHODS = (
162 # I don't really understand this, but removing it breaks tests (groditi)
165 # if it is not blessed, then someone is asking
166 # for the meta of Class::MOP::Immutable
167 return Class::MOP::Class->initialize($self) unless blessed($self);
168 # otherwise, they are asking for the metaclass
169 # which has been made immutable, which is itself
170 # except in the cases where it is a metaclass itself
171 # that has been made immutable and for that we need
173 if ($self->isa('Class::MOP::Class')) {
174 return $self->{'___original_class'}->meta;
180 is_mutable => sub { 0 },
181 is_immutable => sub { 1 },
182 make_immutable => sub { () },
185 sub _create_methods_for_immutable_metaclass {
188 my $metaclass = $self->metaclass;
189 my $meta = $metaclass->meta;
193 $self->_make_read_only_methods,
194 $self->_make_uncallable_methods,
195 $self->_make_memoized_methods,
196 $self->_make_wrapped_methods,
197 get_mutable_metaclass_name => sub { (shift)->{'___original_class'} },
198 immutable_transformer => sub {$self},
202 sub _make_read_only_methods {
205 my $metameta = $self->metaclass->meta;
208 foreach my $read_only_method ( @{ $self->options->{read_only} } ) {
209 my $method = $metameta->find_method_by_name($read_only_method);
212 || confess "Could not find the method '$read_only_method' in "
213 . $self->metaclass->name;
215 $methods{$read_only_method} = sub {
216 confess "This method is read-only" if scalar @_ > 1;
217 goto &{ $method->body };
224 sub _make_uncallable_methods {
228 foreach my $cannot_call_method ( @{ $self->options->{cannot_call} } ) {
229 $methods{$cannot_call_method} = sub {
231 "This method ($cannot_call_method) cannot be called on an immutable instance";
238 sub _make_memoized_methods {
243 my $metameta = $self->metaclass->meta;
245 my $memoized_methods = $self->options->{memoize};
246 foreach my $method_name ( keys %{$memoized_methods} ) {
247 my $type = $memoized_methods->{$method_name};
248 my $key = '___' . $method_name;
249 my $method = $metameta->find_method_by_name($method_name);
251 if ( $type eq 'ARRAY' ) {
252 $methods{$method_name} = sub {
253 @{ $_[0]->{$key} } = $method->execute( $_[0] )
254 if !exists $_[0]->{$key};
255 return @{ $_[0]->{$key} };
258 elsif ( $type eq 'HASH' ) {
259 $methods{$method_name} = sub {
260 %{ $_[0]->{$key} } = $method->execute( $_[0] )
261 if !exists $_[0]->{$key};
262 return %{ $_[0]->{$key} };
265 elsif ( $type eq 'SCALAR' ) {
266 $methods{$method_name} = sub {
267 $_[0]->{$key} = $method->execute( $_[0] )
268 if !exists $_[0]->{$key};
269 return $_[0]->{$key};
277 sub _make_wrapped_methods {
282 my $wrapped_methods = $self->options->{wrapped};
284 my $metameta = $self->metaclass->meta;
286 foreach my $method_name ( keys %{$wrapped_methods} ) {
287 my $method = $metameta->find_method_by_name($method_name);
290 || confess "Could not find the method '$method_name' in "
291 . $self->metaclass->name;
293 my $wrapper = $wrapped_methods->{$method_name};
295 $methods{$method_name} = sub { $wrapper->( $method, @_ ) };
301 sub make_metaclass_mutable {
304 my $metaclass = $self->metaclass;
306 my $original_class = $metaclass->get_mutable_metaclass_name;
307 delete $metaclass->{'___original_class'};
308 bless $metaclass => $original_class;
310 my $memoized_methods = $self->options->{memoize};
311 foreach my $method_name ( keys %{$memoized_methods} ) {
312 my $type = $memoized_methods->{$method_name};
314 ( $metaclass->can($method_name) )
315 || confess "Could not find the method '$method_name' in "
317 if ( $type eq 'SCALAR' || $type eq 'ARRAY' || $type eq 'HASH' ) {
318 delete $metaclass->{ '___' . $method_name };
322 if ( $self->options->{inline_destructor}
323 && $metaclass->has_method('DESTROY') ) {
324 $metaclass->remove_method('DESTROY')
325 if blessed( $metaclass->get_method('DESTROY') ) eq
326 $self->options->{destructor_class};
330 # 14:01 <@stevan> nah,. you shouldnt
331 # 14:01 <@stevan> they are just inlined
332 # 14:01 <@stevan> which is the default in Moose anyway
333 # 14:02 <@stevan> and adding new attributes will just DWIM
334 # 14:02 <@stevan> and you really cant change an attribute anyway
335 # if ($options{inline_accessors}) {
336 # foreach my $attr_name ($immutable->get_attribute_list) {
337 # my $attr = $immutable->get_attribute($attr_name);
338 # $attr->remove_accessors;
339 # $attr->install_accessors(0);
343 # 14:26 <@stevan> the only user of ::Method::Constructor is immutable
344 # 14:27 <@stevan> if someone uses it outside of immutable,.. they are either: mst or groditi
345 # 14:27 <@stevan> so I am not worried
346 if ( $self->options->{inline_constructor}
347 && $metaclass->has_method( $self->options->{constructor_name} ) ) {
348 my $constructor_class = $self->options->{constructor_class}
349 || 'Class::MOP::Method::Constructor';
353 $metaclass->get_method( $self->options->{constructor_name} )
354 ) eq $constructor_class
356 $metaclass->remove_method( $self->options->{constructor_name} );
357 $self->{inlined_constructor} = undef;
370 Class::MOP::Immutable - A class to transform Class::MOP::Class metaclasses
374 use Class::MOP::Immutable;
376 my $immutable_metaclass = Class::MOP::Immutable->new($metaclass, {
377 read_only => [qw/superclasses/],
385 remove_package_symbol
388 class_precedence_list => 'ARRAY',
389 compute_all_applicable_attributes => 'ARRAY',
390 get_meta_instance => 'SCALAR',
391 get_method_map => 'SCALAR',
395 $immutable_metaclass->make_metaclass_immutable;
399 This class encapsulates the logic behind immutabilization.
401 This class provides generic immutabilization logic. Decisions about
402 I<what> gets transformed are up to the caller.
404 Immutabilization allows for a number of transformations. It can ask
405 the calling metaclass to inline methods such as the constructor,
406 destructor, or accessors. It can memoize metaclass accessors
407 themselves. It can also turn read-write accessors in the metaclass
408 into read-only methods, and make attempting to set these values an
409 error. Finally, it can make some methods throw an exception when they
410 are called. This is used to disable methods that can alter the class.
416 =item B<< Class::MOP::Immutable->new($metaclass, %options) >>
418 This method takes a metaclass object (typically a L<Class::MOP::Class>
419 object) and a hash of options.
421 It returns a new transformer, but does not actually do any
424 This method accepts the following options:
428 =item * inline_accessors
430 =item * inline_constructor
432 =item * inline_destructor
434 These are all booleans indicating whether the specified method(s)
437 By default, accessors and the constructor are inlined, but not the
440 =item * replace_constructor
442 This is a boolean indicating whether an existing constructor should be
443 replaced when inlining a constructor. This defaults to false.
445 =item * constructor_name
447 This is the constructor method name. This defaults to "new".
449 =item * constructor_class
451 The name of the method metaclass for constructors. It will be used to
452 generate the inlined constructor. This defaults to
453 "Class::MOP::Method::Constructor".
455 =item * destructor_class
457 The name of the method metaclass for destructors. It will be used to
458 generate the inlined destructor. This defaults to
459 "Class::MOP::Method::Denstructor".
463 This option takes a hash reference. They keys are method names to be
464 memoized, and the values are the type of data the method returns. This
465 can be one of "SCALAR", "ARRAY", or "HASH".
469 This option takes an array reference of read-write methods which will
470 be made read-only. After they are transformed, attempting to set them
475 This option takes an array reference of methods which cannot be called
476 after immutabilization. Attempting to call these methods will throw an
481 This option takes a hash reference. The keys are method names and the
482 body is a subroutine reference which will wrap the named method. This
483 allows you to do some sort of custom transformation to a method.
487 =item B<< $transformer->options >>
489 Returns a hash reference of the options passed to C<new>.
491 =item B<< $transformer->metaclass >>
493 Returns the metaclass object passed to C<new>.
495 =item B<< $transformer->immutable_metaclass >>
497 Returns the immutable metaclass object that is created by the
498 transformation process.
500 =item B<< $transformer->inlined_constructor >>
502 If the constructor was inlined, this returns the constructor method
503 object that was created to do this.
505 =item B<< $transformer->make_metaclass_immutable >>
507 Makes the transformer's metaclass immutable.
509 =item B<< $transformer->make_metaclass_mutable >>
511 Makes the transformer's metaclass mutable.
517 Stevan Little E<lt>stevan@iinteractive.comE<gt>
519 =head1 COPYRIGHT AND LICENSE
521 Copyright 2006-2009 by Infinity Interactive, Inc.
523 L<http://www.iinteractive.com>
525 This library is free software; you can redistribute it and/or modify
526 it under the same terms as Perl itself.