lib/Class/MOP/Class/Immutable.pm

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