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.02';
  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
  51 my %DEFAULT_METHODS = (
  52     # I don't really understand this, but removing it breaks tests (groditi)
  53     meta => sub {
  54         my $self = shift;
  55         # if it is not blessed, then someone is asking
  56         # for the meta of Class::MOP::Class::Immutable
  57         return Class::MOP::Class->initialize($self) unless blessed($self);
  58         # otherwise, they are asking for the metaclass
  59         # which has been made immutable, which is itself
  60         return $self;
  61     },
  62     is_mutable     => sub { 0  },
  63     is_immutable   => sub { 1  },
  64     make_immutable => sub { () },
  65 );
  66
  67 # NOTE:
  68 # this will actually convert the
  69 # existing metaclass to an immutable
  70 # version of itself
  71 sub make_metaclass_immutable {
  72     my ($self, $metaclass, %options) = @_;
  73
  74     $options{inline_accessors}   = 1     unless exists $options{inline_accessors};
  75     $options{inline_constructor} = 1     unless exists $options{inline_constructor};
  76     $options{inline_destructor}  = 0     unless exists $options{inline_destructor};
  77     $options{constructor_name}   = 'new' unless exists $options{constructor_name};
  78     $options{debug}              = 0     unless exists $options{debug};
  79
  80     if ($options{inline_accessors}) {
  81         foreach my $attr_name ($metaclass->get_attribute_list) {
  82             # inline the accessors
  83             $metaclass->get_attribute($attr_name)
  84                       ->install_accessors(1);
  85         }
  86     }
  87
  88     if ($options{inline_constructor}) {
  89         my $constructor_class = $options{constructor_class} || 'Class::MOP::Method::Constructor';
  90         $metaclass->add_method(
  91             $options{constructor_name},
  92             $constructor_class->new(
  93                 options   => \%options,
  94                 metaclass => $metaclass,
  95                 is_inline => 1,
  96             )
  97         ) unless $metaclass->has_method($options{constructor_name});
  98     }
  99
 100     if ($options{inline_destructor}) {
 101         (exists $options{destructor_class})
 102             || confess "The 'inline_destructor' option is present, but "
 103                      . "no destructor class was specified";
 104
 105         my $destructor_class = $options{destructor_class};
 106
 107         my $destructor = $destructor_class->new(
 108             options   => \%options,
 109             metaclass => $metaclass,
 110         );
 111
 112         $metaclass->add_method('DESTROY' => $destructor)
 113             # NOTE:
 114             # we allow the destructor to determine
 115             # if it is needed or not, it can perform
 116             # all sorts of checks because it has the
 117             # metaclass instance
 118             if $destructor->is_needed;
 119     }
 120
 121     my $memoized_methods = $self->options->{memoize};
 122     foreach my $method_name (keys %{$memoized_methods}) {
 123         my $type = $memoized_methods->{$method_name};
 124
 125         ($metaclass->can($method_name))
 126             || confess "Could not find the method '$method_name' in " . $metaclass->name;
 127
 128         if ($type eq 'ARRAY') {
 129             $metaclass->{'___' . $method_name} = [ $metaclass->$method_name ];
 130         }
 131         elsif ($type eq 'HASH') {
 132             $metaclass->{'___' . $method_name} = { $metaclass->$method_name };
 133         }
 134         elsif ($type eq 'SCALAR') {
 135             $metaclass->{'___' . $method_name} = $metaclass->$method_name;
 136         }
 137     }
 138
 139     $metaclass->{'___original_class'} = blessed($metaclass);
 140     bless $metaclass => $self->immutable_metaclass->name;
 141 }
 142
 143 sub make_metaclass_mutable {
 144     my ($self, $immutable, %options) = @_;
 145
 146     my $original_class = $immutable->get_mutable_metaclass_name;
 147     delete $immutable->{'___original_class'} ;
 148     bless $immutable => $original_class;
 149
 150     my $memoized_methods = $self->options->{memoize};
 151     foreach my $method_name (keys %{$memoized_methods}) {
 152         my $type = $memoized_methods->{$method_name};
 153
 154         ($immutable->can($method_name))
 155           || confess "Could not find the method '$method_name' in " . $immutable->name;
 156         if ($type eq 'SCALAR' || $type eq 'ARRAY' ||  $type eq 'HASH' ) {
 157             delete $immutable->{'___' . $method_name};
 158         }
 159     }
 160
 161     if ($options{inline_destructor} && $immutable->has_method('DESTROY')) {
 162         $immutable->remove_method('DESTROY')
 163           if $immutable->get_method('DESTROY')->blessed eq $options{destructor_class};
 164     }
 165
 166     # NOTE:
 167     # 14:01 <@stevan> nah,. you shouldnt
 168     # 14:01 <@stevan> they are just inlined
 169     # 14:01 <@stevan> which is the default in Moose anyway
 170     # 14:02 <@stevan> and adding new attributes will just DWIM
 171     # 14:02 <@stevan> and you really cant change an attribute anyway
 172     # if ($options{inline_accessors}) {
 173     #     foreach my $attr_name ($immutable->get_attribute_list) {
 174     #         my $attr = $immutable->get_attribute($attr_name);
 175     #         $attr->remove_accessors;
 176     #         $attr->install_accessors(0);
 177     #     }
 178     # }
 179
 180     # 14:26 <@stevan> the only user of ::Method::Constructor is immutable
 181     # 14:27 <@stevan> if someone uses it outside of immutable,.. they are either: mst or groditi
 182     # 14:27 <@stevan> so I am not worried
 183     $options{constructor_name} = 'new' unless exists $options{constructor_name};
 184     if ($options{inline_constructor}) {
 185         my $constructor_class = $options{constructor_class} || 'Class::MOP::Method::Constructor';
 186         $immutable->remove_method( $options{constructor_name}  )
 187           if $immutable->get_method($options{constructor_name})->blessed eq $constructor_class;
 188     }
 189 }
 190
 191 sub create_methods_for_immutable_metaclass {
 192     my $self = shift;
 193
 194     my %methods = %DEFAULT_METHODS;
 195
 196     foreach my $read_only_method (@{$self->options->{read_only}}) {
 197         my $method = $self->metaclass->meta->find_method_by_name($read_only_method);
 198
 199         (defined $method)
 200             || confess "Could not find the method '$read_only_method' in " . $self->metaclass->name;
 201
 202         $methods{$read_only_method} = sub {
 203             confess "This method is read-only" if scalar @_ > 1;
 204             goto &{$method->body}
 205         };
 206     }
 207
 208     foreach my $cannot_call_method (@{$self->options->{cannot_call}}) {
 209         $methods{$cannot_call_method} = sub {
 210             confess "This method ($cannot_call_method) cannot be called on an immutable instance";
 211         };
 212     }
 213
 214     my $memoized_methods = $self->options->{memoize};
 215     foreach my $method_name (keys %{$memoized_methods}) {
 216         my $type = $memoized_methods->{$method_name};
 217         if ($type eq 'ARRAY') {
 218             $methods{$method_name} = sub { @{$_[0]->{'___' . $method_name}} };
 219         }
 220         elsif ($type eq 'HASH') {
 221             $methods{$method_name} = sub { %{$_[0]->{'___' . $method_name}} };
 222         }
 223         elsif ($type eq 'SCALAR') {
 224             $methods{$method_name} = sub { $_[0]->{'___' . $method_name} };
 225         }
 226     }
 227
 228     $methods{get_mutable_metaclass_name} = sub { (shift)->{'___original_class'} };
 229
 230     return \%methods;
 231 }
 232
 233 1;
 234
 235 __END__
 236
 237 =pod
 238
 239 =head1 NAME
 240
 241 Class::MOP::Immutable - A class to transform Class::MOP::Class metaclasses
 242
 243 =head1 SYNOPSIS
 244
 245     use Class::MOP::Immutable;
 246
 247     my $immutable_metaclass = Class::MOP::Immutable->new($metaclass, {
 248         read_only   => [qw/superclasses/],
 249         cannot_call => [qw/
 250             add_method
 251             alias_method
 252             remove_method
 253             add_attribute
 254             remove_attribute
 255             add_package_symbol
 256             remove_package_symbol
 257         /],
 258         memoize     => {
 259             class_precedence_list             => 'ARRAY',
 260             compute_all_applicable_attributes => 'ARRAY',
 261             get_meta_instance                 => 'SCALAR',
 262             get_method_map                    => 'SCALAR',
 263         }
 264     });
 265
 266     $immutable_metaclass->make_metaclass_immutable(@_)
 267
 268 =head1 DESCRIPTION
 269
 270 This is basically a module for applying a transformation on a given
 271 metaclass. Current features include making methods read-only,
 272 making methods un-callable and memoizing methods (in a type specific
 273 way too).
 274
 275 This module is fairly new to the MOP, and quite possibly will be
 276 expanded and further generalized as the need arises.
 277
 278 =head1 METHODS
 279
 280 =over 4
 281
 282 =item B<new ($metaclass, \%options)>
 283
 284 Given a C<$metaclass> and a set of C<%options> this module will
 285 prepare an immutable version of the C<$metaclass>, which can then
 286 be applied to the C<$metaclass> using the C<make_metaclass_immutable>
 287 method.
 288
 289 =item B<options>
 290
 291 Returns the options HASH set in C<new>.
 292
 293 =item B<metaclass>
 294
 295 Returns the metaclass set in C<new>.
 296
 297 =item B<immutable_metaclass>
 298
 299 Returns the immutable metaclass created within C<new>.
 300
 301 =back
 302
 303 =over 4
 304
 305 =item B<create_immutable_metaclass>
 306
 307 This will create the immutable version of the C<$metaclass>, but will
 308 not actually change the original metaclass.
 309
 310 =item B<create_methods_for_immutable_metaclass>
 311
 312 This will create all the methods for the immutable metaclass based
 313 on the C<%options> passed into C<new>.
 314
 315 =item B<make_metaclass_immutable (%options)>
 316
 317 This will actually change the C<$metaclass> into the immutable version.
 318
 319 =item B<make_metaclass_mutable (%options)>
 320
 321 This will change the C<$metaclass> into the mutable version by reversing
 322 the immutable process. C<%options> should be the same options that were
 323 given to make_metaclass_immutable.
 324
 325 =back
 326
 327 =head1 AUTHORS
 328
 329 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 330
 331 =head1 COPYRIGHT AND LICENSE
 332
 333 Copyright 2006, 2007 by Infinity Interactive, Inc.
 334
 335 L<http://www.iinteractive.com>
 336
 337 This library is free software; you can redistribute it and/or modify
 338 it under the same terms as Perl itself.
 339
 340 =cut