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.02';
  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::Class::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     return \%methods;
 238 }
 239
 240 1;
 241
 242 __END__
 243
 244 =pod
 245
 246 =head1 NAME
 247
 248 Class::MOP::Immutable - A class to transform Class::MOP::Class metaclasses
 249
 250 =head1 SYNOPSIS
 251
 252     use Class::MOP::Immutable;
 253
 254     my $immutable_metaclass = Class::MOP::Immutable->new($metaclass, {
 255         read_only   => [qw/superclasses/],
 256         cannot_call => [qw/
 257             add_method
 258             alias_method
 259             remove_method
 260             add_attribute
 261             remove_attribute
 262             add_package_symbol
 263             remove_package_symbol
 264         /],
 265         memoize     => {
 266             class_precedence_list             => 'ARRAY',
 267             compute_all_applicable_attributes => 'ARRAY',
 268             get_meta_instance                 => 'SCALAR',
 269             get_method_map                    => 'SCALAR',
 270         }
 271     });
 272
 273     $immutable_metaclass->make_metaclass_immutable(@_)
 274
 275 =head1 DESCRIPTION
 276
 277 This is basically a module for applying a transformation on a given
 278 metaclass. Current features include making methods read-only,
 279 making methods un-callable and memoizing methods (in a type specific
 280 way too).
 281
 282 This module is fairly new to the MOP, and quite possibly will be
 283 expanded and further generalized as the need arises.
 284
 285 =head1 METHODS
 286
 287 =over 4
 288
 289 =item B<new ($metaclass, \%options)>
 290
 291 Given a C<$metaclass> and a set of C<%options> this module will
 292 prepare an immutable version of the C<$metaclass>, which can then
 293 be applied to the C<$metaclass> using the C<make_metaclass_immutable>
 294 method.
 295
 296 =item B<options>
 297
 298 Returns the options HASH set in C<new>.
 299
 300 =item B<metaclass>
 301
 302 Returns the metaclass set in C<new>.
 303
 304 =item B<immutable_metaclass>
 305
 306 Returns the immutable metaclass created within C<new>.
 307
 308 =back
 309
 310 =over 4
 311
 312 =item B<create_immutable_metaclass>
 313
 314 This will create the immutable version of the C<$metaclass>, but will
 315 not actually change the original metaclass.
 316
 317 =item B<create_methods_for_immutable_metaclass>
 318
 319 This will create all the methods for the immutable metaclass based
 320 on the C<%options> passed into C<new>.
 321
 322 =item B<make_metaclass_immutable (%options)>
 323
 324 This will actually change the C<$metaclass> into the immutable version.
 325
 326 =item B<make_metaclass_mutable (%options)>
 327
 328 This will change the C<$metaclass> into the mutable version by reversing
 329 the immutable process. C<%options> should be the same options that were
 330 given to make_metaclass_immutable.
 331
 332 =back
 333
 334 =head1 AUTHORS
 335
 336 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 337
 338 =head1 COPYRIGHT AND LICENSE
 339
 340 Copyright 2006, 2007 by Infinity Interactive, Inc.
 341
 342 L<http://www.iinteractive.com>
 343
 344 This library is free software; you can redistribute it and/or modify
 345 it under the same terms as Perl itself.
 346
 347 =cut