2 package Class::MOP::Immutable;
7 use Class::MOP::Method::Constructor;
10 use Scalar::Util 'blessed';
12 our $VERSION = '0.71_01';
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,
46 my $options = @_ == 1 ? $_[0] : {@_};
48 bless $options, $class;
51 sub immutable_metaclass {
54 $self->create_immutable_metaclass unless $self->{'immutable_metaclass'};
56 return $self->{'immutable_metaclass'};
59 sub metaclass { (shift)->{'metaclass'} }
60 sub options { (shift)->{'options'} }
62 sub create_immutable_metaclass {
66 # The immutable version of the
67 # metaclass is just a anon-class
68 # which shadows the methods
70 $self->{'immutable_metaclass'} = Class::MOP::Class->create_anon_class(
71 superclasses => [ blessed($self->metaclass) ],
72 methods => $self->create_methods_for_immutable_metaclass,
77 my %DEFAULT_METHODS = (
78 # I don't really understand this, but removing it breaks tests (groditi)
81 # if it is not blessed, then someone is asking
82 # for the meta of Class::MOP::Immutable
83 return Class::MOP::Class->initialize($self) unless blessed($self);
84 # otherwise, they are asking for the metaclass
85 # which has been made immutable, which is itself
86 # except in the cases where it is a metaclass itself
87 # that has been made immutable and for that we need
89 if ($self->isa('Class::MOP::Class')) {
90 return $self->{'___original_class'}->meta;
96 is_mutable => sub { 0 },
97 is_immutable => sub { 1 },
98 make_immutable => sub { () },
102 # this will actually convert the
103 # existing metaclass to an immutable
105 sub make_metaclass_immutable {
106 my ($self, $metaclass, $options) = @_;
109 inline_accessors => 1,
110 inline_constructor => 1,
111 inline_destructor => 0,
112 constructor_name => 'new',
117 %$options = %options; # FIXME who the hell is relying on this?!? tests fail =(
119 $self->_inline_accessors( $metaclass, \%options );
120 $self->_inline_constructor( $metaclass, \%options );
121 $self->_inline_destructor( $metaclass, \%options );
122 $self->_check_memoized_methods( $metaclass, \%options );
124 $metaclass->{'___original_class'} = blessed($metaclass);
125 bless $metaclass => $self->immutable_metaclass->name;
128 sub _inline_accessors {
129 my ( $self, $metaclass, $options ) = @_;
131 return unless $options->{inline_accessors};
133 foreach my $attr_name ( $metaclass->get_attribute_list ) {
134 $metaclass->get_attribute($attr_name)->install_accessors(1);
138 sub _inline_constructor {
139 my ( $self, $metaclass, $options ) = @_;
141 return unless $options->{inline_constructor};
144 unless $options->{replace_constructor}
145 or !$metaclass->has_method( $options->{constructor_name} );
147 my $constructor_class = $options->{constructor_class}
148 || 'Class::MOP::Method::Constructor';
150 my $constructor = $constructor_class->new(
152 metaclass => $metaclass,
154 package_name => $metaclass->name,
155 name => $options->{constructor_name},
158 $metaclass->add_method( $options->{constructor_name} => $constructor )
159 if $options->{replace_constructor} or $constructor->can_be_inlined;
162 sub _inline_destructor {
163 my ( $self, $metaclass, $options ) = @_;
165 return unless $options->{inline_destructor};
167 ( exists $options->{destructor_class} )
168 || confess "The 'inline_destructor' option is present, but "
169 . "no destructor class was specified";
171 my $destructor_class = $options->{destructor_class};
173 return unless $destructor_class->is_needed($metaclass);
175 my $destructor = $destructor_class->new(
177 metaclass => $metaclass,
178 package_name => $metaclass->name,
182 return unless $destructor->is_needed;
184 $metaclass->add_method( 'DESTROY' => $destructor )
187 sub _check_memoized_methods {
188 my ( $self, $metaclass, $options ) = @_;
190 my $memoized_methods = $self->options->{memoize};
191 foreach my $method_name ( keys %{$memoized_methods} ) {
192 my $type = $memoized_methods->{$method_name};
194 ( $metaclass->can($method_name) )
195 || confess "Could not find the method '$method_name' in "
200 sub create_methods_for_immutable_metaclass {
203 my %methods = %DEFAULT_METHODS;
204 my $metaclass = $self->metaclass;
205 my $meta = $metaclass->meta;
207 $methods{get_mutable_metaclass_name}
208 = sub { (shift)->{'___original_class'} };
210 $methods{immutable_transformer} = sub {$self};
214 $self->_make_read_only_methods( $metaclass, $meta ),
215 $self->_make_uncallable_methods( $metaclass, $meta ),
216 $self->_make_memoized_methods( $metaclass, $meta ),
217 $self->_make_wrapped_methods( $metaclass, $meta ),
218 get_mutable_metaclass_name => sub { (shift)->{'___original_class'} },
219 immutable_transformer => sub {$self},
223 sub _make_read_only_methods {
224 my ( $self, $metaclass, $meta ) = @_;
227 foreach my $read_only_method ( @{ $self->options->{read_only} } ) {
228 my $method = $meta->find_method_by_name($read_only_method);
231 || confess "Could not find the method '$read_only_method' in "
234 $methods{$read_only_method} = sub {
235 confess "This method is read-only" if scalar @_ > 1;
236 goto &{ $method->body };
243 sub _make_uncallable_methods {
244 my ( $self, $metaclass, $meta ) = @_;
247 foreach my $cannot_call_method ( @{ $self->options->{cannot_call} } ) {
248 $methods{$cannot_call_method} = sub {
250 "This method ($cannot_call_method) cannot be called on an immutable instance";
257 sub _make_memoized_methods {
258 my ( $self, $metaclass, $meta ) = @_;
262 my $memoized_methods = $self->options->{memoize};
263 foreach my $method_name ( keys %{$memoized_methods} ) {
264 my $type = $memoized_methods->{$method_name};
265 my $key = '___' . $method_name;
266 my $method = $meta->find_method_by_name($method_name);
268 if ( $type eq 'ARRAY' ) {
269 $methods{$method_name} = sub {
270 @{ $_[0]->{$key} } = $method->execute( $_[0] )
271 if !exists $_[0]->{$key};
272 return @{ $_[0]->{$key} };
275 elsif ( $type eq 'HASH' ) {
276 $methods{$method_name} = sub {
277 %{ $_[0]->{$key} } = $method->execute( $_[0] )
278 if !exists $_[0]->{$key};
279 return %{ $_[0]->{$key} };
282 elsif ( $type eq 'SCALAR' ) {
283 $methods{$method_name} = sub {
284 $_[0]->{$key} = $method->execute( $_[0] )
285 if !exists $_[0]->{$key};
286 return $_[0]->{$key};
294 sub _make_wrapped_methods {
295 my ( $self, $metaclass, $meta ) = @_;
299 my $wrapped_methods = $self->options->{wrapped};
301 foreach my $method_name ( keys %{$wrapped_methods} ) {
302 my $method = $meta->find_method_by_name($method_name);
305 || confess "Could not find the method '$method_name' in "
308 my $wrapper = $wrapped_methods->{$method_name};
310 $methods{$method_name} = sub { $wrapper->( $method, @_ ) };
316 sub make_metaclass_mutable {
317 my ($self, $immutable, $options) = @_;
319 my %options = %$options;
321 my $original_class = $immutable->get_mutable_metaclass_name;
322 delete $immutable->{'___original_class'} ;
323 bless $immutable => $original_class;
325 my $memoized_methods = $self->options->{memoize};
326 foreach my $method_name (keys %{$memoized_methods}) {
327 my $type = $memoized_methods->{$method_name};
329 ($immutable->can($method_name))
330 || confess "Could not find the method '$method_name' in " . $immutable->name;
331 if ($type eq 'SCALAR' || $type eq 'ARRAY' || $type eq 'HASH' ) {
332 delete $immutable->{'___' . $method_name};
336 if ($options{inline_destructor} && $immutable->has_method('DESTROY')) {
337 $immutable->remove_method('DESTROY')
338 if blessed($immutable->get_method('DESTROY')) eq $options{destructor_class};
342 # 14:01 <@stevan> nah,. you shouldnt
343 # 14:01 <@stevan> they are just inlined
344 # 14:01 <@stevan> which is the default in Moose anyway
345 # 14:02 <@stevan> and adding new attributes will just DWIM
346 # 14:02 <@stevan> and you really cant change an attribute anyway
347 # if ($options{inline_accessors}) {
348 # foreach my $attr_name ($immutable->get_attribute_list) {
349 # my $attr = $immutable->get_attribute($attr_name);
350 # $attr->remove_accessors;
351 # $attr->install_accessors(0);
355 # 14:26 <@stevan> the only user of ::Method::Constructor is immutable
356 # 14:27 <@stevan> if someone uses it outside of immutable,.. they are either: mst or groditi
357 # 14:27 <@stevan> so I am not worried
358 if ($options{inline_constructor} && $immutable->has_method($options{constructor_name})) {
359 my $constructor_class = $options{constructor_class} || 'Class::MOP::Method::Constructor';
360 $immutable->remove_method( $options{constructor_name} )
361 if blessed($immutable->get_method($options{constructor_name})) eq $constructor_class;
373 Class::MOP::Immutable - A class to transform Class::MOP::Class metaclasses
377 use Class::MOP::Immutable;
379 my $immutable_metaclass = Class::MOP::Immutable->new($metaclass, {
380 read_only => [qw/superclasses/],
388 remove_package_symbol
391 class_precedence_list => 'ARRAY',
392 compute_all_applicable_attributes => 'ARRAY',
393 get_meta_instance => 'SCALAR',
394 get_method_map => 'SCALAR',
398 $immutable_metaclass->make_metaclass_immutable(@_)
402 This is basically a module for applying a transformation on a given
403 metaclass. Current features include making methods read-only,
404 making methods un-callable and memoizing methods (in a type specific
407 This module is not for the feint of heart, it does some whacky things
408 to the metaclass in order to make it immutable. If you are just curious,
409 I suggest you turn back now, there is nothing to see here.
415 =item B<new ($metaclass, \%options)>
417 Given a C<$metaclass> and a set of C<%options> this module will
418 prepare an immutable version of the C<$metaclass>, which can then
419 be applied to the C<$metaclass> using the C<make_metaclass_immutable>
424 Returns the options HASH set in C<new>.
428 Returns the metaclass set in C<new>.
430 =item B<immutable_metaclass>
432 Returns the immutable metaclass created within C<new>.
438 =item B<create_immutable_metaclass>
440 This will create the immutable version of the C<$metaclass>, but will
441 not actually change the original metaclass.
443 =item B<create_methods_for_immutable_metaclass>
445 This will create all the methods for the immutable metaclass based
446 on the C<%options> passed into C<new>.
448 =item B<make_metaclass_immutable (%options)>
450 This will actually change the C<$metaclass> into the immutable version.
452 =item B<make_metaclass_mutable (%options)>
454 This will change the C<$metaclass> into the mutable version by reversing
455 the immutable process. C<%options> should be the same options that were
456 given to make_metaclass_immutable.
462 Stevan Little E<lt>stevan@iinteractive.comE<gt>
464 =head1 COPYRIGHT AND LICENSE
466 Copyright 2006-2008 by Infinity Interactive, Inc.
468 L<http://www.iinteractive.com>
470 This library is free software; you can redistribute it and/or modify
471 it under the same terms as Perl itself.