2 package Class::MOP::Immutable;
7 use Class::MOP::Method::Constructor;
10 use Scalar::Util 'blessed';
12 our $VERSION = '0.80';
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 $self->metaclass->add_method( 'DESTROY' => $destructor );
147 sub _check_memoized_methods {
150 my $memoized_methods = $self->options->{memoize};
151 foreach my $method_name ( keys %{$memoized_methods} ) {
152 my $type = $memoized_methods->{$method_name};
154 ( $self->metaclass->can($method_name) )
155 || confess "Could not find the method '$method_name' in "
156 . $self->metaclass->name;
159 my %DEFAULT_METHODS = (
160 # I don't really understand this, but removing it breaks tests (groditi)
163 # if it is not blessed, then someone is asking
164 # for the meta of Class::MOP::Immutable
165 return Class::MOP::Class->initialize($self) unless blessed($self);
166 # otherwise, they are asking for the metaclass
167 # which has been made immutable, which is itself
168 # except in the cases where it is a metaclass itself
169 # that has been made immutable and for that we need
171 if ($self->isa('Class::MOP::Class')) {
172 return Class::MOP::class_of($self->{'___original_class'});
178 is_mutable => sub { 0 },
179 is_immutable => sub { 1 },
180 make_immutable => sub { () },
183 sub _create_methods_for_immutable_metaclass {
186 my $metaclass = $self->metaclass;
187 my $meta = Class::MOP::class_of($metaclass);
191 $self->_make_read_only_methods,
192 $self->_make_uncallable_methods,
193 $self->_make_memoized_methods,
194 $self->_make_wrapped_methods,
195 get_mutable_metaclass_name => sub { (shift)->{'___original_class'} },
196 immutable_transformer => sub {$self},
200 sub _make_read_only_methods {
203 my $metameta = Class::MOP::class_of($self->metaclass);
206 foreach my $read_only_method ( @{ $self->options->{read_only} } ) {
207 my $method = $metameta->find_method_by_name($read_only_method);
210 || confess "Could not find the method '$read_only_method' in "
211 . $self->metaclass->name;
213 $methods{$read_only_method} = sub {
214 confess "This method is read-only" if scalar @_ > 1;
215 goto &{ $method->body };
222 sub _make_uncallable_methods {
226 foreach my $cannot_call_method ( @{ $self->options->{cannot_call} } ) {
227 $methods{$cannot_call_method} = sub {
229 "This method ($cannot_call_method) cannot be called on an immutable instance";
236 sub _make_memoized_methods {
241 my $metameta = Class::MOP::class_of($self->metaclass);
243 my $memoized_methods = $self->options->{memoize};
244 foreach my $method_name ( keys %{$memoized_methods} ) {
245 my $type = $memoized_methods->{$method_name};
246 my $key = '___' . $method_name;
247 my $method = $metameta->find_method_by_name($method_name);
249 if ( $type eq 'ARRAY' ) {
250 $methods{$method_name} = sub {
251 @{ $_[0]->{$key} } = $method->execute( $_[0] )
252 if !exists $_[0]->{$key};
253 return @{ $_[0]->{$key} };
256 elsif ( $type eq 'HASH' ) {
257 $methods{$method_name} = sub {
258 %{ $_[0]->{$key} } = $method->execute( $_[0] )
259 if !exists $_[0]->{$key};
260 return %{ $_[0]->{$key} };
263 elsif ( $type eq 'SCALAR' ) {
264 $methods{$method_name} = sub {
265 $_[0]->{$key} = $method->execute( $_[0] )
266 if !exists $_[0]->{$key};
267 return $_[0]->{$key};
275 sub _make_wrapped_methods {
280 my $wrapped_methods = $self->options->{wrapped};
282 my $metameta = Class::MOP::class_of($self->metaclass);
284 foreach my $method_name ( keys %{$wrapped_methods} ) {
285 my $method = $metameta->find_method_by_name($method_name);
288 || confess "Could not find the method '$method_name' in "
289 . $self->metaclass->name;
291 my $wrapper = $wrapped_methods->{$method_name};
293 $methods{$method_name} = sub { $wrapper->( $method, @_ ) };
299 sub make_metaclass_mutable {
302 my $metaclass = $self->metaclass;
304 my $original_class = $metaclass->get_mutable_metaclass_name;
305 delete $metaclass->{'___original_class'};
306 bless $metaclass => $original_class;
308 my $memoized_methods = $self->options->{memoize};
309 foreach my $method_name ( keys %{$memoized_methods} ) {
310 my $type = $memoized_methods->{$method_name};
312 ( $metaclass->can($method_name) )
313 || confess "Could not find the method '$method_name' in "
315 if ( $type eq 'SCALAR' || $type eq 'ARRAY' || $type eq 'HASH' ) {
316 delete $metaclass->{ '___' . $method_name };
320 if ( $self->options->{inline_destructor}
321 && $metaclass->has_method('DESTROY') ) {
322 $metaclass->remove_method('DESTROY')
323 if blessed( $metaclass->get_method('DESTROY') ) eq
324 $self->options->{destructor_class};
328 # 14:01 <@stevan> nah,. you shouldnt
329 # 14:01 <@stevan> they are just inlined
330 # 14:01 <@stevan> which is the default in Moose anyway
331 # 14:02 <@stevan> and adding new attributes will just DWIM
332 # 14:02 <@stevan> and you really cant change an attribute anyway
333 # if ($options{inline_accessors}) {
334 # foreach my $attr_name ($immutable->get_attribute_list) {
335 # my $attr = $immutable->get_attribute($attr_name);
336 # $attr->remove_accessors;
337 # $attr->install_accessors(0);
341 # 14:26 <@stevan> the only user of ::Method::Constructor is immutable
342 # 14:27 <@stevan> if someone uses it outside of immutable,.. they are either: mst or groditi
343 # 14:27 <@stevan> so I am not worried
344 if ( $self->options->{inline_constructor}
345 && $metaclass->has_method( $self->options->{constructor_name} ) ) {
346 my $constructor_class = $self->options->{constructor_class}
347 || 'Class::MOP::Method::Constructor';
351 $metaclass->get_method( $self->options->{constructor_name} )
352 ) eq $constructor_class
354 $metaclass->remove_method( $self->options->{constructor_name} );
355 $self->{inlined_constructor} = undef;
368 Class::MOP::Immutable - A class to transform Class::MOP::Class metaclasses
372 use Class::MOP::Immutable;
374 my $immutable_metaclass = Class::MOP::Immutable->new($metaclass, {
375 read_only => [qw/superclasses/],
383 remove_package_symbol
386 class_precedence_list => 'ARRAY',
387 compute_all_applicable_attributes => 'ARRAY',
388 get_meta_instance => 'SCALAR',
389 get_method_map => 'SCALAR',
393 $immutable_metaclass->make_metaclass_immutable;
397 This class encapsulates the logic behind immutabilization.
399 This class provides generic immutabilization logic. Decisions about
400 I<what> gets transformed are up to the caller.
402 Immutabilization allows for a number of transformations. It can ask
403 the calling metaclass to inline methods such as the constructor,
404 destructor, or accessors. It can memoize metaclass accessors
405 themselves. It can also turn read-write accessors in the metaclass
406 into read-only methods, and make attempting to set these values an
407 error. Finally, it can make some methods throw an exception when they
408 are called. This is used to disable methods that can alter the class.
414 =item B<< Class::MOP::Immutable->new($metaclass, %options) >>
416 This method takes a metaclass object (typically a L<Class::MOP::Class>
417 object) and a hash of options.
419 It returns a new transformer, but does not actually do any
422 This method accepts the following options:
426 =item * inline_accessors
428 =item * inline_constructor
430 =item * inline_destructor
432 These are all booleans indicating whether the specified method(s)
435 By default, accessors and the constructor are inlined, but not the
438 =item * replace_constructor
440 This is a boolean indicating whether an existing constructor should be
441 replaced when inlining a constructor. This defaults to false.
443 =item * constructor_name
445 This is the constructor method name. This defaults to "new".
447 =item * constructor_class
449 The name of the method metaclass for constructors. It will be used to
450 generate the inlined constructor. This defaults to
451 "Class::MOP::Method::Constructor".
453 =item * destructor_class
455 The name of the method metaclass for destructors. It will be used to
456 generate the inlined destructor. This defaults to
457 "Class::MOP::Method::Denstructor".
461 This option takes a hash reference. They keys are method names to be
462 memoized, and the values are the type of data the method returns. This
463 can be one of "SCALAR", "ARRAY", or "HASH".
467 This option takes an array reference of read-write methods which will
468 be made read-only. After they are transformed, attempting to set them
473 This option takes an array reference of methods which cannot be called
474 after immutabilization. Attempting to call these methods will throw an
479 This option takes a hash reference. The keys are method names and the
480 body is a subroutine reference which will wrap the named method. This
481 allows you to do some sort of custom transformation to a method.
485 =item B<< $transformer->options >>
487 Returns a hash reference of the options passed to C<new>.
489 =item B<< $transformer->metaclass >>
491 Returns the metaclass object passed to C<new>.
493 =item B<< $transformer->immutable_metaclass >>
495 Returns the immutable metaclass object that is created by the
496 transformation process.
498 =item B<< $transformer->inlined_constructor >>
500 If the constructor was inlined, this returns the constructor method
501 object that was created to do this.
503 =item B<< $transformer->make_metaclass_immutable >>
505 Makes the transformer's metaclass immutable.
507 =item B<< $transformer->make_metaclass_mutable >>
509 Makes the transformer's metaclass mutable.
515 Stevan Little E<lt>stevan@iinteractive.comE<gt>
517 =head1 COPYRIGHT AND LICENSE
519 Copyright 2006-2009 by Infinity Interactive, Inc.
521 L<http://www.iinteractive.com>
523 This library is free software; you can redistribute it and/or modify
524 it under the same terms as Perl itself.