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