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