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     use Class::MOP::Immutable;
 198
 199     my $immutable_metaclass = Class::MOP::Immutable->new($metaclass, {
 200         read_only   => [qw/superclasses/],
 201         cannot_call => [qw/
 202             add_method
 203             alias_method
 204             remove_method
 205             add_attribute
 206             remove_attribute
 207             add_package_symbol
 208             remove_package_symbol
 209         /],
 210         memoize     => {
 211             class_precedence_list             => 'ARRAY',
 212             compute_all_applicable_attributes => 'ARRAY',
 213             get_meta_instance                 => 'SCALAR',
 214             get_method_map                    => 'SCALAR',
 215         }
 216     });
 217
 218     $immutable_metaclass->make_metaclass_immutable(@_)
 219
 220 =head1 DESCRIPTION
 221
 222 This is basically a module for applying a transformation on a given
 223 metaclass. Current features include making methods read-only,
 224 making methods un-callable and memoizing methods (in a type specific
 225 way too).
 226
 227 This module is fairly new to the MOP, and quite possibly will be
 228 expanded and further generalized as the need arises.
 229
 230 =head1 METHODS
 231
 232 =over 4
 233
 234 =item B<new ($metaclass, \%options)>
 235
 236 Given a C<$metaclass> and a set of C<%options> this module will
 237 prepare an immutable version of the C<$metaclass>, which can then
 238 be applied to the C<$metaclass> using the C<make_metaclass_immutable>
 239 method.
 240
 241 =item B<options>
 242
 243 Returns the options HASH set in C<new>.
 244
 245 =item B<metaclass>
 246
 247 Returns the metaclass set in C<new>.
 248
 249 =item B<immutable_metaclass>
 250
 251 Returns the immutable metaclass created within C<new>.
 252
 253 =back
 254
 255 =over 4
 256
 257 =item B<create_immutable_metaclass>
 258
 259 This will create the immutable version of the C<$metaclass>, but will
 260 not actually change the original metaclass.
 261
 262 =item B<create_methods_for_immutable_metaclass>
 263
 264 This will create all the methods for the immutable metaclass based
 265 on the C<%options> passed into C<new>.
 266
 267 =item B<make_metaclass_immutable>
 268
 269 This will actually change the C<$metaclass> into the immutable version.
 270
 271 =back
 272
 273 =head1 AUTHORS
 274
 275 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 276
 277 =head1 COPYRIGHT AND LICENSE
 278
 279 Copyright 2006, 2007 by Infinity Interactive, Inc.
 280
 281 L<http://www.iinteractive.com>
 282
 283 This library is free software; you can redistribute it and/or modify
 284 it under the same terms as Perl itself.
 285
 286 =cut