2 package Class::MOP::Immutable;
7 use Class::MOP::Method::Constructor;
10 use Scalar::Util 'blessed';
12 our $VERSION = '0.78_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,
39 'inlined_constructor' => undef,
47 my $options = @_ == 1 ? $_[0] : {@_};
49 bless $options, $class;
52 sub immutable_metaclass {
55 $self->create_immutable_metaclass unless $self->{'immutable_metaclass'};
57 return $self->{'immutable_metaclass'};
60 sub metaclass { (shift)->{'metaclass'} }
61 sub options { (shift)->{'options'} }
62 sub inlined_constructor { (shift)->{'inlined_constructor'} }
64 sub create_immutable_metaclass {
68 # The immutable version of the
69 # metaclass is just a anon-class
70 # which shadows the methods
72 $self->{'immutable_metaclass'} = Class::MOP::Class->create_anon_class(
73 superclasses => [ blessed($self->metaclass) ],
74 methods => $self->create_methods_for_immutable_metaclass,
79 my %DEFAULT_METHODS = (
80 # I don't really understand this, but removing it breaks tests (groditi)
83 # if it is not blessed, then someone is asking
84 # for the meta of Class::MOP::Immutable
85 return Class::MOP::Class->initialize($self) unless blessed($self);
86 # otherwise, they are asking for the metaclass
87 # which has been made immutable, which is itself
88 # except in the cases where it is a metaclass itself
89 # that has been made immutable and for that we need
91 if ($self->isa('Class::MOP::Class')) {
92 return $self->{'___original_class'}->meta;
98 is_mutable => sub { 0 },
99 is_immutable => sub { 1 },
100 make_immutable => sub { () },
104 # this will actually convert the
105 # existing metaclass to an immutable
107 sub make_metaclass_immutable {
108 my ($self, $metaclass, $options) = @_;
111 inline_accessors => 1,
112 inline_constructor => 1,
113 inline_destructor => 0,
114 constructor_name => 'new',
119 %$options = %options; # FIXME who the hell is relying on this?!? tests fail =(
121 $self->_inline_accessors( $metaclass, \%options );
122 $self->_inline_constructor( $metaclass, \%options );
123 $self->_inline_destructor( $metaclass, \%options );
124 $self->_check_memoized_methods( $metaclass, \%options );
126 $metaclass->{'___original_class'} = blessed($metaclass);
127 bless $metaclass => $self->immutable_metaclass->name;
130 sub _inline_accessors {
131 my ( $self, $metaclass, $options ) = @_;
133 return unless $options->{inline_accessors};
135 foreach my $attr_name ( $metaclass->get_attribute_list ) {
136 $metaclass->get_attribute($attr_name)->install_accessors(1);
140 sub _inline_constructor {
141 my ( $self, $metaclass, $options ) = @_;
143 return unless $options->{inline_constructor};
146 unless $options->{replace_constructor}
147 or !$metaclass->has_method( $options->{constructor_name} );
149 my $constructor_class = $options->{constructor_class}
150 || 'Class::MOP::Method::Constructor';
152 my $constructor = $constructor_class->new(
154 metaclass => $metaclass,
156 package_name => $metaclass->name,
157 name => $options->{constructor_name},
160 if ( $options->{replace_constructor} or $constructor->can_be_inlined ) {
161 $metaclass->add_method( $options->{constructor_name} => $constructor );
162 $self->{inlined_constructor} = $constructor;
166 sub _inline_destructor {
167 my ( $self, $metaclass, $options ) = @_;
169 return unless $options->{inline_destructor};
171 ( exists $options->{destructor_class} )
172 || confess "The 'inline_destructor' option is present, but "
173 . "no destructor class was specified";
175 my $destructor_class = $options->{destructor_class};
177 return unless $destructor_class->is_needed($metaclass);
179 my $destructor = $destructor_class->new(
181 metaclass => $metaclass,
182 package_name => $metaclass->name,
186 $metaclass->add_method( 'DESTROY' => $destructor )
189 sub _check_memoized_methods {
190 my ( $self, $metaclass, $options ) = @_;
192 my $memoized_methods = $self->options->{memoize};
193 foreach my $method_name ( keys %{$memoized_methods} ) {
194 my $type = $memoized_methods->{$method_name};
196 ( $metaclass->can($method_name) )
197 || confess "Could not find the method '$method_name' in "
202 sub create_methods_for_immutable_metaclass {
205 my %methods = %DEFAULT_METHODS;
206 my $metaclass = $self->metaclass;
207 my $meta = $metaclass->meta;
209 $methods{get_mutable_metaclass_name}
210 = sub { (shift)->{'___original_class'} };
212 $methods{immutable_transformer} = sub {$self};
216 $self->_make_read_only_methods( $metaclass, $meta ),
217 $self->_make_uncallable_methods( $metaclass, $meta ),
218 $self->_make_memoized_methods( $metaclass, $meta ),
219 $self->_make_wrapped_methods( $metaclass, $meta ),
220 get_mutable_metaclass_name => sub { (shift)->{'___original_class'} },
221 immutable_transformer => sub {$self},
225 sub _make_read_only_methods {
226 my ( $self, $metaclass, $meta ) = @_;
229 foreach my $read_only_method ( @{ $self->options->{read_only} } ) {
230 my $method = $meta->find_method_by_name($read_only_method);
233 || confess "Could not find the method '$read_only_method' in "
236 $methods{$read_only_method} = sub {
237 confess "This method is read-only" if scalar @_ > 1;
238 goto &{ $method->body };
245 sub _make_uncallable_methods {
246 my ( $self, $metaclass, $meta ) = @_;
249 foreach my $cannot_call_method ( @{ $self->options->{cannot_call} } ) {
250 $methods{$cannot_call_method} = sub {
252 "This method ($cannot_call_method) cannot be called on an immutable instance";
259 sub _make_memoized_methods {
260 my ( $self, $metaclass, $meta ) = @_;
264 my $memoized_methods = $self->options->{memoize};
265 foreach my $method_name ( keys %{$memoized_methods} ) {
266 my $type = $memoized_methods->{$method_name};
267 my $key = '___' . $method_name;
268 my $method = $meta->find_method_by_name($method_name);
270 if ( $type eq 'ARRAY' ) {
271 $methods{$method_name} = sub {
272 @{ $_[0]->{$key} } = $method->execute( $_[0] )
273 if !exists $_[0]->{$key};
274 return @{ $_[0]->{$key} };
277 elsif ( $type eq 'HASH' ) {
278 $methods{$method_name} = sub {
279 %{ $_[0]->{$key} } = $method->execute( $_[0] )
280 if !exists $_[0]->{$key};
281 return %{ $_[0]->{$key} };
284 elsif ( $type eq 'SCALAR' ) {
285 $methods{$method_name} = sub {
286 $_[0]->{$key} = $method->execute( $_[0] )
287 if !exists $_[0]->{$key};
288 return $_[0]->{$key};
296 sub _make_wrapped_methods {
297 my ( $self, $metaclass, $meta ) = @_;
301 my $wrapped_methods = $self->options->{wrapped};
303 foreach my $method_name ( keys %{$wrapped_methods} ) {
304 my $method = $meta->find_method_by_name($method_name);
307 || confess "Could not find the method '$method_name' in "
310 my $wrapper = $wrapped_methods->{$method_name};
312 $methods{$method_name} = sub { $wrapper->( $method, @_ ) };
318 sub make_metaclass_mutable {
319 my ($self, $immutable, $options) = @_;
321 my %options = %$options;
323 my $original_class = $immutable->get_mutable_metaclass_name;
324 delete $immutable->{'___original_class'} ;
325 bless $immutable => $original_class;
327 my $memoized_methods = $self->options->{memoize};
328 foreach my $method_name (keys %{$memoized_methods}) {
329 my $type = $memoized_methods->{$method_name};
331 ($immutable->can($method_name))
332 || confess "Could not find the method '$method_name' in " . $immutable->name;
333 if ($type eq 'SCALAR' || $type eq 'ARRAY' || $type eq 'HASH' ) {
334 delete $immutable->{'___' . $method_name};
338 if ($options{inline_destructor} && $immutable->has_method('DESTROY')) {
339 $immutable->remove_method('DESTROY')
340 if blessed($immutable->get_method('DESTROY')) eq $options{destructor_class};
344 # 14:01 <@stevan> nah,. you shouldnt
345 # 14:01 <@stevan> they are just inlined
346 # 14:01 <@stevan> which is the default in Moose anyway
347 # 14:02 <@stevan> and adding new attributes will just DWIM
348 # 14:02 <@stevan> and you really cant change an attribute anyway
349 # if ($options{inline_accessors}) {
350 # foreach my $attr_name ($immutable->get_attribute_list) {
351 # my $attr = $immutable->get_attribute($attr_name);
352 # $attr->remove_accessors;
353 # $attr->install_accessors(0);
357 # 14:26 <@stevan> the only user of ::Method::Constructor is immutable
358 # 14:27 <@stevan> if someone uses it outside of immutable,.. they are either: mst or groditi
359 # 14:27 <@stevan> so I am not worried
360 if ($options{inline_constructor} && $immutable->has_method($options{constructor_name})) {
361 my $constructor_class = $options{constructor_class} || 'Class::MOP::Method::Constructor';
363 if ( blessed($immutable->get_method($options{constructor_name})) eq $constructor_class ) {
364 $immutable->remove_method( $options{constructor_name} );
365 $self->{inlined_constructor} = undef;
378 Class::MOP::Immutable - A class to transform Class::MOP::Class metaclasses
382 use Class::MOP::Immutable;
384 my $immutable_metaclass = Class::MOP::Immutable->new($metaclass, {
385 read_only => [qw/superclasses/],
393 remove_package_symbol
396 class_precedence_list => 'ARRAY',
397 compute_all_applicable_attributes => 'ARRAY',
398 get_meta_instance => 'SCALAR',
399 get_method_map => 'SCALAR',
403 $immutable_metaclass->make_metaclass_immutable(@_)
407 This class encapsulates the logic behind immutabilization.
409 This class provides generic immutabilization logic. Decisions about
410 I<what> gets transformed are up to the caller.
412 Immutabilization allows for a number of transformations. It can ask
413 the calling metaclass to inline methods such as the constructor,
414 destructor, or accessors. It can memoize metaclass accessors
415 themselves. It can also turn read-write accessors in the metaclass
416 into read-only methods, and make attempting to set these values an
417 error. Finally, it can make some methods throw an exception when they
418 are called. This is used to disable methods that can alter the class.
424 =item B<< Class::MOP::Immutable->new($metaclass, %options) >>
426 This method takes a metaclass object (typically a L<Class::MOP::Class>
427 object) and a hash of options.
429 It returns a new transformer, but does not actually do any
432 This method accepts the following options:
436 =item * inline_accessors
438 =item * inline_constructor
440 =item * inline_destructor
442 These are all booleans indicating whether the specified method(s)
445 By default, accessors and the constructor are inlined, but not the
448 =item * replace_constructor
450 This is a boolean indicating whether an existing constructor should be
451 replaced when inlining a constructor. This defaults to false.
453 =item * constructor_name
455 This is the constructor method name. This defaults to "new".
457 =item * constructor_class
459 The name of the method metaclass for constructors. It will be used to
460 generate the inlined constructor. This defaults to
461 "Class::MOP::Method::Constructor".
463 =item * destructor_class
465 The name of the method metaclass for destructors. It will be used to
466 generate the inlined destructor. This defaults to
467 "Class::MOP::Method::Denstructor".
471 This option takes a hash reference. They keys are method names to be
472 memoized, and the values are the type of data the method returns. This
473 can be one of "SCALAR", "ARRAY", or "HASH".
477 This option takes an array reference of read-write methods which will
478 be made read-only. After they are transformed, attempting to set them
483 This option takes an array reference of methods which cannot be called
484 after immutabilization. Attempting to call these methods will throw an
489 This option takes a hash reference. The keys are method names and the
490 body is a subroutine reference which will wrap the named method. This
491 allows you to do some sort of custom transformation to a method.
495 =item B<< $transformer->options >>
497 Returns a hash reference of the options passed to C<new>.
499 =item B<< $transformer->metaclass >>
501 Returns the metaclass object passed to C<new>.
503 =item B<< $transformer->immutable_metaclass >>
505 Returns the immutable metaclass object that is created by the
506 transformation process.
508 =item B<< $transformer->inlined_constructor >>
510 If the constructor was inlined, this returns the constructor method
511 object that was created to do this.
517 Stevan Little E<lt>stevan@iinteractive.comE<gt>
519 =head1 COPYRIGHT AND LICENSE
521 Copyright 2006-2009 by Infinity Interactive, Inc.
523 L<http://www.iinteractive.com>
525 This library is free software; you can redistribute it and/or modify
526 it under the same terms as Perl itself.