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     my $metaclass = $self->metaclass;
 247     my $meta = $metaclass->meta;
 248
 249     foreach my $read_only_method (@{$self->options->{read_only}}) {
 250         my $method = $meta->find_method_by_name($read_only_method);
 251
 252         (defined $method)
 253             || confess "Could not find the method '$read_only_method' in " . $metaclass->name;
 254
 255         $methods{$read_only_method} = sub {
 256             confess "This method is read-only" if scalar @_ > 1;
 257             goto &{$method->body}
 258         };
 259     }
 260
 261     foreach my $cannot_call_method (@{$self->options->{cannot_call}}) {
 262         $methods{$cannot_call_method} = sub {
 263             confess "This method ($cannot_call_method) cannot be called on an immutable instance";
 264         };
 265     }
 266
 267     my $memoized_methods = $self->options->{memoize};
 268     foreach my $method_name (keys %{$memoized_methods}) {
 269         my $type = $memoized_methods->{$method_name};
 270         if ($type eq 'ARRAY') {
 271             $methods{$method_name} = sub { @{$_[0]->{'___' . $method_name}} };
 272         }
 273         elsif ($type eq 'HASH') {
 274             $methods{$method_name} = sub { %{$_[0]->{'___' . $method_name}} };
 275         }
 276         elsif ($type eq 'SCALAR') {
 277             $methods{$method_name} = sub { $_[0]->{'___' . $method_name} };
 278         }
 279     }
 280
 281     my $wrapped_methods = $self->options->{wrapped};
 282
 283     foreach my $method_name (keys %{ $wrapped_methods }) {
 284         my $method = $meta->find_method_by_name($method_name);
 285
 286         (defined $method)
 287             || confess "Could not find the method '$method_name' in " . $metaclass->name;
 288
 289         my $wrapper = $wrapped_methods->{$method_name};
 290
 291         $methods{$method_name} = sub { $wrapper->($method, @_) };
 292     }
 293
 294     $methods{get_mutable_metaclass_name} = sub { (shift)->{'___original_class'} };
 295
 296     $methods{immutable_transformer} = sub { $self };
 297
 298     return \%methods;
 299 }
 300
 301 1;
 302
 303 __END__
 304
 305 =pod
 306
 307 =head1 NAME
 308
 309 Class::MOP::Immutable - A class to transform Class::MOP::Class metaclasses
 310
 311 =head1 SYNOPSIS
 312
 313     use Class::MOP::Immutable;
 314
 315     my $immutable_metaclass = Class::MOP::Immutable->new($metaclass, {
 316         read_only   => [qw/superclasses/],
 317         cannot_call => [qw/
 318             add_method
 319             alias_method
 320             remove_method
 321             add_attribute
 322             remove_attribute
 323             add_package_symbol
 324             remove_package_symbol
 325         /],
 326         memoize     => {
 327             class_precedence_list             => 'ARRAY',
 328             compute_all_applicable_attributes => 'ARRAY',
 329             get_meta_instance                 => 'SCALAR',
 330             get_method_map                    => 'SCALAR',
 331         }
 332     });
 333
 334     $immutable_metaclass->make_metaclass_immutable(@_)
 335
 336 =head1 DESCRIPTION
 337
 338 This is basically a module for applying a transformation on a given
 339 metaclass. Current features include making methods read-only,
 340 making methods un-callable and memoizing methods (in a type specific
 341 way too).
 342
 343 This module is not for the feint of heart, it does some whacky things
 344 to the metaclass in order to make it immutable. If you are just curious,
 345 I suggest you turn back now, there is nothing to see here.
 346
 347 =head1 METHODS
 348
 349 =over 4
 350
 351 =item B<new ($metaclass, \%options)>
 352
 353 Given a C<$metaclass> and a set of C<%options> this module will
 354 prepare an immutable version of the C<$metaclass>, which can then
 355 be applied to the C<$metaclass> using the C<make_metaclass_immutable>
 356 method.
 357
 358 =item B<options>
 359
 360 Returns the options HASH set in C<new>.
 361
 362 =item B<metaclass>
 363
 364 Returns the metaclass set in C<new>.
 365
 366 =item B<immutable_metaclass>
 367
 368 Returns the immutable metaclass created within C<new>.
 369
 370 =back
 371
 372 =over 4
 373
 374 =item B<create_immutable_metaclass>
 375
 376 This will create the immutable version of the C<$metaclass>, but will
 377 not actually change the original metaclass.
 378
 379 =item B<create_methods_for_immutable_metaclass>
 380
 381 This will create all the methods for the immutable metaclass based
 382 on the C<%options> passed into C<new>.
 383
 384 =item B<make_metaclass_immutable (%options)>
 385
 386 This will actually change the C<$metaclass> into the immutable version.
 387
 388 =item B<make_metaclass_mutable (%options)>
 389
 390 This will change the C<$metaclass> into the mutable version by reversing
 391 the immutable process. C<%options> should be the same options that were
 392 given to make_metaclass_immutable.
 393
 394 =back
 395
 396 =head1 AUTHORS
 397
 398 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 399
 400 =head1 COPYRIGHT AND LICENSE
 401
 402 Copyright 2006-2008 by Infinity Interactive, Inc.
 403
 404 L<http://www.iinteractive.com>
 405
 406 This library is free software; you can redistribute it and/or modify
 407 it under the same terms as Perl itself.
 408
 409 =cut