2 package Class::MOP::Immutable;
7 use Class::MOP::Method::Constructor;
10 use Scalar::Util 'blessed';
12 our $VERSION = '0.65';
13 our $AUTHORITY = 'cpan:STEVAN';
15 use base 'Class::MOP::Object';
18 my ($class, @args) = @_;
20 my ( $metaclass, $options );
24 ( $metaclass, $options ) = @args;
26 unshift @args, "metaclass" if @args % 2 == 1;
31 $metaclass = $options{metaclass};
34 my $self = $class->_new(
35 'metaclass' => $metaclass,
36 'options' => $options,
37 'immutable_metaclass' => undef,
41 # we initialize the immutable
42 # version of the metaclass here
44 $self->create_immutable_metaclass;
51 my $options = @_ == 1 ? $_[0] : {@_};
53 bless $options, $class;
56 sub immutable_metaclass { (shift)->{'immutable_metaclass'} }
57 sub metaclass { (shift)->{'metaclass'} }
58 sub options { (shift)->{'options'} }
60 sub create_immutable_metaclass {
64 # The immutable version of the
65 # metaclass is just a anon-class
66 # which shadows the methods
68 $self->{'immutable_metaclass'} = Class::MOP::Class->create_anon_class(
69 superclasses => [ blessed($self->metaclass) ],
70 methods => $self->create_methods_for_immutable_metaclass,
75 my %DEFAULT_METHODS = (
76 # I don't really understand this, but removing it breaks tests (groditi)
79 # if it is not blessed, then someone is asking
80 # for the meta of Class::MOP::Immutable
81 return Class::MOP::Class->initialize($self) unless blessed($self);
82 # otherwise, they are asking for the metaclass
83 # which has been made immutable, which is itself
84 # except in the cases where it is a metaclass itself
85 # that has been made immutable and for that we need
87 if ($self->isa('Class::MOP::Class')) {
88 return $self->{'___original_class'}->meta;
94 is_mutable => sub { 0 },
95 is_immutable => sub { 1 },
96 make_immutable => sub { () },
100 # this will actually convert the
101 # existing metaclass to an immutable
103 sub make_metaclass_immutable {
104 my ($self, $metaclass, $options) = @_;
107 inline_accessors => 1,
108 inline_constructor => 1,
109 inline_destructor => 0,
110 constructor_name => 'new',
115 %$options = %options; # FIXME who the hell is relying on this?!? tests fail =(
117 if ($options{inline_accessors}) {
118 foreach my $attr_name ($metaclass->get_attribute_list) {
119 # inline the accessors
120 $metaclass->get_attribute($attr_name)
121 ->install_accessors(1);
125 if ($options{inline_constructor}) {
126 my $constructor_class = $options{constructor_class} || 'Class::MOP::Method::Constructor';
127 $metaclass->add_method(
128 $options{constructor_name},
129 $constructor_class->new(
130 options => \%options,
131 metaclass => $metaclass,
133 package_name => $metaclass->name,
134 name => $options{constructor_name}
136 ) if $options{replace_constructor} or !$metaclass->has_method($options{constructor_name});
139 if ($options{inline_destructor}) {
140 (exists $options{destructor_class})
141 || confess "The 'inline_destructor' option is present, but "
142 . "no destructor class was specified";
144 my $destructor_class = $options{destructor_class};
147 # we allow the destructor to determine
148 # if it is needed or not before we actually
149 # create the destructor too
151 if ($destructor_class->is_needed($metaclass)) {
152 my $destructor = $destructor_class->new(
153 options => \%options,
154 metaclass => $metaclass,
155 package_name => $metaclass->name,
159 $metaclass->add_method('DESTROY' => $destructor)
161 # we allow the destructor to determine
162 # if it is needed or not, it can perform
163 # all sorts of checks because it has the
165 if $destructor->is_needed;
169 my $memoized_methods = $self->options->{memoize};
170 foreach my $method_name (keys %{$memoized_methods}) {
171 my $type = $memoized_methods->{$method_name};
173 ($metaclass->can($method_name))
174 || confess "Could not find the method '$method_name' in " . $metaclass->name;
176 if ($type eq 'ARRAY') {
177 $metaclass->{'___' . $method_name} = [ $metaclass->$method_name ];
179 elsif ($type eq 'HASH') {
180 $metaclass->{'___' . $method_name} = { $metaclass->$method_name };
182 elsif ($type eq 'SCALAR') {
183 $metaclass->{'___' . $method_name} = $metaclass->$method_name;
187 $metaclass->{'___original_class'} = blessed($metaclass);
188 bless $metaclass => $self->immutable_metaclass->name;
191 sub make_metaclass_mutable {
192 my ($self, $immutable, $options) = @_;
194 my %options = %$options;
196 my $original_class = $immutable->get_mutable_metaclass_name;
197 delete $immutable->{'___original_class'} ;
198 bless $immutable => $original_class;
200 my $memoized_methods = $self->options->{memoize};
201 foreach my $method_name (keys %{$memoized_methods}) {
202 my $type = $memoized_methods->{$method_name};
204 ($immutable->can($method_name))
205 || confess "Could not find the method '$method_name' in " . $immutable->name;
206 if ($type eq 'SCALAR' || $type eq 'ARRAY' || $type eq 'HASH' ) {
207 delete $immutable->{'___' . $method_name};
211 if ($options{inline_destructor} && $immutable->has_method('DESTROY')) {
212 $immutable->remove_method('DESTROY')
213 if blessed($immutable->get_method('DESTROY')) eq $options{destructor_class};
217 # 14:01 <@stevan> nah,. you shouldnt
218 # 14:01 <@stevan> they are just inlined
219 # 14:01 <@stevan> which is the default in Moose anyway
220 # 14:02 <@stevan> and adding new attributes will just DWIM
221 # 14:02 <@stevan> and you really cant change an attribute anyway
222 # if ($options{inline_accessors}) {
223 # foreach my $attr_name ($immutable->get_attribute_list) {
224 # my $attr = $immutable->get_attribute($attr_name);
225 # $attr->remove_accessors;
226 # $attr->install_accessors(0);
230 # 14:26 <@stevan> the only user of ::Method::Constructor is immutable
231 # 14:27 <@stevan> if someone uses it outside of immutable,.. they are either: mst or groditi
232 # 14:27 <@stevan> so I am not worried
233 if ($options{inline_constructor} && $immutable->has_method($options{constructor_name})) {
234 my $constructor_class = $options{constructor_class} || 'Class::MOP::Method::Constructor';
235 $immutable->remove_method( $options{constructor_name} )
236 if blessed($immutable->get_method($options{constructor_name})) eq $constructor_class;
240 sub create_methods_for_immutable_metaclass {
243 my %methods = %DEFAULT_METHODS;
245 foreach my $read_only_method (@{$self->options->{read_only}}) {
246 my $method = $self->metaclass->meta->find_method_by_name($read_only_method);
249 || confess "Could not find the method '$read_only_method' in " . $self->metaclass->name;
251 $methods{$read_only_method} = sub {
252 confess "This method is read-only" if scalar @_ > 1;
253 goto &{$method->body}
257 foreach my $cannot_call_method (@{$self->options->{cannot_call}}) {
258 $methods{$cannot_call_method} = sub {
259 confess "This method ($cannot_call_method) cannot be called on an immutable instance";
263 my $memoized_methods = $self->options->{memoize};
264 foreach my $method_name (keys %{$memoized_methods}) {
265 my $type = $memoized_methods->{$method_name};
266 if ($type eq 'ARRAY') {
267 $methods{$method_name} = sub { @{$_[0]->{'___' . $method_name}} };
269 elsif ($type eq 'HASH') {
270 $methods{$method_name} = sub { %{$_[0]->{'___' . $method_name}} };
272 elsif ($type eq 'SCALAR') {
273 $methods{$method_name} = sub { $_[0]->{'___' . $method_name} };
277 my $wrapped_methods = $self->options->{wrapped};
279 foreach my $method_name (keys %{ $wrapped_methods }) {
280 my $method = $self->metaclass->meta->find_method_by_name($method_name);
283 || confess "Could not find the method '$method_name' in " . $self->metaclass->name;
285 my $wrapper = $wrapped_methods->{$method_name};
287 $methods{$method_name} = sub { $wrapper->($method, @_) };
290 $methods{get_mutable_metaclass_name} = sub { (shift)->{'___original_class'} };
292 $methods{immutable_transformer} = sub { $self };
305 Class::MOP::Immutable - A class to transform Class::MOP::Class metaclasses
309 use Class::MOP::Immutable;
311 my $immutable_metaclass = Class::MOP::Immutable->new($metaclass, {
312 read_only => [qw/superclasses/],
320 remove_package_symbol
323 class_precedence_list => 'ARRAY',
324 compute_all_applicable_attributes => 'ARRAY',
325 get_meta_instance => 'SCALAR',
326 get_method_map => 'SCALAR',
330 $immutable_metaclass->make_metaclass_immutable(@_)
334 This is basically a module for applying a transformation on a given
335 metaclass. Current features include making methods read-only,
336 making methods un-callable and memoizing methods (in a type specific
339 This module is not for the feint of heart, it does some whacky things
340 to the metaclass in order to make it immutable. If you are just curious,
341 I suggest you turn back now, there is nothing to see here.
347 =item B<new ($metaclass, \%options)>
349 Given a C<$metaclass> and a set of C<%options> this module will
350 prepare an immutable version of the C<$metaclass>, which can then
351 be applied to the C<$metaclass> using the C<make_metaclass_immutable>
356 Returns the options HASH set in C<new>.
360 Returns the metaclass set in C<new>.
362 =item B<immutable_metaclass>
364 Returns the immutable metaclass created within C<new>.
370 =item B<create_immutable_metaclass>
372 This will create the immutable version of the C<$metaclass>, but will
373 not actually change the original metaclass.
375 =item B<create_methods_for_immutable_metaclass>
377 This will create all the methods for the immutable metaclass based
378 on the C<%options> passed into C<new>.
380 =item B<make_metaclass_immutable (%options)>
382 This will actually change the C<$metaclass> into the immutable version.
384 =item B<make_metaclass_mutable (%options)>
386 This will change the C<$metaclass> into the mutable version by reversing
387 the immutable process. C<%options> should be the same options that were
388 given to make_metaclass_immutable.
394 Stevan Little E<lt>stevan@iinteractive.comE<gt>
396 =head1 COPYRIGHT AND LICENSE
398 Copyright 2006-2008 by Infinity Interactive, Inc.
400 L<http://www.iinteractive.com>
402 This library is free software; you can redistribute it and/or modify
403 it under the same terms as Perl itself.