lib/Class/MOP/Immutable.pm

   1
   2 package Class::MOP::Immutable;
   3
   4 use strict;
   5 use warnings;
   6
   7 use Class::MOP::Method::Constructor;
   8
   9 use Carp         'confess';
  10 use Scalar::Util 'blessed';
  11
  12 our $VERSION   = '0.01';
  13 our $AUTHORITY = 'cpan:STEVAN';
  14
  15 sub new {
  16     my ($class, $metaclass, $options) = @_;
  17
  18     my $self = bless {
  19         metaclass           => $metaclass,
  20         options             => $options,
  21         immutable_metaclass => undef,
  22     } => $class;
  23
  24     # NOTE:
  25     # we initialize the immutable
  26     # version of the metaclass here
  27     $self->create_immutable_metaclass;
  28
  29     return $self;
  30 }
  31
  32 sub immutable_metaclass { (shift)->{immutable_metaclass} }
  33 sub metaclass           { (shift)->{metaclass}           }
  34 sub options             { (shift)->{options}             }
  35
  36 sub create_immutable_metaclass {
  37     my $self = shift;
  38
  39     # NOTE:
  40     # The immutable version of the
  41     # metaclass is just a anon-class
  42     # which shadows the methods
  43     # appropriately
  44     $self->{immutable_metaclass} = Class::MOP::Class->create_anon_class(
  45         superclasses => [ blessed($self->metaclass) ],
  46         methods      => $self->create_methods_for_immutable_metaclass,
  47     );
  48 }
  49
  50 my %DEFAULT_METHODS = (
  51     meta => sub {
  52         my $self = shift;
  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
  58         return $self;
  59     },
  60     is_mutable     => sub {  0  },
  61     is_immutable   => sub {  1  },
  62     make_immutable => sub { ( ) },
  63 );
  64
  65 # NOTE:
  66 # this will actually convert the
  67 # existing metaclass to an immutable
  68 # version of itself
  69 sub make_metaclass_immutable {
  70     my ($self, $metaclass, %options) = @_;
  71
  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};
  76
  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);
  82         }
  83     }
  84
  85     if ($options{inline_constructor}) {
  86         my $constructor_class = $options{constructor_class} || 'Class::MOP::Method::Constructor';
  87
  88         my $constructor = $constructor_class->new(
  89             options       => \%options,
  90             meta_instance => $metaclass->get_meta_instance,
  91             attributes    => [ $metaclass->compute_all_applicable_attributes ]
  92         );
  93
  94         $metaclass->add_method(
  95             $options{constructor_name},
  96             $constructor
  97         );
  98     }
  99
 100     my $memoized_methods = $self->options->{memoize};
 101     foreach my $method_name (keys %{$memoized_methods}) {
 102         my $type = $memoized_methods->{$method_name};
 103
 104         ($metaclass->can($method_name))
 105             || confess "Could not find the method '$method_name' in " . $metaclass->name;
 106
 107         my $memoized_method;
 108         if ($type eq 'ARRAY') {
 109             $metaclass->{'___' . $method_name} = [ $metaclass->$method_name ];
 110         }
 111         elsif ($type eq 'HASH') {
 112             $metaclass->{'___' . $method_name} = { $metaclass->$method_name };
 113         }
 114         elsif ($type eq 'SCALAR') {
 115             $metaclass->{'___' . $method_name} = $metaclass->$method_name;
 116         }
 117     }
 118     $metaclass->{'___original_class'} = blessed($metaclass);
 119
 120     bless $metaclass => $self->immutable_metaclass->name;
 121 }
 122
 123 sub create_methods_for_immutable_metaclass {
 124     my $self = shift;
 125
 126     my %methods = %DEFAULT_METHODS;
 127
 128     foreach my $read_only_method (@{$self->options->{read_only}}) {
 129         my $method = $self->metaclass->meta->find_method_by_name($read_only_method);
 130
 131         (defined $method)
 132             || confess "Could not find the method '$read_only_method' in " . $self->metaclass->name;
 133
 134         $methods{$read_only_method} = sub {
 135             confess "This method is read-only" if scalar @_ > 1;
 136             goto &{$method->body}
 137         };
 138     }
 139
 140     foreach my $cannot_call_method (@{$self->options->{cannot_call}}) {
 141         $methods{$cannot_call_method} = sub {
 142             confess "This method cannot be called on an immutable instance";
 143         };
 144     }
 145
 146     my $memoized_methods = $self->options->{memoize};
 147
 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}} };
 152         }
 153         elsif ($type eq 'HASH') {
 154             $methods{$method_name} = sub { %{$_[0]->{'___' . $method_name}} };
 155         }
 156         elsif ($type eq 'SCALAR') {
 157             $methods{$method_name} = sub { $_[0]->{'___' . $method_name} };
 158         }
 159     }
 160
 161     $methods{get_mutable_metaclass_name} = sub { (shift)->{'___original_class'} };
 162
 163     return \%methods;
 164 }
 165
 166 1;
 167
 168 __END__
 169
 170 =pod
 171
 172 =head1 NAME
 173
 174 Class::MOP::Immutable - A class to transform Class::MOP::Class metaclasses
 175
 176 =head1 SYNOPSIS
 177
 178 =head1 DESCRIPTION
 179
 180 =head1 METHODS
 181
 182 =over 4
 183
 184 =item B<new>
 185
 186 =item B<options>
 187
 188 =item B<metaclass>
 189
 190 =item B<immutable_metaclass>
 191
 192 =back
 193
 194 =over 4
 195
 196 =item B<create_immutable_metaclass>
 197
 198 =item B<create_methods_for_immutable_metaclass>
 199
 200 =item B<make_metaclass_immutable>
 201
 202 =back
 203
 204 =head1 AUTHORS
 205
 206 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 207
 208 =head1 COPYRIGHT AND LICENSE
 209
 210 Copyright 2006 by Infinity Interactive, Inc.
 211
 212 L<http://www.iinteractive.com>
 213
 214 This library is free software; you can redistribute it and/or modify
 215 it under the same terms as Perl itself.
 216
 217 =cut