Class::MOP::Class::Immutable

diff --git a/bench/all.yml b/bench/all.yml
index 0a71cfa..43c6819 100644 (file)
--- 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 (file)
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 (file)
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 (file)
--- 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 (file)
--- 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<is_mutable>
+
+=item B<is_immutable>
+
+=item B<make_immutable>
+
+=back
+
 =head1 AUTHOR
 
 Stevan Little E<lt>stevan@iinteractive.comE<gt>

diff --git a/lib/Class/MOP/Class/Immutable.pm b/lib/Class/MOP/Class/Immutable.pm
new file mode 100644 (file)
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<meta>
+
+This will return a B<Class::MOP::Class> instance which is related 
+to this class.
+
+=back
+
+=over 4
+
+
+=back
+
+=head1 AUTHOR
+
+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

diff --git a/t/010_self_introspection.t b/t/010_self_introspection.t
index 09e828f..caf532a 100644 (file)
--- 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 (file)
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');
+}
+
+