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