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