lib/Class/MOP/Class/Immutable.pm

   1
   2 package Class::MOP::Class::Immutable;
   3
   4 use strict;
   5 use warnings;
   6
   7 use Carp         'confess';
   8 use Scalar::Util 'blessed', 'looks_like_number';
   9
  10 our $VERSION   = '0.03';
  11 our $AUTHORITY = 'cpan:STEVAN';
  12
  13 use base 'Class::MOP::Class';
  14
  15 # methods which can *not* be called
  16 for my $meth (qw(
  17     add_method
  18     alias_method
  19     remove_method
  20     add_attribute
  21     remove_attribute
  22     add_package_symbol
  23     remove_package_symbol
  24 )) {
  25     no strict 'refs';
  26     *{$meth} = sub {
  27         confess "Cannot call method '$meth' on an immutable instance";
  28     };
  29 }
  30
  31 sub get_package_symbol {
  32     my ($self, $variable) = @_;
  33     my ($name, $sigil, $type) = $self->_deconstruct_variable_name($variable);
  34     return *{$self->namespace->{$name}}{$type}
  35         if exists $self->namespace->{$name};
  36     # NOTE:
  37     # we have to do this here in order to preserve
  38     # perl's autovivification of variables. However
  39     # we do cut off direct access to add_package_symbol
  40     # as shown above.
  41     $self->Class::MOP::Package::add_package_symbol($variable);
  42 }
  43
  44 # NOTE:
  45 # superclasses is an accessor, so
  46 # it just cannot be changed
  47 sub superclasses {
  48     my $class = shift;
  49     (!@_) || confess 'Cannot change the "superclasses" on an immmutable instance';
  50     @{$class->get_package_symbol('@ISA')};
  51 }
  52
  53 # predicates
  54
  55 sub is_mutable   { 0 }
  56 sub is_immutable { 1 }
  57
  58 sub make_immutable { () }
  59
  60 sub make_metaclass_immutable {
  61     my ($class, $metaclass, %options) = @_;
  62
  63     # NOTE:
  64     # i really need the // (defined-or) operator here
  65     $options{inline_accessors}   = 1     unless exists $options{inline_accessors};
  66     $options{inline_constructor} = 1     unless exists $options{inline_constructor};
  67     $options{constructor_name}   = 'new' unless exists $options{constructor_name};
  68     $options{debug}              = 0     unless exists $options{debug};
  69
  70     my $meta_instance = $metaclass->get_meta_instance;
  71     $metaclass->{'___class_precedence_list'}             = [ $metaclass->class_precedence_list ];
  72     $metaclass->{'___compute_all_applicable_attributes'} = [ $metaclass->compute_all_applicable_attributes ];
  73     $metaclass->{'___get_meta_instance'}                 = $meta_instance;
  74     $metaclass->{'___original_class'}                    = blessed($metaclass);
  75
  76     if ($options{inline_accessors}) {
  77         foreach my $attr_name ($metaclass->get_attribute_list) {
  78             my $attr = $metaclass->get_attribute($attr_name);
  79             $attr->install_accessors(1); # inline the accessors
  80         }
  81     }
  82
  83     if ($options{inline_constructor}) {
  84         $metaclass->add_method(
  85             $options{constructor_name},
  86             $class->_generate_inline_constructor(
  87                 \%options,
  88                 $meta_instance,
  89                 $metaclass->{'___compute_all_applicable_attributes'}
  90             )
  91         );
  92     }
  93
  94     # now cache the method map ...
  95     $metaclass->{'___method_map'} = $metaclass->get_method_map;
  96
  97     bless $metaclass => $class;
  98 }
  99
 100 sub _generate_inline_constructor {
 101     my ($class, $options, $meta_instance, $attrs) = @_;
 102     # TODO:
 103     # the %options should also include a both
 104     # a call 'initializer' and call 'SUPER::'
 105     # options, which should cover approx 90%
 106     # of the possible use cases (even if it
 107     # requires some adaption on the part of
 108     # the author, after all, nothing is free)
 109     my $source = 'sub {';
 110     $source .= "\n" . 'my ($class, %params) = @_;';
 111     $source .= "\n" . 'my $instance = ' . $meta_instance->inline_create_instance('$class');
 112     $source .= ";\n" . (join ";\n" => map {
 113         $class->_generate_slot_initializer($meta_instance, $attrs, $_)
 114     } 0 .. (@$attrs - 1));
 115     $source .= ";\n" . 'return $instance';
 116     $source .= ";\n" . '}';
 117     warn $source if $options->{debug};
 118     my $code = eval $source;
 119     confess "Could not eval the constructor :\n\n$source\n\nbecause :\n\n$@" if $@;
 120     return $code;
 121 }
 122
 123 sub _generate_slot_initializer {
 124     my ($class, $meta_instance, $attrs, $index) = @_;
 125     my $attr = $attrs->[$index];
 126     my $default;
 127     if ($attr->has_default) {
 128         # NOTE:
 129         # default values can either be CODE refs
 130         # in which case we need to call them. Or
 131         # they can be scalars (strings/numbers)
 132         # in which case we can just deal with them
 133         # in the code we eval.
 134         if ($attr->is_default_a_coderef) {
 135             $default = '$attrs->[' . $index . ']->default($instance)';
 136         }
 137         else {
 138             $default = $attrs->[$index]->default;
 139             # make sure to quote strings ...
 140             unless (looks_like_number($default)) {
 141                 $default = "'$default'";
 142             }
 143         }
 144     }
 145     $meta_instance->inline_set_slot_value(
 146         '$instance',
 147         ("'" . $attr->name . "'"),
 148         ('$params{\'' . $attr->init_arg . '\'}' . (defined $default ? (' || ' . $default) : ''))
 149     )
 150 }
 151
 152 # cached methods
 153
 154 sub get_meta_instance                 {   (shift)->{'___get_meta_instance'}                  }
 155 sub class_precedence_list             { @{(shift)->{'___class_precedence_list'}}             }
 156 sub compute_all_applicable_attributes { @{(shift)->{'___compute_all_applicable_attributes'}} }
 157 sub get_mutable_metaclass_name        {   (shift)->{'___original_class'}                     }
 158 sub get_method_map                    {   (shift)->{'___method_map'}                         }
 159
 160 1;
 161
 162 __END__
 163
 164 =pod
 165
 166 =head1 NAME
 167
 168 Class::MOP::Class::Immutable - An immutable version of Class::MOP::Class
 169
 170 =head1 SYNOPSIS
 171
 172   package Point;
 173   use metaclass;
 174
 175   __PACKAGE__->meta->add_attribute('x' => (accessor => 'x', default => 10));
 176   __PACKAGE__->meta->add_attribute('y' => (accessor => 'y'));
 177
 178   sub new {
 179       my $class = shift;
 180       $class->meta->new_object(@_);
 181   }
 182
 183   sub clear {
 184       my $self = shift;
 185       $self->x(0);
 186       $self->y(0);
 187   }
 188
 189   __PACKAGE__->meta->make_immutable();  # close the class
 190
 191 =head1 DESCRIPTION
 192
 193 Class::MOP offers many benefits to object oriented development but it
 194 comes at a cost. Pure Class::MOP classes can be quite a bit slower than
 195 the typical hand coded Perl classes. This is because just about
 196 I<everything> is recalculated on the fly, and nothing is cached. The
 197 reason this is so, is because Perl itself allows you to modify virtually
 198 everything at runtime. Class::MOP::Class::Immutable offers an alternative
 199 to this.
 200
 201 By making your class immutable, you are promising that you will not
 202 modify your inheritence tree or the attributes of any classes in
 203 that tree. Since runtime modifications like this are fairly atypical
 204 (and usually recomended against), this is not usally a very hard promise
 205 to make. For making this promise you are given a wide range of
 206 optimization options which bring speed close to (and sometimes above)
 207 those of typical hand coded Perl.
 208
 209 =head1 METHODS
 210
 211 =over 4
 212
 213 =item B<meta>
 214
 215 This will return a B<Class::MOP::Class> instance which is related
 216 to this class.
 217
 218 =back
 219
 220 =head2 Introspection and Construction
 221
 222 =over 4
 223
 224 =item B<make_metaclass_immutable>
 225
 226 The arguments to C<Class::MOP::Class::make_immutable> are passed
 227 to this method, which
 228
 229 =over 4
 230
 231 =item I<inline_accessors (Bool)>
 232
 233 =item I<inline_constructor (Bool)>
 234
 235 =item I<debug (Bool)>
 236
 237 =item I<constructor_name (Str)>
 238
 239 =back
 240
 241 =item B<is_immutable>
 242
 243 =item B<is_mutable>
 244
 245 =item B<make_immutable>
 246
 247 =item B<get_mutable_metaclass_name>
 248
 249 =back
 250
 251 =head2 Methods which will die if you touch them.
 252
 253 =over 4
 254
 255 =item B<add_attribute>
 256
 257 =item B<add_method>
 258
 259 =item B<add_package_symbol>
 260
 261 =item B<alias_method>
 262
 263 =item B<remove_attribute>
 264
 265 =item B<remove_method>
 266
 267 =item B<remove_package_symbol>
 268
 269 =back
 270
 271 =head2 Methods which work slightly differently.
 272
 273 =over 4
 274
 275 =item B<superclasses>
 276
 277 This method becomes read-only in an immutable class.
 278
 279 =item B<get_package_symbol>
 280
 281 This method must handle package variable autovivification
 282 correctly, while still disallowing C<add_package_symbol>.
 283
 284 =back
 285
 286 =head2 Cached methods
 287
 288 =over 4
 289
 290 =item B<class_precedence_list>
 291
 292 =item B<compute_all_applicable_attributes>
 293
 294 =item B<get_meta_instance>
 295
 296 =item B<get_method_map>
 297
 298 =back
 299
 300 =head1 AUTHORS
 301
 302 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 303
 304 Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
 305
 306 =head1 COPYRIGHT AND LICENSE
 307
 308 Copyright 2006 by Infinity Interactive, Inc.
 309
 310 L<http://www.iinteractive.com>
 311
 312 This library is free software; you can redistribute it and/or modify
 313 it under the same terms as Perl itself.
 314
 315 =cut