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.05';
  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 $immutable->get_method('DESTROY')->blessed 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}) {
 195         my $constructor_class = $options{constructor_class} || 'Class::MOP::Method::Constructor';
 196         $immutable->remove_method( $options{constructor_name}  )
 197           if $immutable->get_method($options{constructor_name})->blessed 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 $around_methods = $self->options->{around};
 239     foreach my $method_name (keys %{$around_methods}) {
 240         my $method = $self->metaclass->meta->find_method_by_name($method_name);
 241         $method = Class::MOP::Method::Wrapped->wrap($method);
 242         $method->add_around_modifier(subname ':around' => $around_methods->{$method_name});
 243     }
 244
 245     $methods{get_mutable_metaclass_name} = sub { (shift)->{'___original_class'} };
 246
 247     $methods{immutable_transformer} = sub { $self };
 248
 249     return \%methods;
 250 }
 251
 252 1;
 253
 254 __END__
 255
 256 =pod
 257
 258 =head1 NAME
 259
 260 Class::MOP::Immutable - A class to transform Class::MOP::Class metaclasses
 261
 262 =head1 SYNOPSIS
 263
 264     use Class::MOP::Immutable;
 265
 266     my $immutable_metaclass = Class::MOP::Immutable->new($metaclass, {
 267         read_only   => [qw/superclasses/],
 268         cannot_call => [qw/
 269             add_method
 270             alias_method
 271             remove_method
 272             add_attribute
 273             remove_attribute
 274             add_package_symbol
 275             remove_package_symbol
 276         /],
 277         memoize     => {
 278             class_precedence_list             => 'ARRAY',
 279             compute_all_applicable_attributes => 'ARRAY',
 280             get_meta_instance                 => 'SCALAR',
 281             get_method_map                    => 'SCALAR',
 282         }
 283     });
 284
 285     $immutable_metaclass->make_metaclass_immutable(@_)
 286
 287 =head1 DESCRIPTION
 288
 289 This is basically a module for applying a transformation on a given
 290 metaclass. Current features include making methods read-only,
 291 making methods un-callable and memoizing methods (in a type specific
 292 way too).
 293
 294 This module is not for the feint of heart, it does some whacky things
 295 to the metaclass in order to make it immutable. If you are just curious,
 296 I suggest you turn back now, there is nothing to see here.
 297
 298 =head1 METHODS
 299
 300 =over 4
 301
 302 =item B<new ($metaclass, \%options)>
 303
 304 Given a C<$metaclass> and a set of C<%options> this module will
 305 prepare an immutable version of the C<$metaclass>, which can then
 306 be applied to the C<$metaclass> using the C<make_metaclass_immutable>
 307 method.
 308
 309 =item B<options>
 310
 311 Returns the options HASH set in C<new>.
 312
 313 =item B<metaclass>
 314
 315 Returns the metaclass set in C<new>.
 316
 317 =item B<immutable_metaclass>
 318
 319 Returns the immutable metaclass created within C<new>.
 320
 321 =back
 322
 323 =over 4
 324
 325 =item B<create_immutable_metaclass>
 326
 327 This will create the immutable version of the C<$metaclass>, but will
 328 not actually change the original metaclass.
 329
 330 =item B<create_methods_for_immutable_metaclass>
 331
 332 This will create all the methods for the immutable metaclass based
 333 on the C<%options> passed into C<new>.
 334
 335 =item B<make_metaclass_immutable (%options)>
 336
 337 This will actually change the C<$metaclass> into the immutable version.
 338
 339 =item B<make_metaclass_mutable (%options)>
 340
 341 This will change the C<$metaclass> into the mutable version by reversing
 342 the immutable process. C<%options> should be the same options that were
 343 given to make_metaclass_immutable.
 344
 345 =back
 346
 347 =head1 AUTHORS
 348
 349 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 350
 351 =head1 COPYRIGHT AND LICENSE
 352
 353 Copyright 2006-2008 by Infinity Interactive, Inc.
 354
 355 L<http://www.iinteractive.com>
 356
 357 This library is free software; you can redistribute it and/or modify
 358 it under the same terms as Perl itself.
 359
 360 =cut