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