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