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::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     $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 fairly new to the MOP, and quite possibly will be
 285 expanded and further generalized as the need arises.
 286
 287 =head1 METHODS
 288
 289 =over 4
 290
 291 =item B<new ($metaclass, \%options)>
 292
 293 Given a C<$metaclass> and a set of C<%options> this module will
 294 prepare an immutable version of the C<$metaclass>, which can then
 295 be applied to the C<$metaclass> using the C<make_metaclass_immutable>
 296 method.
 297
 298 =item B<options>
 299
 300 Returns the options HASH set in C<new>.
 301
 302 =item B<metaclass>
 303
 304 Returns the metaclass set in C<new>.
 305
 306 =item B<immutable_metaclass>
 307
 308 Returns the immutable metaclass created within C<new>.
 309
 310 =back
 311
 312 =over 4
 313
 314 =item B<create_immutable_metaclass>
 315
 316 This will create the immutable version of the C<$metaclass>, but will
 317 not actually change the original metaclass.
 318
 319 =item B<create_methods_for_immutable_metaclass>
 320
 321 This will create all the methods for the immutable metaclass based
 322 on the C<%options> passed into C<new>.
 323
 324 =item B<make_metaclass_immutable (%options)>
 325
 326 This will actually change the C<$metaclass> into the immutable version.
 327
 328 =item B<make_metaclass_mutable (%options)>
 329
 330 This will change the C<$metaclass> into the mutable version by reversing
 331 the immutable process. C<%options> should be the same options that were
 332 given to make_metaclass_immutable.
 333
 334 =back
 335
 336 =head1 AUTHORS
 337
 338 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 339
 340 =head1 COPYRIGHT AND LICENSE
 341
 342 Copyright 2006-2008 by Infinity Interactive, Inc.
 343
 344 L<http://www.iinteractive.com>
 345
 346 This library is free software; you can redistribute it and/or modify
 347 it under the same terms as Perl itself.
 348
 349 =cut