2 package Class::MOP::Immutable;
7 use Class::MOP::Method::Constructor;
10 use Scalar::Util 'blessed';
12 our $VERSION = '0.01';
13 our $AUTHORITY = 'cpan:STEVAN';
16 my ($class, $metaclass, $options) = @_;
19 metaclass => $metaclass,
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,
50 my %DEFAULT_METHODS = (
53 # if it is not blessed, then someone is asking
54 # for the meta of Class::MOP::Class::Immutable
55 return Class::MOP::Class->initialize($self) unless blessed($self);
56 # otherwise, they are asking for the metaclass
57 # which has been made immutable, which is itself
60 is_mutable => sub { 0 },
61 is_immutable => sub { 1 },
62 make_immutable => sub { ( ) },
66 # this will actually convert the
67 # existing metaclass to an immutable
69 sub make_metaclass_immutable {
70 my ($self, $metaclass, %options) = @_;
72 $options{inline_accessors} = 1 unless exists $options{inline_accessors};
73 $options{inline_constructor} = 1 unless exists $options{inline_constructor};
74 $options{constructor_name} = 'new' unless exists $options{constructor_name};
75 $options{debug} = 0 unless exists $options{debug};
77 if ($options{inline_accessors}) {
78 foreach my $attr_name ($metaclass->get_attribute_list) {
79 # inline the accessors
80 $metaclass->get_attribute($attr_name)
81 ->install_accessors(1);
85 if ($options{inline_constructor}) {
86 my $constructor_class = $options{constructor_class} || 'Class::MOP::Method::Constructor';
88 $metaclass->add_method(
89 $options{constructor_name},
90 $constructor_class->new(
91 metaclass => $metaclass,
94 meta_instance => $metaclass->get_meta_instance,
95 attributes => [ $metaclass->compute_all_applicable_attributes ]
97 ) unless $metaclass->has_method($options{constructor_name});
100 my $memoized_methods = $self->options->{memoize};
101 foreach my $method_name (keys %{$memoized_methods}) {
102 my $type = $memoized_methods->{$method_name};
104 ($metaclass->can($method_name))
105 || confess "Could not find the method '$method_name' in " . $metaclass->name;
108 if ($type eq 'ARRAY') {
109 $metaclass->{'___' . $method_name} = [ $metaclass->$method_name ];
111 elsif ($type eq 'HASH') {
112 $metaclass->{'___' . $method_name} = { $metaclass->$method_name };
114 elsif ($type eq 'SCALAR') {
115 $metaclass->{'___' . $method_name} = $metaclass->$method_name;
118 $metaclass->{'___original_class'} = blessed($metaclass);
120 bless $metaclass => $self->immutable_metaclass->name;
123 sub create_methods_for_immutable_metaclass {
126 my %methods = %DEFAULT_METHODS;
128 foreach my $read_only_method (@{$self->options->{read_only}}) {
129 my $method = $self->metaclass->meta->find_method_by_name($read_only_method);
132 || confess "Could not find the method '$read_only_method' in " . $self->metaclass->name;
134 $methods{$read_only_method} = sub {
135 confess "This method is read-only" if scalar @_ > 1;
136 goto &{$method->body}
140 foreach my $cannot_call_method (@{$self->options->{cannot_call}}) {
141 $methods{$cannot_call_method} = sub {
142 confess "This method ($cannot_call_method) cannot be called on an immutable instance";
146 my $memoized_methods = $self->options->{memoize};
148 foreach my $method_name (keys %{$memoized_methods}) {
149 my $type = $memoized_methods->{$method_name};
150 if ($type eq 'ARRAY') {
151 $methods{$method_name} = sub { @{$_[0]->{'___' . $method_name}} };
153 elsif ($type eq 'HASH') {
154 $methods{$method_name} = sub { %{$_[0]->{'___' . $method_name}} };
156 elsif ($type eq 'SCALAR') {
157 $methods{$method_name} = sub { $_[0]->{'___' . $method_name} };
161 $methods{get_mutable_metaclass_name} = sub { (shift)->{'___original_class'} };
174 Class::MOP::Immutable - A class to transform Class::MOP::Class metaclasses
190 =item B<immutable_metaclass>
196 =item B<create_immutable_metaclass>
198 =item B<create_methods_for_immutable_metaclass>
200 =item B<make_metaclass_immutable>
206 Stevan Little E<lt>stevan@iinteractive.comE<gt>
208 =head1 COPYRIGHT AND LICENSE
210 Copyright 2006 by Infinity Interactive, Inc.
212 L<http://www.iinteractive.com>
214 This library is free software; you can redistribute it and/or modify
215 it under the same terms as Perl itself.