2 package Class::MOP::Immutable;
7 use Class::MOP::Method::Constructor;
10 use Scalar::Util 'blessed';
12 our $VERSION = '0.05';
13 our $AUTHORITY = 'cpan:STEVAN';
15 use base 'Class::MOP::Object';
18 my ($class, $metaclass, $options) = @_;
21 '$!metaclass' => $metaclass,
22 '%!options' => $options,
23 '$!immutable_metaclass' => undef,
27 # we initialize the immutable
28 # version of the metaclass here
29 $self->create_immutable_metaclass;
34 sub immutable_metaclass { (shift)->{'$!immutable_metaclass'} }
35 sub metaclass { (shift)->{'$!metaclass'} }
36 sub options { (shift)->{'%!options'} }
38 sub create_immutable_metaclass {
42 # The immutable version of the
43 # metaclass is just a anon-class
44 # which shadows the methods
46 $self->{'$!immutable_metaclass'} = Class::MOP::Class->create_anon_class(
47 superclasses => [ blessed($self->metaclass) ],
48 methods => $self->create_methods_for_immutable_metaclass,
53 my %DEFAULT_METHODS = (
54 # I don't really understand this, but removing it breaks tests (groditi)
57 # if it is not blessed, then someone is asking
58 # for the meta of Class::MOP::Immutable
59 return Class::MOP::Class->initialize($self) unless blessed($self);
60 # otherwise, they are asking for the metaclass
61 # which has been made immutable, which is itself
64 is_mutable => sub { 0 },
65 is_immutable => sub { 1 },
66 make_immutable => sub { () },
70 # this will actually convert the
71 # existing metaclass to an immutable
73 sub make_metaclass_immutable {
74 my ($self, $metaclass, $options) = @_;
77 [ inline_accessors => 1 ],
78 [ inline_constructor => 1 ],
79 [ inline_destructor => 0 ],
80 [ constructor_name => 'new' ],
83 $options->{$pair->[0]} = $pair->[1] unless exists $options->{$pair->[0]};
86 my %options = %$options;
88 if ($options{inline_accessors}) {
89 foreach my $attr_name ($metaclass->get_attribute_list) {
90 # inline the accessors
91 $metaclass->get_attribute($attr_name)
92 ->install_accessors(1);
96 if ($options{inline_constructor}) {
97 my $constructor_class = $options{constructor_class} || 'Class::MOP::Method::Constructor';
98 $metaclass->add_method(
99 $options{constructor_name},
100 $constructor_class->new(
101 options => \%options,
102 metaclass => $metaclass,
105 ) unless $metaclass->has_method($options{constructor_name});
108 if ($options{inline_destructor}) {
109 (exists $options{destructor_class})
110 || confess "The 'inline_destructor' option is present, but "
111 . "no destructor class was specified";
113 my $destructor_class = $options{destructor_class};
115 my $destructor = $destructor_class->new(
116 options => \%options,
117 metaclass => $metaclass,
120 $metaclass->add_method('DESTROY' => $destructor)
122 # we allow the destructor to determine
123 # if it is needed or not, it can perform
124 # all sorts of checks because it has the
126 if $destructor->is_needed;
129 my $memoized_methods = $self->options->{memoize};
130 foreach my $method_name (keys %{$memoized_methods}) {
131 my $type = $memoized_methods->{$method_name};
133 ($metaclass->can($method_name))
134 || confess "Could not find the method '$method_name' in " . $metaclass->name;
136 if ($type eq 'ARRAY') {
137 $metaclass->{'___' . $method_name} = [ $metaclass->$method_name ];
139 elsif ($type eq 'HASH') {
140 $metaclass->{'___' . $method_name} = { $metaclass->$method_name };
142 elsif ($type eq 'SCALAR') {
143 $metaclass->{'___' . $method_name} = $metaclass->$method_name;
147 $metaclass->{'___original_class'} = blessed($metaclass);
148 bless $metaclass => $self->immutable_metaclass->name;
151 sub make_metaclass_mutable {
152 my ($self, $immutable, $options) = @_;
154 my %options = %$options;
156 my $original_class = $immutable->get_mutable_metaclass_name;
157 delete $immutable->{'___original_class'} ;
158 bless $immutable => $original_class;
160 my $memoized_methods = $self->options->{memoize};
161 foreach my $method_name (keys %{$memoized_methods}) {
162 my $type = $memoized_methods->{$method_name};
164 ($immutable->can($method_name))
165 || confess "Could not find the method '$method_name' in " . $immutable->name;
166 if ($type eq 'SCALAR' || $type eq 'ARRAY' || $type eq 'HASH' ) {
167 delete $immutable->{'___' . $method_name};
171 if ($options{inline_destructor} && $immutable->has_method('DESTROY')) {
172 $immutable->remove_method('DESTROY')
173 if $immutable->get_method('DESTROY')->blessed eq $options{destructor_class};
177 # 14:01 <@stevan> nah,. you shouldnt
178 # 14:01 <@stevan> they are just inlined
179 # 14:01 <@stevan> which is the default in Moose anyway
180 # 14:02 <@stevan> and adding new attributes will just DWIM
181 # 14:02 <@stevan> and you really cant change an attribute anyway
182 # if ($options{inline_accessors}) {
183 # foreach my $attr_name ($immutable->get_attribute_list) {
184 # my $attr = $immutable->get_attribute($attr_name);
185 # $attr->remove_accessors;
186 # $attr->install_accessors(0);
190 # 14:26 <@stevan> the only user of ::Method::Constructor is immutable
191 # 14:27 <@stevan> if someone uses it outside of immutable,.. they are either: mst or groditi
192 # 14:27 <@stevan> so I am not worried
193 if ($options{inline_constructor}) {
194 my $constructor_class = $options{constructor_class} || 'Class::MOP::Method::Constructor';
195 $immutable->remove_method( $options{constructor_name} )
196 if $immutable->get_method($options{constructor_name})->blessed eq $constructor_class;
200 sub create_methods_for_immutable_metaclass {
203 my %methods = %DEFAULT_METHODS;
205 foreach my $read_only_method (@{$self->options->{read_only}}) {
206 my $method = $self->metaclass->meta->find_method_by_name($read_only_method);
209 || confess "Could not find the method '$read_only_method' in " . $self->metaclass->name;
211 $methods{$read_only_method} = sub {
212 confess "This method is read-only" if scalar @_ > 1;
213 goto &{$method->body}
217 foreach my $cannot_call_method (@{$self->options->{cannot_call}}) {
218 $methods{$cannot_call_method} = sub {
219 confess "This method ($cannot_call_method) cannot be called on an immutable instance";
223 my $memoized_methods = $self->options->{memoize};
224 foreach my $method_name (keys %{$memoized_methods}) {
225 my $type = $memoized_methods->{$method_name};
226 if ($type eq 'ARRAY') {
227 $methods{$method_name} = sub { @{$_[0]->{'___' . $method_name}} };
229 elsif ($type eq 'HASH') {
230 $methods{$method_name} = sub { %{$_[0]->{'___' . $method_name}} };
232 elsif ($type eq 'SCALAR') {
233 $methods{$method_name} = sub { $_[0]->{'___' . $method_name} };
237 $methods{get_mutable_metaclass_name} = sub { (shift)->{'___original_class'} };
239 $methods{immutable_transformer} = sub { $self };
252 Class::MOP::Immutable - A class to transform Class::MOP::Class metaclasses
256 use Class::MOP::Immutable;
258 my $immutable_metaclass = Class::MOP::Immutable->new($metaclass, {
259 read_only => [qw/superclasses/],
267 remove_package_symbol
270 class_precedence_list => 'ARRAY',
271 compute_all_applicable_attributes => 'ARRAY',
272 get_meta_instance => 'SCALAR',
273 get_method_map => 'SCALAR',
277 $immutable_metaclass->make_metaclass_immutable(@_)
281 This is basically a module for applying a transformation on a given
282 metaclass. Current features include making methods read-only,
283 making methods un-callable and memoizing methods (in a type specific
286 This module is not for the feint of heart, it does some whacky things
287 to the metaclass in order to make it immutable. If you are just curious,
288 I suggest you turn back now, there is nothing to see here.
294 =item B<new ($metaclass, \%options)>
296 Given a C<$metaclass> and a set of C<%options> this module will
297 prepare an immutable version of the C<$metaclass>, which can then
298 be applied to the C<$metaclass> using the C<make_metaclass_immutable>
303 Returns the options HASH set in C<new>.
307 Returns the metaclass set in C<new>.
309 =item B<immutable_metaclass>
311 Returns the immutable metaclass created within C<new>.
317 =item B<create_immutable_metaclass>
319 This will create the immutable version of the C<$metaclass>, but will
320 not actually change the original metaclass.
322 =item B<create_methods_for_immutable_metaclass>
324 This will create all the methods for the immutable metaclass based
325 on the C<%options> passed into C<new>.
327 =item B<make_metaclass_immutable (%options)>
329 This will actually change the C<$metaclass> into the immutable version.
331 =item B<make_metaclass_mutable (%options)>
333 This will change the C<$metaclass> into the mutable version by reversing
334 the immutable process. C<%options> should be the same options that were
335 given to make_metaclass_immutable.
341 Stevan Little E<lt>stevan@iinteractive.comE<gt>
343 =head1 COPYRIGHT AND LICENSE
345 Copyright 2006-2008 by Infinity Interactive, Inc.
347 L<http://www.iinteractive.com>
349 This library is free software; you can redistribute it and/or modify
350 it under the same terms as Perl itself.