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