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