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_01';
  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
 179     $metaclass->{'___original_class'} = blessed($metaclass);
 180     bless $metaclass => $self->immutable_metaclass->name;
 181 }
 182
 183 sub make_metaclass_mutable {
 184     my ($self, $immutable, $options) = @_;
 185
 186     my %options = %$options;
 187
 188     my $original_class = $immutable->get_mutable_metaclass_name;
 189     delete $immutable->{'___original_class'} ;
 190     bless $immutable => $original_class;
 191
 192     my $memoized_methods = $self->options->{memoize};
 193     foreach my $method_name (keys %{$memoized_methods}) {
 194         my $type = $memoized_methods->{$method_name};
 195
 196         ($immutable->can($method_name))
 197           || confess "Could not find the method '$method_name' in " . $immutable->name;
 198         if ($type eq 'SCALAR' || $type eq 'ARRAY' ||  $type eq 'HASH' ) {
 199             delete $immutable->{'___' . $method_name};
 200         }
 201     }
 202
 203     if ($options{inline_destructor} && $immutable->has_method('DESTROY')) {
 204         $immutable->remove_method('DESTROY')
 205           if blessed($immutable->get_method('DESTROY')) eq $options{destructor_class};
 206     }
 207
 208     # NOTE:
 209     # 14:01 <@stevan> nah,. you shouldnt
 210     # 14:01 <@stevan> they are just inlined
 211     # 14:01 <@stevan> which is the default in Moose anyway
 212     # 14:02 <@stevan> and adding new attributes will just DWIM
 213     # 14:02 <@stevan> and you really cant change an attribute anyway
 214     # if ($options{inline_accessors}) {
 215     #     foreach my $attr_name ($immutable->get_attribute_list) {
 216     #         my $attr = $immutable->get_attribute($attr_name);
 217     #         $attr->remove_accessors;
 218     #         $attr->install_accessors(0);
 219     #     }
 220     # }
 221
 222     # 14:26 <@stevan> the only user of ::Method::Constructor is immutable
 223     # 14:27 <@stevan> if someone uses it outside of immutable,.. they are either: mst or groditi
 224     # 14:27 <@stevan> so I am not worried
 225     if ($options{inline_constructor}  && $immutable->has_method($options{constructor_name})) {
 226         my $constructor_class = $options{constructor_class} || 'Class::MOP::Method::Constructor';
 227         $immutable->remove_method( $options{constructor_name}  )
 228           if blessed($immutable->get_method($options{constructor_name})) eq $constructor_class;
 229     }
 230 }
 231
 232 sub create_methods_for_immutable_metaclass {
 233     my $self = shift;
 234
 235     my %methods = %DEFAULT_METHODS;
 236     my $metaclass = $self->metaclass;
 237     my $meta = $metaclass->meta;
 238
 239     foreach my $read_only_method (@{$self->options->{read_only}}) {
 240         my $method = $meta->find_method_by_name($read_only_method);
 241
 242         (defined $method)
 243             || confess "Could not find the method '$read_only_method' in " . $metaclass->name;
 244
 245         $methods{$read_only_method} = sub {
 246             confess "This method is read-only" if scalar @_ > 1;
 247             goto &{$method->body}
 248         };
 249     }
 250
 251     foreach my $cannot_call_method (@{$self->options->{cannot_call}}) {
 252         $methods{$cannot_call_method} = sub {
 253             confess "This method ($cannot_call_method) cannot be called on an immutable instance";
 254         };
 255     }
 256
 257     my $memoized_methods = $self->options->{memoize};
 258     foreach my $method_name (keys %{$memoized_methods}) {
 259         my $type = $memoized_methods->{$method_name};
 260         my $key = '___' . $method_name;
 261         my $method = $meta->find_method_by_name($method_name);
 262
 263         if ($type eq 'ARRAY') {
 264             $methods{$method_name} = sub {
 265                 @{$_[0]->{$key}} = $method->execute($_[0])
 266                     if !exists $_[0]->{$key};
 267                 return @{$_[0]->{$key}};
 268             };
 269         }
 270         elsif ($type eq 'HASH') {
 271             $methods{$method_name} = sub {
 272                 %{$_[0]->{$key}} = $method->execute($_[0])
 273                     if !exists $_[0]->{$key};
 274                 return %{$_[0]->{$key}};
 275             };
 276         }
 277         elsif ($type eq 'SCALAR') {
 278             $methods{$method_name} = sub {
 279                 $_[0]->{$key} = $method->execute($_[0])
 280                     if !exists $_[0]->{$key};
 281                 return $_[0]->{$key};
 282             };
 283         }
 284     }
 285
 286     my $wrapped_methods = $self->options->{wrapped};
 287
 288     foreach my $method_name (keys %{ $wrapped_methods }) {
 289         my $method = $meta->find_method_by_name($method_name);
 290
 291         (defined $method)
 292             || confess "Could not find the method '$method_name' in " . $metaclass->name;
 293
 294         my $wrapper = $wrapped_methods->{$method_name};
 295
 296         $methods{$method_name} = sub { $wrapper->($method, @_) };
 297     }
 298
 299     $methods{get_mutable_metaclass_name} = sub { (shift)->{'___original_class'} };
 300
 301     $methods{immutable_transformer} = sub { $self };
 302
 303     return \%methods;
 304 }
 305
 306 1;
 307
 308 __END__
 309
 310 =pod
 311
 312 =head1 NAME
 313
 314 Class::MOP::Immutable - A class to transform Class::MOP::Class metaclasses
 315
 316 =head1 SYNOPSIS
 317
 318     use Class::MOP::Immutable;
 319
 320     my $immutable_metaclass = Class::MOP::Immutable->new($metaclass, {
 321         read_only   => [qw/superclasses/],
 322         cannot_call => [qw/
 323             add_method
 324             alias_method
 325             remove_method
 326             add_attribute
 327             remove_attribute
 328             add_package_symbol
 329             remove_package_symbol
 330         /],
 331         memoize     => {
 332             class_precedence_list             => 'ARRAY',
 333             compute_all_applicable_attributes => 'ARRAY',
 334             get_meta_instance                 => 'SCALAR',
 335             get_method_map                    => 'SCALAR',
 336         }
 337     });
 338
 339     $immutable_metaclass->make_metaclass_immutable(@_)
 340
 341 =head1 DESCRIPTION
 342
 343 This is basically a module for applying a transformation on a given
 344 metaclass. Current features include making methods read-only,
 345 making methods un-callable and memoizing methods (in a type specific
 346 way too).
 347
 348 This module is not for the feint of heart, it does some whacky things
 349 to the metaclass in order to make it immutable. If you are just curious,
 350 I suggest you turn back now, there is nothing to see here.
 351
 352 =head1 METHODS
 353
 354 =over 4
 355
 356 =item B<new ($metaclass, \%options)>
 357
 358 Given a C<$metaclass> and a set of C<%options> this module will
 359 prepare an immutable version of the C<$metaclass>, which can then
 360 be applied to the C<$metaclass> using the C<make_metaclass_immutable>
 361 method.
 362
 363 =item B<options>
 364
 365 Returns the options HASH set in C<new>.
 366
 367 =item B<metaclass>
 368
 369 Returns the metaclass set in C<new>.
 370
 371 =item B<immutable_metaclass>
 372
 373 Returns the immutable metaclass created within C<new>.
 374
 375 =back
 376
 377 =over 4
 378
 379 =item B<create_immutable_metaclass>
 380
 381 This will create the immutable version of the C<$metaclass>, but will
 382 not actually change the original metaclass.
 383
 384 =item B<create_methods_for_immutable_metaclass>
 385
 386 This will create all the methods for the immutable metaclass based
 387 on the C<%options> passed into C<new>.
 388
 389 =item B<make_metaclass_immutable (%options)>
 390
 391 This will actually change the C<$metaclass> into the immutable version.
 392
 393 =item B<make_metaclass_mutable (%options)>
 394
 395 This will change the C<$metaclass> into the mutable version by reversing
 396 the immutable process. C<%options> should be the same options that were
 397 given to make_metaclass_immutable.
 398
 399 =back
 400
 401 =head1 AUTHORS
 402
 403 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 404
 405 =head1 COPYRIGHT AND LICENSE
 406
 407 Copyright 2006-2008 by Infinity Interactive, Inc.
 408
 409 L<http://www.iinteractive.com>
 410
 411 This library is free software; you can redistribute it and/or modify
 412 it under the same terms as Perl itself.
 413
 414 =cut