2 package Class::MOP::Immutable;
7 use Class::MOP::Method::Constructor;
10 use Scalar::Util 'blessed';
12 our $VERSION = '0.77';
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 is basically a module for applying a transformation on a given
410 metaclass. Current features include making methods read-only,
411 making methods un-callable and memoizing methods (in a type specific
414 This module is not for the feint of heart, it does some whacky things
415 to the metaclass in order to make it immutable. If you are just curious,
416 I suggest you turn back now, there is nothing to see here.
422 =item B<new ($metaclass, \%options)>
424 Given a C<$metaclass> and a set of C<%options> this module will
425 prepare an immutable version of the C<$metaclass>, which can then
426 be applied to the C<$metaclass> using the C<make_metaclass_immutable>
431 Returns the options HASH set in C<new>.
435 Returns the metaclass set in C<new>.
437 =item B<immutable_metaclass>
439 Returns the immutable metaclass created within C<new>.
445 =item B<create_immutable_metaclass>
447 This will create the immutable version of the C<$metaclass>, but will
448 not actually change the original metaclass.
450 =item B<create_methods_for_immutable_metaclass>
452 This will create all the methods for the immutable metaclass based
453 on the C<%options> passed into C<new>.
455 =item B<make_metaclass_immutable (%options)>
457 This will actually change the C<$metaclass> into the immutable version.
459 =item B<make_metaclass_mutable (%options)>
461 This will change the C<$metaclass> into the mutable version by reversing
462 the immutable process. C<%options> should be the same options that were
463 given to make_metaclass_immutable.
465 =item B<inlined_constructor>
467 If the constructor was inlined, this returns the constructor method
468 object that was created to do this.
474 Stevan Little E<lt>stevan@iinteractive.comE<gt>
476 =head1 COPYRIGHT AND LICENSE
478 Copyright 2006-2008 by Infinity Interactive, Inc.
480 L<http://www.iinteractive.com>
482 This library is free software; you can redistribute it and/or modify
483 it under the same terms as Perl itself.