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