2 package Class::MOP::Immutable;
7 use Class::MOP::Method::Constructor;
10 use Scalar::Util 'blessed';
12 our $VERSION = '0.04';
13 our $AUTHORITY = 'cpan:STEVAN';
16 my ($class, $metaclass, $options) = @_;
19 '$!metaclass' => $metaclass,
20 '%!options' => $options,
21 '$!immutable_metaclass' => undef,
25 # we initialize the immutable
26 # version of the metaclass here
27 $self->create_immutable_metaclass;
32 sub immutable_metaclass { (shift)->{'$!immutable_metaclass'} }
33 sub metaclass { (shift)->{'$!metaclass'} }
34 sub options { (shift)->{'%!options'} }
36 sub create_immutable_metaclass {
40 # The immutable version of the
41 # metaclass is just a anon-class
42 # which shadows the methods
44 $self->{'$!immutable_metaclass'} = Class::MOP::Class->create_anon_class(
45 superclasses => [ blessed($self->metaclass) ],
46 methods => $self->create_methods_for_immutable_metaclass,
51 my %DEFAULT_METHODS = (
52 # I don't really understand this, but removing it breaks tests (groditi)
55 # if it is not blessed, then someone is asking
56 # for the meta of Class::MOP::Immutable
57 return Class::MOP::Class->initialize($self) unless blessed($self);
58 # otherwise, they are asking for the metaclass
59 # which has been made immutable, which is itself
62 is_mutable => sub { 0 },
63 is_immutable => sub { 1 },
64 make_immutable => sub { () },
68 # this will actually convert the
69 # existing metaclass to an immutable
71 sub make_metaclass_immutable {
72 my ($self, $metaclass, $options) = @_;
75 [ inline_accessors => 1 ],
76 [ inline_constructor => 1 ],
77 [ inline_destructor => 0 ],
78 [ constructor_name => 'new' ],
81 $options->{$pair->[0]} = $pair->[1] unless exists $options->{$pair->[0]};
84 my %options = %$options;
86 if ($options{inline_accessors}) {
87 foreach my $attr_name ($metaclass->get_attribute_list) {
88 # inline the accessors
89 $metaclass->get_attribute($attr_name)
90 ->install_accessors(1);
94 if ($options{inline_constructor}) {
95 my $constructor_class = $options{constructor_class} || 'Class::MOP::Method::Constructor';
96 $metaclass->add_method(
97 $options{constructor_name},
98 $constructor_class->new(
100 metaclass => $metaclass,
103 ) unless $metaclass->has_method($options{constructor_name});
106 if ($options{inline_destructor}) {
107 (exists $options{destructor_class})
108 || confess "The 'inline_destructor' option is present, but "
109 . "no destructor class was specified";
111 my $destructor_class = $options{destructor_class};
113 my $destructor = $destructor_class->new(
114 options => \%options,
115 metaclass => $metaclass,
118 $metaclass->add_method('DESTROY' => $destructor)
120 # we allow the destructor to determine
121 # if it is needed or not, it can perform
122 # all sorts of checks because it has the
124 if $destructor->is_needed;
127 my $memoized_methods = $self->options->{memoize};
128 foreach my $method_name (keys %{$memoized_methods}) {
129 my $type = $memoized_methods->{$method_name};
131 ($metaclass->can($method_name))
132 || confess "Could not find the method '$method_name' in " . $metaclass->name;
134 if ($type eq 'ARRAY') {
135 $metaclass->{'___' . $method_name} = [ $metaclass->$method_name ];
137 elsif ($type eq 'HASH') {
138 $metaclass->{'___' . $method_name} = { $metaclass->$method_name };
140 elsif ($type eq 'SCALAR') {
141 $metaclass->{'___' . $method_name} = $metaclass->$method_name;
145 $metaclass->{'___original_class'} = blessed($metaclass);
146 bless $metaclass => $self->immutable_metaclass->name;
149 sub make_metaclass_mutable {
150 my ($self, $immutable, $options) = @_;
152 my %options = %$options;
154 my $original_class = $immutable->get_mutable_metaclass_name;
155 delete $immutable->{'___original_class'} ;
156 bless $immutable => $original_class;
158 my $memoized_methods = $self->options->{memoize};
159 foreach my $method_name (keys %{$memoized_methods}) {
160 my $type = $memoized_methods->{$method_name};
162 ($immutable->can($method_name))
163 || confess "Could not find the method '$method_name' in " . $immutable->name;
164 if ($type eq 'SCALAR' || $type eq 'ARRAY' || $type eq 'HASH' ) {
165 delete $immutable->{'___' . $method_name};
169 if ($options{inline_destructor} && $immutable->has_method('DESTROY')) {
170 $immutable->remove_method('DESTROY')
171 if $immutable->get_method('DESTROY')->blessed eq $options{destructor_class};
175 # 14:01 <@stevan> nah,. you shouldnt
176 # 14:01 <@stevan> they are just inlined
177 # 14:01 <@stevan> which is the default in Moose anyway
178 # 14:02 <@stevan> and adding new attributes will just DWIM
179 # 14:02 <@stevan> and you really cant change an attribute anyway
180 # if ($options{inline_accessors}) {
181 # foreach my $attr_name ($immutable->get_attribute_list) {
182 # my $attr = $immutable->get_attribute($attr_name);
183 # $attr->remove_accessors;
184 # $attr->install_accessors(0);
188 # 14:26 <@stevan> the only user of ::Method::Constructor is immutable
189 # 14:27 <@stevan> if someone uses it outside of immutable,.. they are either: mst or groditi
190 # 14:27 <@stevan> so I am not worried
191 if ($options{inline_constructor}) {
192 my $constructor_class = $options{constructor_class} || 'Class::MOP::Method::Constructor';
193 $immutable->remove_method( $options{constructor_name} )
194 if $immutable->get_method($options{constructor_name})->blessed eq $constructor_class;
198 sub create_methods_for_immutable_metaclass {
201 my %methods = %DEFAULT_METHODS;
203 foreach my $read_only_method (@{$self->options->{read_only}}) {
204 my $method = $self->metaclass->meta->find_method_by_name($read_only_method);
207 || confess "Could not find the method '$read_only_method' in " . $self->metaclass->name;
209 $methods{$read_only_method} = sub {
210 confess "This method is read-only" if scalar @_ > 1;
211 goto &{$method->body}
215 foreach my $cannot_call_method (@{$self->options->{cannot_call}}) {
216 $methods{$cannot_call_method} = sub {
217 confess "This method ($cannot_call_method) cannot be called on an immutable instance";
221 my $memoized_methods = $self->options->{memoize};
222 foreach my $method_name (keys %{$memoized_methods}) {
223 my $type = $memoized_methods->{$method_name};
224 if ($type eq 'ARRAY') {
225 $methods{$method_name} = sub { @{$_[0]->{'___' . $method_name}} };
227 elsif ($type eq 'HASH') {
228 $methods{$method_name} = sub { %{$_[0]->{'___' . $method_name}} };
230 elsif ($type eq 'SCALAR') {
231 $methods{$method_name} = sub { $_[0]->{'___' . $method_name} };
235 $methods{get_mutable_metaclass_name} = sub { (shift)->{'___original_class'} };
237 $methods{immutable_transformer} = sub { $self };
250 Class::MOP::Immutable - A class to transform Class::MOP::Class metaclasses
254 use Class::MOP::Immutable;
256 my $immutable_metaclass = Class::MOP::Immutable->new($metaclass, {
257 read_only => [qw/superclasses/],
265 remove_package_symbol
268 class_precedence_list => 'ARRAY',
269 compute_all_applicable_attributes => 'ARRAY',
270 get_meta_instance => 'SCALAR',
271 get_method_map => 'SCALAR',
275 $immutable_metaclass->make_metaclass_immutable(@_)
279 This is basically a module for applying a transformation on a given
280 metaclass. Current features include making methods read-only,
281 making methods un-callable and memoizing methods (in a type specific
284 This module is not for the feint of heart, it does some whacky things
285 to the metaclass in order to make it immutable. If you are just curious,
286 I suggest you turn back now, there is nothing to see here.
292 =item B<new ($metaclass, \%options)>
294 Given a C<$metaclass> and a set of C<%options> this module will
295 prepare an immutable version of the C<$metaclass>, which can then
296 be applied to the C<$metaclass> using the C<make_metaclass_immutable>
301 Returns the options HASH set in C<new>.
305 Returns the metaclass set in C<new>.
307 =item B<immutable_metaclass>
309 Returns the immutable metaclass created within C<new>.
315 =item B<create_immutable_metaclass>
317 This will create the immutable version of the C<$metaclass>, but will
318 not actually change the original metaclass.
320 =item B<create_methods_for_immutable_metaclass>
322 This will create all the methods for the immutable metaclass based
323 on the C<%options> passed into C<new>.
325 =item B<make_metaclass_immutable (%options)>
327 This will actually change the C<$metaclass> into the immutable version.
329 =item B<make_metaclass_mutable (%options)>
331 This will change the C<$metaclass> into the mutable version by reversing
332 the immutable process. C<%options> should be the same options that were
333 given to make_metaclass_immutable.
339 Stevan Little E<lt>stevan@iinteractive.comE<gt>
341 =head1 COPYRIGHT AND LICENSE
343 Copyright 2006-2008 by Infinity Interactive, Inc.
345 L<http://www.iinteractive.com>
347 This library is free software; you can redistribute it and/or modify
348 it under the same terms as Perl itself.