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