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