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