use strict;
use warnings;
+use Class::MOP::Immutable;
use Class::MOP::Instance;
use Class::MOP::Method::Wrapped;
sub is_immutable { 0 }
{
- use Class::MOP::Immutable;
-
- my $IMMUTABLE_META;
-
+ # NOTE:
+ # the immutable version of a
+ # particular metaclass is
+ # really class-level data so
+ # we don't want to regenerate
+ # it any more than we need to
+ my $IMMUTABLE_METACLASS;
sub make_immutable {
my ($self) = @_;
- $IMMUTABLE_META ||= Class::MOP::Immutable->new($self->meta, {
+ $IMMUTABLE_METACLASS ||= Class::MOP::Immutable->new($self, {
read_only => [qw/superclasses/],
cannot_call => [qw/
add_method
get_meta_instance => 'SCALAR',
get_method_map => 'SCALAR',
}
- })->create_immutable_metaclass;
-
- $IMMUTABLE_META->make_metaclass_immutable(@_);
+ });
+
+ $IMMUTABLE_METACLASS->make_metaclass_immutable(@_)
}
}
+++ /dev/null
-
-package Class::MOP::Class::Immutable;
-
-use strict;
-use warnings;
-
-use Class::MOP::Method::Constructor;
-
-use Carp 'confess';
-use Scalar::Util 'blessed';
-
-our $VERSION = '0.04';
-our $AUTHORITY = 'cpan:STEVAN';
-
-use base 'Class::MOP::Class';
-
-# enforce the meta-circularity here
-# and hide the Immutable part
-
-sub meta {
- my $self = shift;
- # if it is not blessed, then someone is asking
- # for the meta of Class::MOP::Class::Immutable
- return Class::MOP::Class->initialize($self) unless blessed($self);
- # otherwise, they are asking for the metaclass
- # which has been made immutable, which is itself
- return $self;
-}
-
-# methods which can *not* be called
-for my $meth (qw(
- add_method
- alias_method
- remove_method
- add_attribute
- remove_attribute
- add_package_symbol
- remove_package_symbol
-)) {
- no strict 'refs';
- *{$meth} = sub {
- confess "Cannot call method '$meth' on an immutable instance";
- };
-}
-
-# NOTE:
-# superclasses is an accessor, so
-# it just cannot be changed
-sub superclasses {
- my $class = shift;
- (!@_) || confess 'Cannot change the "superclasses" on an immmutable instance';
- @{$class->get_package_symbol('@ISA')};
-}
-
-# predicates
-
-sub is_mutable { 0 }
-sub is_immutable { 1 }
-
-sub make_immutable { () }
-
-sub make_metaclass_immutable {
- my ($class, $metaclass, %options) = @_;
-
- # NOTE:
- # i really need the // (defined-or) operator here
- $options{inline_accessors} = 1 unless exists $options{inline_accessors};
- $options{inline_constructor} = 1 unless exists $options{inline_constructor};
- $options{constructor_name} = 'new' unless exists $options{constructor_name};
- $options{debug} = 0 unless exists $options{debug};
-
- my $meta_instance = $metaclass->get_meta_instance;
- $metaclass->{'___class_precedence_list'} = [ $metaclass->class_precedence_list ];
- $metaclass->{'___compute_all_applicable_attributes'} = [ $metaclass->compute_all_applicable_attributes ];
- $metaclass->{'___get_meta_instance'} = $meta_instance;
- $metaclass->{'___original_class'} = blessed($metaclass);
-
- if ($options{inline_accessors}) {
- foreach my $attr_name ($metaclass->get_attribute_list) {
- # inline the accessors
- $metaclass->get_attribute($attr_name)
- ->install_accessors(1);
- }
- }
-
- if ($options{inline_constructor}) {
- my $constructor_class = $options{constructor_class} || 'Class::MOP::Method::Constructor';
- $metaclass->add_method(
- $options{constructor_name},
- $constructor_class->new(
- options => \%options,
- meta_instance => $meta_instance,
- attributes => $metaclass->{'___compute_all_applicable_attributes'}
- )
- );
- }
-
- # now cache the method map ...
- $metaclass->{'___get_method_map'} = $metaclass->get_method_map;
-
- bless $metaclass => $class;
-}
-
-# cached methods
-
-sub get_meta_instance { (shift)->{'___get_meta_instance'} }
-sub class_precedence_list { @{(shift)->{'___class_precedence_list'}} }
-sub compute_all_applicable_attributes { @{(shift)->{'___compute_all_applicable_attributes'}} }
-sub get_mutable_metaclass_name { (shift)->{'___original_class'} }
-sub get_method_map { (shift)->{'___get_method_map'} }
-
-1;
-
-__END__
-
-=pod
-
-=head1 NAME
-
-Class::MOP::Class::Immutable - An immutable version of Class::MOP::Class
-
-=head1 SYNOPSIS
-
- package Point;
- use metaclass;
-
- __PACKAGE__->meta->add_attribute('x' => (accessor => 'x', default => 10));
- __PACKAGE__->meta->add_attribute('y' => (accessor => 'y'));
-
- sub new {
- my $class = shift;
- $class->meta->new_object(@_);
- }
-
- sub clear {
- my $self = shift;
- $self->x(0);
- $self->y(0);
- }
-
- __PACKAGE__->meta->make_immutable(); # close the class
-
-=head1 DESCRIPTION
-
-Class::MOP offers many benefits to object oriented development but it
-comes at a cost. Pure Class::MOP classes can be quite a bit slower than
-the typical hand coded Perl classes. This is because just about
-I<everything> is recalculated on the fly, and nothing is cached. The
-reason this is so, is because Perl itself allows you to modify virtually
-everything at runtime. Class::MOP::Class::Immutable offers an alternative
-to this.
-
-By making your class immutable, you are promising that you will not
-modify your inheritence tree or the attributes of any classes in
-that tree. Since runtime modifications like this are fairly atypical
-(and usually recomended against), this is not usally a very hard promise
-to make. For making this promise you are given a wide range of
-optimization options which bring speed close to (and sometimes above)
-those of typical hand coded Perl.
-
-=head1 METHODS
-
-=over 4
-
-=item B<meta>
-
-This will return a B<Class::MOP::Class> instance which is related
-to this class.
-
-=back
-
-=head2 Introspection and Construction
-
-=over 4
-
-=item B<make_metaclass_immutable>
-
-The arguments to C<Class::MOP::Class::make_immutable> are passed
-to this method, which
-
-=over 4
-
-=item I<inline_accessors (Bool)>
-
-=item I<inline_constructor (Bool)>
-
-=item I<debug (Bool)>
-
-=item I<constructor_name (Str)>
-
-=back
-
-=item B<is_immutable>
-
-=item B<is_mutable>
-
-=item B<make_immutable>
-
-=item B<get_mutable_metaclass_name>
-
-=back
-
-=head2 Methods which will die if you touch them.
-
-=over 4
-
-=item B<add_attribute>
-
-=item B<add_method>
-
-=item B<add_package_symbol>
-
-=item B<alias_method>
-
-=item B<remove_attribute>
-
-=item B<remove_method>
-
-=item B<remove_package_symbol>
-
-=back
-
-=head2 Methods which work slightly differently.
-
-=over 4
-
-=item B<superclasses>
-
-This method becomes read-only in an immutable class.
-
-=back
-
-=head2 Cached methods
-
-=over 4
-
-=item B<class_precedence_list>
-
-=item B<compute_all_applicable_attributes>
-
-=item B<get_meta_instance>
-
-=item B<get_method_map>
-
-=back
-
-=head1 AUTHORS
-
-Stevan Little E<lt>stevan@iinteractive.comE<gt>
-
-Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
-
-=head1 COPYRIGHT AND LICENSE
-
-Copyright 2006 by Infinity Interactive, Inc.
-
-L<http://www.iinteractive.com>
-
-This library is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
-
-=cut
--- /dev/null
+
+package Class::MOP::Immutable;
+
+use strict;
+use warnings;
+
+use Class::MOP::Method::Constructor;
+
+use Carp 'confess';
+use Scalar::Util 'blessed';
+
+our $VERSION = '0.01';
+our $AUTHORITY = 'cpan:STEVAN';
+
+sub new {
+ my ($class, $metaclass, $options) = @_;
+
+ my $self = bless {
+ metaclass => $metaclass,
+ options => $options,
+ immutable_metaclass => undef,
+ } => $class;
+
+ # NOTE:
+ # we initialize the immutable
+ # version of the metaclass here
+ $self->create_immutable_metaclass;
+
+ return $self;
+}
+
+sub immutable_metaclass { (shift)->{immutable_metaclass} }
+sub metaclass { (shift)->{metaclass} }
+sub options { (shift)->{options} }
+
+sub create_immutable_metaclass {
+ my $self = shift;
+
+ # NOTE:
+ # The immutable version of the
+ # metaclass is just a anon-class
+ # which shadows the methods
+ # appropriately
+ $self->{immutable_metaclass} = Class::MOP::Class->create_anon_class(
+ superclasses => [ blessed($self->metaclass) ],
+ methods => $self->create_methods_for_immutable_metaclass,
+ );
+}
+
+my %DEFAULT_METHODS = (
+ meta => sub {
+ my $self = shift;
+ # if it is not blessed, then someone is asking
+ # for the meta of Class::MOP::Class::Immutable
+ return Class::MOP::Class->initialize($self) unless blessed($self);
+ # otherwise, they are asking for the metaclass
+ # which has been made immutable, which is itself
+ return $self;
+ },
+ is_mutable => sub { 0 },
+ is_immutable => sub { 1 },
+ make_immutable => sub { ( ) },
+);
+
+# NOTE:
+# this will actually convert the
+# existing metaclass to an immutable
+# version of itself
+sub make_metaclass_immutable {
+ my ($self, $metaclass, %options) = @_;
+
+ $options{inline_accessors} = 1 unless exists $options{inline_accessors};
+ $options{inline_constructor} = 1 unless exists $options{inline_constructor};
+ $options{constructor_name} = 'new' unless exists $options{constructor_name};
+ $options{debug} = 0 unless exists $options{debug};
+
+ if ($options{inline_accessors}) {
+ foreach my $attr_name ($metaclass->get_attribute_list) {
+ # inline the accessors
+ $metaclass->get_attribute($attr_name)
+ ->install_accessors(1);
+ }
+ }
+
+ if ($options{inline_constructor}) {
+ my $constructor_class = $options{constructor_class} || 'Class::MOP::Method::Constructor';
+
+ my $constructor = $constructor_class->new(
+ options => \%options,
+ meta_instance => $metaclass->get_meta_instance,
+ attributes => [ $metaclass->compute_all_applicable_attributes ]
+ );
+
+ $metaclass->add_method(
+ $options{constructor_name},
+ $constructor
+ );
+ }
+
+ my $memoized_methods = $self->options->{memoize};
+ foreach my $method_name (keys %{$memoized_methods}) {
+ my $type = $memoized_methods->{$method_name};
+
+ ($metaclass->can($method_name))
+ || confess "Could not find the method '$method_name' in " . $metaclass->name;
+
+ my $memoized_method;
+ if ($type eq 'ARRAY') {
+ $metaclass->{'___' . $method_name} = [ $metaclass->$method_name ];
+ }
+ elsif ($type eq 'HASH') {
+ $metaclass->{'___' . $method_name} = { $metaclass->$method_name };
+ }
+ elsif ($type eq 'SCALAR') {
+ $metaclass->{'___' . $method_name} = $metaclass->$method_name;
+ }
+ }
+ $metaclass->{'___original_class'} = blessed($metaclass);
+
+ bless $metaclass => $self->immutable_metaclass->name;
+}
+
+sub create_methods_for_immutable_metaclass {
+ my $self = shift;
+
+ my %methods = %DEFAULT_METHODS;
+
+ foreach my $read_only_method (@{$self->options->{read_only}}) {
+ my $method = $self->metaclass->meta->find_method_by_name($read_only_method);
+
+ (defined $method)
+ || confess "Could not find the method '$read_only_method' in " . $self->metaclass->name;
+
+ $methods{$read_only_method} = sub {
+ confess "This method is read-only" if scalar @_ > 1;
+ goto &{$method->body}
+ };
+ }
+
+ foreach my $cannot_call_method (@{$self->options->{cannot_call}}) {
+ $methods{$cannot_call_method} = sub {
+ confess "This method cannot be called on an immutable instance";
+ };
+ }
+
+ my $memoized_methods = $self->options->{memoize};
+
+ foreach my $method_name (keys %{$memoized_methods}) {
+ my $type = $memoized_methods->{$method_name};
+ if ($type eq 'ARRAY') {
+ $methods{$method_name} = sub { @{$_[0]->{'___' . $method_name}} };
+ }
+ elsif ($type eq 'HASH') {
+ $methods{$method_name} = sub { %{$_[0]->{'___' . $method_name}} };
+ }
+ elsif ($type eq 'SCALAR') {
+ $methods{$method_name} = sub { $_[0]->{'___' . $method_name} };
+ }
+ }
+
+ $methods{get_mutable_metaclass_name} = sub { (shift)->{'___original_class'} };
+
+ return \%methods;
+}
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+Class::MOP::Immutable - A class to transform Class::MOP::Class metaclasses
+
+=head1 SYNOPSIS
+
+=head1 DESCRIPTION
+
+=head1 METHODS
+
+=over 4
+
+=item B<new>
+
+=item B<options>
+
+=item B<metaclass>
+
+=item B<immutable_metaclass>
+
+=back
+
+=over 4
+
+=item B<create_immutable_metaclass>
+
+=item B<create_methods_for_immutable_metaclass>
+
+=item B<make_metaclass_immutable>
+
+=back
+
+=head1 AUTHORS
+
+Stevan Little E<lt>stevan@iinteractive.comE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2006 by Infinity Interactive, Inc.
+
+L<http://www.iinteractive.com>
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
=over 4
+=item B<associated_metaclass>
+
=item B<get_all_slots>
This will return the current list of slots based on what was
$code = eval $source;
confess "Could not eval the constructor :\n\n$source\n\nbecause :\n\n$@" if $@;
}
- $self->{body} = $code;
+ $self->{'&!body'} = $code;
}
sub _generate_slot_initializer {
use_ok('Class::MOP::Package');
use_ok('Class::MOP::Module');
use_ok('Class::MOP::Class');
- use_ok('Class::MOP::Class::Immutable');
+ use_ok('Class::MOP::Immutable');
use_ok('Class::MOP::Attribute');
use_ok('Class::MOP::Method');
use_ok('Class::MOP::Method::Wrapped');
# make sure we are tracking metaclasses correctly
+my $CLASS_MOP_CLASS_IMMUTABLE_CLASS = 'Class::MOP::Class::__ANON__::SERIAL::1';
+
my %METAS = (
'Class::MOP::Attribute' => Class::MOP::Attribute->meta,
'Class::MOP::Method::Accessor' => Class::MOP::Method::Accessor->meta,
'Class::MOP::Method' => Class::MOP::Method->meta,
'Class::MOP::Method::Wrapped' => Class::MOP::Method::Wrapped->meta,
'Class::MOP::Instance' => Class::MOP::Instance->meta,
- 'Class::MOP::Object' => Class::MOP::Object->meta,
+ 'Class::MOP::Object' => Class::MOP::Object->meta,
);
ok($_->is_immutable(), '... ' . $_->name . ' is immutable') for values %METAS;
is_deeply(
{ Class::MOP::get_all_metaclasses },
- \%METAS,
+ {
+ %METAS,
+ $CLASS_MOP_CLASS_IMMUTABLE_CLASS => $CLASS_MOP_CLASS_IMMUTABLE_CLASS->meta
+ },
'... got all the metaclasses');
is_deeply(
[
Class::MOP::Attribute->meta,
Class::MOP::Class->meta,
+ $CLASS_MOP_CLASS_IMMUTABLE_CLASS->meta,
Class::MOP::Instance->meta,
Class::MOP::Method->meta,
Class::MOP::Method::Accessor->meta,
Class::MOP::Method::Wrapped->meta,
Class::MOP::Module->meta,
Class::MOP::Object->meta,
- Class::MOP::Package->meta,
+ Class::MOP::Package->meta,
],
'... got all the metaclass instances');
is_deeply(
[ sort { $a cmp $b } Class::MOP::get_all_metaclass_names() ],
- [ qw/
+ [ sort qw/
Class::MOP::Attribute
Class::MOP::Class
Class::MOP::Instance
Class::MOP::Module
Class::MOP::Object
Class::MOP::Package
- / ],
+ /, $CLASS_MOP_CLASS_IMMUTABLE_CLASS ],
'... got all the metaclass names');
is_deeply(
[
"Class::MOP::Attribute-" . $Class::MOP::Attribute::VERSION . "-cpan:STEVAN",
"Class::MOP::Class-" . $Class::MOP::Class::VERSION . "-cpan:STEVAN",
+ $CLASS_MOP_CLASS_IMMUTABLE_CLASS,
"Class::MOP::Instance-" . $Class::MOP::Instance::VERSION . "-cpan:STEVAN",
"Class::MOP::Method-" . $Class::MOP::Method::VERSION . "-cpan:STEVAN",
"Class::MOP::Method::Accessor-" . $Class::MOP::Method::Accessor::VERSION . "-cpan:STEVAN",
ok($anon_class->has_method('foo'), '... we have a foo method now');
$instance = $anon_class->new_object();
- isa_ok($instance, $anon_class->name);
+ isa_ok($instance, $anon_class->name);
isa_ok($instance, 'Foo');
is($instance->foo, '__ANON__::foo', '... got the right return value of our foo method');
use strict;
use warnings;
-use Test::More tests => 77;
+use Test::More tests => 73;
use Test::Exception;
BEGIN {
use_ok('Class::MOP');
- use_ok('Class::MOP::Class::Immutable');
}
{
ok(!$meta->is_mutable, '... our class is no longer mutable');
ok($meta->is_immutable, '... our class is now immutable');
- isa_ok($meta, 'Class::MOP::Class::Immutable');
isa_ok($meta, 'Class::MOP::Class');
dies_ok { $meta->add_method() } '... exception thrown as expected';
ok(!$meta->is_mutable, '... our class is no longer mutable');
ok($meta->is_immutable, '... our class is now immutable');
- isa_ok($meta, 'Class::MOP::Class::Immutable');
isa_ok($meta, 'Class::MOP::Class');
dies_ok { $meta->add_method() } '... exception thrown as expected';
ok(!$meta->is_mutable, '... our class is no longer mutable');
ok($meta->is_immutable, '... our class is now immutable');
- isa_ok($meta, 'Class::MOP::Class::Immutable');
isa_ok($meta, 'Class::MOP::Class');
dies_ok { $meta->add_method() } '... exception thrown as expected';
use strict;
use warnings;
-use Test::More tests => 76;
+use Test::More tests => 73;
use Test::Exception;
BEGIN {
} '... changed Foo to be immutable';
ok($meta->is_immutable, '... our class is now immutable');
- isa_ok($meta, 'Class::MOP::Class::Immutable');
isa_ok($meta, 'Class::MOP::Class');
# they made a constructor for us :)
} '... changed Bar to be immutable';
ok($meta->is_immutable, '... our class is now immutable');
- isa_ok($meta, 'Class::MOP::Class::Immutable');
isa_ok($meta, 'Class::MOP::Class');
# they made a constructor for us :)
} '... changed Bar to be immutable';
ok($meta->is_immutable, '... our class is now immutable');
- isa_ok($meta, 'Class::MOP::Class::Immutable');
isa_ok($meta, 'Class::MOP::Class');
ok(!Baz->meta->has_method('new'), '... no constructor was made');
projects / gitmo/Class-MOP.git / commitdiff