From: Stevan Little Date: Wed, 28 Jun 2006 21:31:40 +0000 (+0000) Subject: Class::MOP::Class::Immutable X-Git-Tag: 0_33~30 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=857f87a765627171a17f4bc588bcdf9db4da9f09;p=gitmo%2FClass-MOP.git Class::MOP::Class::Immutable --- diff --git a/bench/all.yml b/bench/all.yml index 0a71cfa..43c6819 100644 --- a/bench/all.yml +++ b/bench/all.yml @@ -2,6 +2,7 @@ - name: Point classes classes: - 'MOP::Point' + - 'MOP::Immutable::Point' - 'Plain::Point' benchmarks: - class: 'Bench::Construct' diff --git a/bench/lib/MOP/Immutable/Point.pm b/bench/lib/MOP/Immutable/Point.pm new file mode 100644 index 0000000..0461bb8 --- /dev/null +++ b/bench/lib/MOP/Immutable/Point.pm @@ -0,0 +1,26 @@ + +package MOP::Immutable::Point; + +use strict; +use warnings; +use metaclass; + +__PACKAGE__->meta->add_attribute('x' => (accessor => 'x')); +__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; + +1; + +__END__ \ No newline at end of file diff --git a/bench/lib/MOP/Immutable/Point3D.pm b/bench/lib/MOP/Immutable/Point3D.pm new file mode 100644 index 0000000..5c9f9fb --- /dev/null +++ b/bench/lib/MOP/Immutable/Point3D.pm @@ -0,0 +1,22 @@ + +package MOP::Immutable::Point3D; + +use strict; +use warnings; +use metaclass; + +use base 'MOP::Point'; + +__PACKAGE__->meta->add_attribute('z' => (accessor => 'z')); + +sub clear { + my $self = shift; + $self->SUPER::clear(); + $self->z(0); +} + +__PACKAGE__->meta->make_immutable; + +1; + +__END__ \ No newline at end of file diff --git a/lib/Class/MOP.pm b/lib/Class/MOP.pm index 2475d39..d55df90 100644 --- a/lib/Class/MOP.pm +++ b/lib/Class/MOP.pm @@ -11,6 +11,8 @@ use Class::MOP::Class; use Class::MOP::Attribute; use Class::MOP::Method; +use Class::MOP::Class::Immutable; + our $VERSION = '0.29_02'; ## ---------------------------------------------------------------------------- diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm index b546b82..1782718 100644 --- a/lib/Class/MOP/Class.pm +++ b/lib/Class/MOP/Class.pm @@ -96,7 +96,7 @@ sub meta { Class::MOP::Class->initialize(blessed($_[0]) || $_[0]) } '%:attributes' => {}, '$:attribute_metaclass' => $options{':attribute_metaclass'} || 'Class::MOP::Attribute', '$:method_metaclass' => $options{':method_metaclass'} || 'Class::MOP::Method', - '$:instance_metaclass' => $options{':instance_metaclass'} || 'Class::MOP::Instance', + '$:instance_metaclass' => $options{':instance_metaclass'} || 'Class::MOP::Instance', } => $class; } else { @@ -688,6 +688,16 @@ sub remove_package_variable { delete ${$self->name . '::'}{$name}; } +## Class closing + +sub is_mutable { 1 } +sub is_immutable { 0 } + +sub make_immutable { + my ($class) = @_; + return Class::MOP::Class::Immutable->make_metaclass_immutable($class); +} + 1; __END__ @@ -1252,6 +1262,18 @@ This will attempt to remove the package variable at C<$variable_name>. =back +=head2 Class closing + +=over 4 + +=item B + +=item B + +=item B + +=back + =head1 AUTHOR Stevan Little Estevan@iinteractive.comE diff --git a/lib/Class/MOP/Class/Immutable.pm b/lib/Class/MOP/Class/Immutable.pm new file mode 100644 index 0000000..346e120 --- /dev/null +++ b/lib/Class/MOP/Class/Immutable.pm @@ -0,0 +1,109 @@ + +package Class::MOP::Class::Immutable; + +use strict; +use warnings; + +use Carp 'confess'; +use Scalar::Util 'blessed'; + +our $VERSION = '0.01'; + +use base 'Class::MOP::Class'; + +# methods which can *not* be called + +sub reinitialize { confess 'Cannot call method "reinitialize" on an immutable instance' } + +sub add_method { confess 'Cannot call method "add_method" on an immutable instance' } +sub alias_method { confess 'Cannot call method "alias_method" on an immutable instance' } +sub remove_method { confess 'Cannot call method "remove_method" on an immutable instance' } + +sub add_attribute { confess 'Cannot call method "add_attribute" on an immutable instance' } +sub remove_attribute { confess 'Cannot call method "remove_attribute" on an immutable instance' } + +sub add_package_variable { confess 'Cannot call method "add_package_variable" on an immutable instance' } +sub remove_package_variable { confess 'Cannot call method "remove_package_variable" 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'; + no strict 'refs'; + @{$class->name . '::ISA'}; +} + +# predicates + +sub is_mutable { 0 } +sub is_immutable { 1 } + +sub make_immutable { () } + +sub make_metaclass_immutable { + my ($class, $metaclass) = @_; + $metaclass->{'___class_precedence_list'} = [ $metaclass->class_precedence_list ]; + $metaclass->{'___get_meta_instance'} = $metaclass->get_meta_instance; + $metaclass->{'___compute_all_applicable_attributes'} = [ $metaclass->compute_all_applicable_attributes ]; + $metaclass->{'___original_class'} = blessed($metaclass); + 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'} } +} + +1; + +__END__ + +=pod + +=head1 NAME + +Class::MOP::Class::Immutable - An immutable version of Class::MOP::Class + +=head1 SYNOPSIS + +=head1 DESCRIPTION + +=head1 METHODS + +=over 4 + +=item B + +This will return a B instance which is related +to this class. + +=back + +=over 4 + + +=back + +=head1 AUTHOR + +Stevan Little Estevan@iinteractive.comE + +=head1 COPYRIGHT AND LICENSE + +Copyright 2006 by Infinity Interactive, Inc. + +L + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut diff --git a/t/010_self_introspection.t b/t/010_self_introspection.t index 09e828f..caf532a 100644 --- a/t/010_self_introspection.t +++ b/t/010_self_introspection.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 146; +use Test::More tests => 152; use Test::Exception; BEGIN { @@ -48,6 +48,8 @@ my @methods = qw( add_package_variable get_package_variable has_package_variable remove_package_variable + is_mutable is_immutable make_immutable + DESTROY ); diff --git a/t/070_immutable_metaclass.t b/t/070_immutable_metaclass.t new file mode 100644 index 0000000..17407c9 --- /dev/null +++ b/t/070_immutable_metaclass.t @@ -0,0 +1,236 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 80; +use Test::Exception; + +BEGIN { + use_ok('Class::MOP'); + use_ok('Class::MOP::Class::Immutable'); +} + +{ + package Foo; + + use strict; + use warnings; + use metaclass; + + __PACKAGE__->meta->add_attribute('bar'); + + package Bar; + + use strict; + use warnings; + use metaclass; + + __PACKAGE__->meta->superclasses('Foo'); + + __PACKAGE__->meta->add_attribute('baz'); + + package Baz; + + use strict; + use warnings; + use metaclass; + + __PACKAGE__->meta->superclasses('Bar'); + + __PACKAGE__->meta->add_attribute('bah'); +} + +{ + my $meta = Foo->meta; + is($meta->name, 'Foo', '... checking the Foo metaclass'); + + ok($meta->is_mutable, '... our class is mutable'); + ok(!$meta->is_immutable, '... our class is not immutable'); + + lives_ok { + $meta->make_immutable(); + } '... changed Foo to be immutable'; + + ok(!$meta->make_immutable, '... make immutable now returns nothing'); + + 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->reinitialize() } '... exception thrown as expected'; + + dies_ok { $meta->add_method() } '... exception thrown as expected'; + dies_ok { $meta->alias_method() } '... exception thrown as expected'; + dies_ok { $meta->remove_method() } '... exception thrown as expected'; + + dies_ok { $meta->add_attribute() } '... exception thrown as expected'; + dies_ok { $meta->remove_attribute() } '... exception thrown as expected'; + + dies_ok { $meta->add_package_variable() } '... exception thrown as expected'; + dies_ok { $meta->remove_package_variable() } '... exception thrown as expected'; + + my @supers; + lives_ok { + @supers = $meta->superclasses; + } '... got the superclasses okay'; + + dies_ok { $meta->superclasses([ 'UNIVERSAL' ]) } '... but could not set the superclasses okay'; + + my $meta_instance; + lives_ok { + $meta_instance = $meta->get_meta_instance; + } '... got the meta instance okay'; + isa_ok($meta_instance, 'Class::MOP::Instance'); + is($meta_instance, $meta->get_meta_instance, '... and we know it is cached'); + + my @cpl; + lives_ok { + @cpl = $meta->class_precedence_list; + } '... got the class precedence list okay'; + is_deeply( + \@cpl, + [ 'Foo' ], + '... we just have ourselves in the class precedence list'); + + my @attributes; + lives_ok { + @attributes = $meta->compute_all_applicable_attributes; + } '... got the attribute list okay'; + is_deeply( + \@attributes, + [ $meta->get_attribute('bar') ], + '... got the right list of attributes'); +} + +{ + my $meta = Bar->meta; + is($meta->name, 'Bar', '... checking the Bar metaclass'); + + ok($meta->is_mutable, '... our class is mutable'); + ok(!$meta->is_immutable, '... our class is not immutable'); + + lives_ok { + $meta->make_immutable(); + } '... changed Bar to be immutable'; + + ok(!$meta->make_immutable, '... make immutable now returns nothing'); + + 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->reinitialize() } '... exception thrown as expected'; + + dies_ok { $meta->add_method() } '... exception thrown as expected'; + dies_ok { $meta->alias_method() } '... exception thrown as expected'; + dies_ok { $meta->remove_method() } '... exception thrown as expected'; + + dies_ok { $meta->add_attribute() } '... exception thrown as expected'; + dies_ok { $meta->remove_attribute() } '... exception thrown as expected'; + + dies_ok { $meta->add_package_variable() } '... exception thrown as expected'; + dies_ok { $meta->remove_package_variable() } '... exception thrown as expected'; + + my @supers; + lives_ok { + @supers = $meta->superclasses; + } '... got the superclasses okay'; + + dies_ok { $meta->superclasses([ 'UNIVERSAL' ]) } '... but could not set the superclasses okay'; + + my $meta_instance; + lives_ok { + $meta_instance = $meta->get_meta_instance; + } '... got the meta instance okay'; + isa_ok($meta_instance, 'Class::MOP::Instance'); + is($meta_instance, $meta->get_meta_instance, '... and we know it is cached'); + + my @cpl; + lives_ok { + @cpl = $meta->class_precedence_list; + } '... got the class precedence list okay'; + is_deeply( + \@cpl, + [ 'Bar', 'Foo'], + '... we just have ourselves in the class precedence list'); + + my @attributes; + lives_ok { + @attributes = $meta->compute_all_applicable_attributes; + } '... got the attribute list okay'; + is_deeply( + [ sort { $a->name cmp $b->name } @attributes ], + [ Foo->meta->get_attribute('bar'), $meta->get_attribute('baz') ], + '... got the right list of attributes'); +} + +{ + my $meta = Baz->meta; + is($meta->name, 'Baz', '... checking the Baz metaclass'); + + ok($meta->is_mutable, '... our class is mutable'); + ok(!$meta->is_immutable, '... our class is not immutable'); + + lives_ok { + $meta->make_immutable(); + } '... changed Baz to be immutable'; + + ok(!$meta->make_immutable, '... make immutable now returns nothing'); + + 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->reinitialize() } '... exception thrown as expected'; + + dies_ok { $meta->add_method() } '... exception thrown as expected'; + dies_ok { $meta->alias_method() } '... exception thrown as expected'; + dies_ok { $meta->remove_method() } '... exception thrown as expected'; + + dies_ok { $meta->add_attribute() } '... exception thrown as expected'; + dies_ok { $meta->remove_attribute() } '... exception thrown as expected'; + + dies_ok { $meta->add_package_variable() } '... exception thrown as expected'; + dies_ok { $meta->remove_package_variable() } '... exception thrown as expected'; + + my @supers; + lives_ok { + @supers = $meta->superclasses; + } '... got the superclasses okay'; + + dies_ok { $meta->superclasses([ 'UNIVERSAL' ]) } '... but could not set the superclasses okay'; + + my $meta_instance; + lives_ok { + $meta_instance = $meta->get_meta_instance; + } '... got the meta instance okay'; + isa_ok($meta_instance, 'Class::MOP::Instance'); + is($meta_instance, $meta->get_meta_instance, '... and we know it is cached'); + + my @cpl; + lives_ok { + @cpl = $meta->class_precedence_list; + } '... got the class precedence list okay'; + is_deeply( + \@cpl, + [ 'Baz', 'Bar', 'Foo'], + '... we just have ourselves in the class precedence list'); + + my @attributes; + lives_ok { + @attributes = $meta->compute_all_applicable_attributes; + } '... got the attribute list okay'; + is_deeply( + [ sort { $a->name cmp $b->name } @attributes ], + [ $meta->get_attribute('bah'), Foo->meta->get_attribute('bar'), Bar->meta->get_attribute('baz') ], + '... got the right list of attributes'); +} + +