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 make_metaclass_mutable {
202 my ($self, $immutable, $options) = @_;
204 my %options = %$options;
206 my $original_class = $immutable->get_mutable_metaclass_name;
207 delete $immutable->{'___original_class'} ;
208 bless $immutable => $original_class;
210 my $memoized_methods = $self->options->{memoize};
211 foreach my $method_name (keys %{$memoized_methods}) {
212 my $type = $memoized_methods->{$method_name};
214 ($immutable->can($method_name))
215 || confess "Could not find the method '$method_name' in " . $immutable->name;
216 if ($type eq 'SCALAR' || $type eq 'ARRAY' || $type eq 'HASH' ) {
217 delete $immutable->{'___' . $method_name};
221 if ($options{inline_destructor} && $immutable->has_method('DESTROY')) {
222 $immutable->remove_method('DESTROY')
223 if blessed($immutable->get_method('DESTROY')) eq $options{destructor_class};
227 # 14:01 <@stevan> nah,. you shouldnt
228 # 14:01 <@stevan> they are just inlined
229 # 14:01 <@stevan> which is the default in Moose anyway
230 # 14:02 <@stevan> and adding new attributes will just DWIM
231 # 14:02 <@stevan> and you really cant change an attribute anyway
232 # if ($options{inline_accessors}) {
233 # foreach my $attr_name ($immutable->get_attribute_list) {
234 # my $attr = $immutable->get_attribute($attr_name);
235 # $attr->remove_accessors;
236 # $attr->install_accessors(0);
240 # 14:26 <@stevan> the only user of ::Method::Constructor is immutable
241 # 14:27 <@stevan> if someone uses it outside of immutable,.. they are either: mst or groditi
242 # 14:27 <@stevan> so I am not worried
243 if ($options{inline_constructor} && $immutable->has_method($options{constructor_name})) {
244 my $constructor_class = $options{constructor_class} || 'Class::MOP::Method::Constructor';
245 $immutable->remove_method( $options{constructor_name} )
246 if blessed($immutable->get_method($options{constructor_name})) eq $constructor_class;
250 sub create_methods_for_immutable_metaclass {
253 my %methods = %DEFAULT_METHODS;
254 my $metaclass = $self->metaclass;
255 my $meta = $metaclass->meta;
257 foreach my $read_only_method (@{$self->options->{read_only}}) {
258 my $method = $meta->find_method_by_name($read_only_method);
261 || confess "Could not find the method '$read_only_method' in " . $metaclass->name;
263 $methods{$read_only_method} = sub {
264 confess "This method is read-only" if scalar @_ > 1;
265 goto &{$method->body}
269 foreach my $cannot_call_method (@{$self->options->{cannot_call}}) {
270 $methods{$cannot_call_method} = sub {
271 confess "This method ($cannot_call_method) cannot be called on an immutable instance";
275 my $memoized_methods = $self->options->{memoize};
276 foreach my $method_name (keys %{$memoized_methods}) {
277 my $type = $memoized_methods->{$method_name};
278 my $key = '___' . $method_name;
279 my $method = $meta->find_method_by_name($method_name);
281 if ($type eq 'ARRAY') {
282 $methods{$method_name} = sub {
283 @{$_[0]->{$key}} = $method->execute($_[0])
284 if !exists $_[0]->{$key};
285 return @{$_[0]->{$key}};
288 elsif ($type eq 'HASH') {
289 $methods{$method_name} = sub {
290 %{$_[0]->{$key}} = $method->execute($_[0])
291 if !exists $_[0]->{$key};
292 return %{$_[0]->{$key}};
295 elsif ($type eq 'SCALAR') {
296 $methods{$method_name} = sub {
297 $_[0]->{$key} = $method->execute($_[0])
298 if !exists $_[0]->{$key};
299 return $_[0]->{$key};
304 my $wrapped_methods = $self->options->{wrapped};
306 foreach my $method_name (keys %{ $wrapped_methods }) {
307 my $method = $meta->find_method_by_name($method_name);
310 || confess "Could not find the method '$method_name' in " . $metaclass->name;
312 my $wrapper = $wrapped_methods->{$method_name};
314 $methods{$method_name} = sub { $wrapper->($method, @_) };
317 $methods{get_mutable_metaclass_name} = sub { (shift)->{'___original_class'} };
319 $methods{immutable_transformer} = sub { $self };
332 Class::MOP::Immutable - A class to transform Class::MOP::Class metaclasses
336 use Class::MOP::Immutable;
338 my $immutable_metaclass = Class::MOP::Immutable->new($metaclass, {
339 read_only => [qw/superclasses/],
347 remove_package_symbol
350 class_precedence_list => 'ARRAY',
351 compute_all_applicable_attributes => 'ARRAY',
352 get_meta_instance => 'SCALAR',
353 get_method_map => 'SCALAR',
357 $immutable_metaclass->make_metaclass_immutable(@_)
361 This is basically a module for applying a transformation on a given
362 metaclass. Current features include making methods read-only,
363 making methods un-callable and memoizing methods (in a type specific
366 This module is not for the feint of heart, it does some whacky things
367 to the metaclass in order to make it immutable. If you are just curious,
368 I suggest you turn back now, there is nothing to see here.
374 =item B<new ($metaclass, \%options)>
376 Given a C<$metaclass> and a set of C<%options> this module will
377 prepare an immutable version of the C<$metaclass>, which can then
378 be applied to the C<$metaclass> using the C<make_metaclass_immutable>
383 Returns the options HASH set in C<new>.
387 Returns the metaclass set in C<new>.
389 =item B<immutable_metaclass>
391 Returns the immutable metaclass created within C<new>.
397 =item B<create_immutable_metaclass>
399 This will create the immutable version of the C<$metaclass>, but will
400 not actually change the original metaclass.
402 =item B<create_methods_for_immutable_metaclass>
404 This will create all the methods for the immutable metaclass based
405 on the C<%options> passed into C<new>.
407 =item B<make_metaclass_immutable (%options)>
409 This will actually change the C<$metaclass> into the immutable version.
411 =item B<make_metaclass_mutable (%options)>
413 This will change the C<$metaclass> into the mutable version by reversing
414 the immutable process. C<%options> should be the same options that were
415 given to make_metaclass_immutable.
421 Stevan Little E<lt>stevan@iinteractive.comE<gt>
423 =head1 COPYRIGHT AND LICENSE
425 Copyright 2006-2008 by Infinity Interactive, Inc.
427 L<http://www.iinteractive.com>
429 This library is free software; you can redistribute it and/or modify
430 it under the same terms as Perl itself.