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 $metaclass->add_method(
151 $options->{constructor_name},
152 $constructor_class->new(
154 metaclass => $metaclass,
156 package_name => $metaclass->name,
157 name => $options->{constructor_name}
163 sub _inline_destructor {
164 my ( $self, $metaclass, $options ) = @_;
166 return unless $options->{inline_destructor};
168 ( exists $options->{destructor_class} )
169 || confess "The 'inline_destructor' option is present, but "
170 . "no destructor class was specified";
172 my $destructor_class = $options->{destructor_class};
174 return unless $destructor_class->is_needed($metaclass);
176 my $destructor = $destructor_class->new(
178 metaclass => $metaclass,
179 package_name => $metaclass->name,
183 return unless $destructor->is_needed;
185 $metaclass->add_method( 'DESTROY' => $destructor )
188 sub _check_memoized_methods {
189 my ( $self, $metaclass, $options ) = @_;
191 my $memoized_methods = $self->options->{memoize};
192 foreach my $method_name ( keys %{$memoized_methods} ) {
193 my $type = $memoized_methods->{$method_name};
195 ( $metaclass->can($method_name) )
196 || confess "Could not find the method '$method_name' in "
201 sub create_methods_for_immutable_metaclass {
204 my %methods = %DEFAULT_METHODS;
205 my $metaclass = $self->metaclass;
206 my $meta = $metaclass->meta;
208 $methods{get_mutable_metaclass_name}
209 = sub { (shift)->{'___original_class'} };
211 $methods{immutable_transformer} = sub {$self};
215 $self->_make_read_only_methods( $metaclass, $meta ),
216 $self->_make_uncallable_methods( $metaclass, $meta ),
217 $self->_make_memoized_methods( $metaclass, $meta ),
218 $self->_make_wrapped_methods( $metaclass, $meta ),
219 get_mutable_metaclass_name => sub { (shift)->{'___original_class'} },
220 immutable_transformer => sub {$self},
224 sub _make_read_only_methods {
225 my ( $self, $metaclass, $meta ) = @_;
228 foreach my $read_only_method ( @{ $self->options->{read_only} } ) {
229 my $method = $meta->find_method_by_name($read_only_method);
232 || confess "Could not find the method '$read_only_method' in "
235 $methods{$read_only_method} = sub {
236 confess "This method is read-only" if scalar @_ > 1;
237 goto &{ $method->body };
244 sub _make_uncallable_methods {
245 my ( $self, $metaclass, $meta ) = @_;
248 foreach my $cannot_call_method ( @{ $self->options->{cannot_call} } ) {
249 $methods{$cannot_call_method} = sub {
251 "This method ($cannot_call_method) cannot be called on an immutable instance";
258 sub _make_memoized_methods {
259 my ( $self, $metaclass, $meta ) = @_;
263 my $memoized_methods = $self->options->{memoize};
264 foreach my $method_name ( keys %{$memoized_methods} ) {
265 my $type = $memoized_methods->{$method_name};
266 my $key = '___' . $method_name;
267 my $method = $meta->find_method_by_name($method_name);
269 if ( $type eq 'ARRAY' ) {
270 $methods{$method_name} = sub {
271 @{ $_[0]->{$key} } = $method->execute( $_[0] )
272 if !exists $_[0]->{$key};
273 return @{ $_[0]->{$key} };
276 elsif ( $type eq 'HASH' ) {
277 $methods{$method_name} = sub {
278 %{ $_[0]->{$key} } = $method->execute( $_[0] )
279 if !exists $_[0]->{$key};
280 return %{ $_[0]->{$key} };
283 elsif ( $type eq 'SCALAR' ) {
284 $methods{$method_name} = sub {
285 $_[0]->{$key} = $method->execute( $_[0] )
286 if !exists $_[0]->{$key};
287 return $_[0]->{$key};
295 sub _make_wrapped_methods {
296 my ( $self, $metaclass, $meta ) = @_;
300 my $wrapped_methods = $self->options->{wrapped};
302 foreach my $method_name ( keys %{$wrapped_methods} ) {
303 my $method = $meta->find_method_by_name($method_name);
306 || confess "Could not find the method '$method_name' in "
309 my $wrapper = $wrapped_methods->{$method_name};
311 $methods{$method_name} = sub { $wrapper->( $method, @_ ) };
317 sub make_metaclass_mutable {
318 my ($self, $immutable, $options) = @_;
320 my %options = %$options;
322 my $original_class = $immutable->get_mutable_metaclass_name;
323 delete $immutable->{'___original_class'} ;
324 bless $immutable => $original_class;
326 my $memoized_methods = $self->options->{memoize};
327 foreach my $method_name (keys %{$memoized_methods}) {
328 my $type = $memoized_methods->{$method_name};
330 ($immutable->can($method_name))
331 || confess "Could not find the method '$method_name' in " . $immutable->name;
332 if ($type eq 'SCALAR' || $type eq 'ARRAY' || $type eq 'HASH' ) {
333 delete $immutable->{'___' . $method_name};
337 if ($options{inline_destructor} && $immutable->has_method('DESTROY')) {
338 $immutable->remove_method('DESTROY')
339 if blessed($immutable->get_method('DESTROY')) eq $options{destructor_class};
343 # 14:01 <@stevan> nah,. you shouldnt
344 # 14:01 <@stevan> they are just inlined
345 # 14:01 <@stevan> which is the default in Moose anyway
346 # 14:02 <@stevan> and adding new attributes will just DWIM
347 # 14:02 <@stevan> and you really cant change an attribute anyway
348 # if ($options{inline_accessors}) {
349 # foreach my $attr_name ($immutable->get_attribute_list) {
350 # my $attr = $immutable->get_attribute($attr_name);
351 # $attr->remove_accessors;
352 # $attr->install_accessors(0);
356 # 14:26 <@stevan> the only user of ::Method::Constructor is immutable
357 # 14:27 <@stevan> if someone uses it outside of immutable,.. they are either: mst or groditi
358 # 14:27 <@stevan> so I am not worried
359 if ($options{inline_constructor} && $immutable->has_method($options{constructor_name})) {
360 my $constructor_class = $options{constructor_class} || 'Class::MOP::Method::Constructor';
361 $immutable->remove_method( $options{constructor_name} )
362 if blessed($immutable->get_method($options{constructor_name})) eq $constructor_class;
374 Class::MOP::Immutable - A class to transform Class::MOP::Class metaclasses
378 use Class::MOP::Immutable;
380 my $immutable_metaclass = Class::MOP::Immutable->new($metaclass, {
381 read_only => [qw/superclasses/],
389 remove_package_symbol
392 class_precedence_list => 'ARRAY',
393 compute_all_applicable_attributes => 'ARRAY',
394 get_meta_instance => 'SCALAR',
395 get_method_map => 'SCALAR',
399 $immutable_metaclass->make_metaclass_immutable(@_)
403 This is basically a module for applying a transformation on a given
404 metaclass. Current features include making methods read-only,
405 making methods un-callable and memoizing methods (in a type specific
408 This module is not for the feint of heart, it does some whacky things
409 to the metaclass in order to make it immutable. If you are just curious,
410 I suggest you turn back now, there is nothing to see here.
416 =item B<new ($metaclass, \%options)>
418 Given a C<$metaclass> and a set of C<%options> this module will
419 prepare an immutable version of the C<$metaclass>, which can then
420 be applied to the C<$metaclass> using the C<make_metaclass_immutable>
425 Returns the options HASH set in C<new>.
429 Returns the metaclass set in C<new>.
431 =item B<immutable_metaclass>
433 Returns the immutable metaclass created within C<new>.
439 =item B<create_immutable_metaclass>
441 This will create the immutable version of the C<$metaclass>, but will
442 not actually change the original metaclass.
444 =item B<create_methods_for_immutable_metaclass>
446 This will create all the methods for the immutable metaclass based
447 on the C<%options> passed into C<new>.
449 =item B<make_metaclass_immutable (%options)>
451 This will actually change the C<$metaclass> into the immutable version.
453 =item B<make_metaclass_mutable (%options)>
455 This will change the C<$metaclass> into the mutable version by reversing
456 the immutable process. C<%options> should be the same options that were
457 given to make_metaclass_immutable.
463 Stevan Little E<lt>stevan@iinteractive.comE<gt>
465 =head1 COPYRIGHT AND LICENSE
467 Copyright 2006-2008 by Infinity Interactive, Inc.
469 L<http://www.iinteractive.com>
471 This library is free software; you can redistribute it and/or modify
472 it under the same terms as Perl itself.