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{inline_destructor}  = 0     unless exists $options{inline_destructor};
  75     $options{constructor_name}   = 'new' unless exists $options{constructor_name};
  76     $options{debug}              = 0     unless exists $options{debug};
  77
  78     if ($options{inline_accessors}) {
  79         foreach my $attr_name ($metaclass->get_attribute_list) {
  80             # inline the accessors
  81             $metaclass->get_attribute($attr_name)
  82                       ->install_accessors(1);
  83         }
  84     }
  85
  86     if ($options{inline_constructor}) {
  87         my $constructor_class = $options{constructor_class} || 'Class::MOP::Method::Constructor';
  88
  89         $metaclass->add_method(
  90             $options{constructor_name},
  91             $constructor_class->new(
  92                 options   => \%options,
  93                 metaclass => $metaclass,
  94             )
  95         ) unless $metaclass->has_method($options{constructor_name});
  96     }
  97
  98     if ($options{inline_destructor}) {
  99         (exists $options{destructor_class})
 100             || confess "The 'inline_destructor' option is present, but "
 101                      . "no destructor class was specified";
 102
 103         my $destructor_class = $options{destructor_class};
 104
 105         my $destructor = $destructor_class->new(
 106             options   => \%options,
 107             metaclass => $metaclass,
 108         );
 109
 110         $metaclass->add_method('DESTROY' => $destructor)
 111             # NOTE:
 112             # we allow the destructor to determine
 113             # if it is needed or not, it can perform
 114             # all sorts of checks because it has the
 115             # metaclass instance
 116             if $destructor->is_needed;
 117     }
 118
 119     my $memoized_methods = $self->options->{memoize};
 120     foreach my $method_name (keys %{$memoized_methods}) {
 121         my $type = $memoized_methods->{$method_name};
 122
 123         ($metaclass->can($method_name))
 124             || confess "Could not find the method '$method_name' in " . $metaclass->name;
 125
 126         my $memoized_method;
 127         if ($type eq 'ARRAY') {
 128             $metaclass->{'___' . $method_name} = [ $metaclass->$method_name ];
 129         }
 130         elsif ($type eq 'HASH') {
 131             $metaclass->{'___' . $method_name} = { $metaclass->$method_name };
 132         }
 133         elsif ($type eq 'SCALAR') {
 134             $metaclass->{'___' . $method_name} = $metaclass->$method_name;
 135         }
 136     }
 137     $metaclass->{'___original_class'} = blessed($metaclass);
 138
 139     bless $metaclass => $self->immutable_metaclass->name;
 140 }
 141
 142 sub create_methods_for_immutable_metaclass {
 143     my $self = shift;
 144
 145     my %methods = %DEFAULT_METHODS;
 146
 147     foreach my $read_only_method (@{$self->options->{read_only}}) {
 148         my $method = $self->metaclass->meta->find_method_by_name($read_only_method);
 149
 150         (defined $method)
 151             || confess "Could not find the method '$read_only_method' in " . $self->metaclass->name;
 152
 153         $methods{$read_only_method} = sub {
 154             confess "This method is read-only" if scalar @_ > 1;
 155             goto &{$method->body}
 156         };
 157     }
 158
 159     foreach my $cannot_call_method (@{$self->options->{cannot_call}}) {
 160         $methods{$cannot_call_method} = sub {
 161             confess "This method ($cannot_call_method) cannot be called on an immutable instance";
 162         };
 163     }
 164
 165     my $memoized_methods = $self->options->{memoize};
 166
 167     foreach my $method_name (keys %{$memoized_methods}) {
 168         my $type = $memoized_methods->{$method_name};
 169         if ($type eq 'ARRAY') {
 170             $methods{$method_name} = sub { @{$_[0]->{'___' . $method_name}} };
 171         }
 172         elsif ($type eq 'HASH') {
 173             $methods{$method_name} = sub { %{$_[0]->{'___' . $method_name}} };
 174         }
 175         elsif ($type eq 'SCALAR') {
 176             $methods{$method_name} = sub { $_[0]->{'___' . $method_name} };
 177         }
 178     }
 179
 180     $methods{get_mutable_metaclass_name} = sub { (shift)->{'___original_class'} };
 181
 182     return \%methods;
 183 }
 184
 185 1;
 186
 187 __END__
 188
 189 =pod
 190
 191 =head1 NAME
 192
 193 Class::MOP::Immutable - A class to transform Class::MOP::Class metaclasses
 194
 195 =head1 SYNOPSIS
 196
 197 =head1 DESCRIPTION
 198
 199 =head1 METHODS
 200
 201 =over 4
 202
 203 =item B<new>
 204
 205 =item B<options>
 206
 207 =item B<metaclass>
 208
 209 =item B<immutable_metaclass>
 210
 211 =back
 212
 213 =over 4
 214
 215 =item B<create_immutable_metaclass>
 216
 217 =item B<create_methods_for_immutable_metaclass>
 218
 219 =item B<make_metaclass_immutable>
 220
 221 =back
 222
 223 =head1 AUTHORS
 224
 225 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 226
 227 =head1 COPYRIGHT AND LICENSE
 228
 229 Copyright 2006 by Infinity Interactive, Inc.
 230
 231 L<http://www.iinteractive.com>
 232
 233 This library is free software; you can redistribute it and/or modify
 234 it under the same terms as Perl itself.
 235
 236 =cut