From: Dave Rolsky Date: Tue, 30 Jun 2009 19:45:35 +0000 (-0500) Subject: almost all tests passing! X-Git-Tag: 0.89~13 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=78f6e9c6a73ff3dd985a1cebaafd0b81e543beb8;p=gitmo%2FClass-MOP.git almost all tests passing! --- diff --git a/lib/Class/MOP.pm b/lib/Class/MOP.pm index 7884594..23232d2 100644 --- a/lib/Class/MOP.pm +++ b/lib/Class/MOP.pm @@ -690,10 +690,6 @@ undef Class::MOP::Instance->meta->{_package_cache_flag}; # NOTE: we don't need to inline the the accessors this only lengthens # the compile time of the MOP, and gives us no actual benefits. -# this is just nitpicking to ensure Class::MOP::Class->meta == ->meta->meta -Class::MOP::Class->meta->_immutable_metaclass; -$Class::MOP::Class::immutable_metaclass_cache{"Class::MOP::Class"}{"Class::MOP::Class::Immutable::Trait"} = Class::MOP::Class::Immutable::Class::MOP::Class->meta; - $_->meta->make_immutable( inline_constructor => 1, replace_constructor => 1, @@ -703,7 +699,6 @@ $_->meta->make_immutable( Class::MOP::Package Class::MOP::Module Class::MOP::Class - Class::MOP::Class::Immutable::Class::MOP::Class Class::MOP::Attribute Class::MOP::Method diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm index 1214e45..52cd74c 100644 --- a/lib/Class/MOP/Class.pm +++ b/lib/Class/MOP/Class.pm @@ -8,7 +8,6 @@ use Class::MOP::Instance; use Class::MOP::Method::Wrapped; use Class::MOP::Method::Accessor; use Class::MOP::Method::Constructor; -use Class::MOP::Class::Immutable::Class::MOP::Class; use Carp 'confess'; use Scalar::Util 'blessed', 'weaken'; @@ -181,6 +180,8 @@ sub _check_metaclass_compatibility { return if ref($self) eq 'Class::MOP::Class' && $self->instance_metaclass eq 'Class::MOP::Instance'; + return if $self->can('get_mutable_metaclass_name'); + my @class_list = $self->linearized_isa; shift @class_list; # shift off $self->name @@ -1094,23 +1095,27 @@ sub _immutable_metaclass { $trait, 'ForMetaClass', ref($self); } - if ( Class::MOP::is_class_loaded($class_name) ) { - if ( $class_name->isa($trait) ) { - return $class_name; + return $class_name + if Class::MOP::is_class_loaded($class_name); + + my $meta = Class::MOP::Class->create( + $class_name, + superclasses => [ ref $self ], + ); + + Class::MOP::load_class($trait); + for my $meth ( Class::MOP::Class->initialize($trait)->get_all_methods ) { + next if $meta->has_method( $meth->name ); + + if ( $meta->find_method_by_name( $meth->name ) ) { + $meta->add_around_method_modifier( $meth->name, $meth->body ); } else { - confess - "$class_name is already defined but does not inherit $trait"; + $meta->add_method( $meth->name, $meth->clone ); } } - else { - my @super = ( $trait, ref($self) ); - my $meta = $self->initialize($class_name); - $meta->superclasses(@super); - - return $class_name; - } + return $class_name; } sub _remove_inlined_code { diff --git a/lib/Class/MOP/Class/Immutable/Class/MOP/Class.pm b/lib/Class/MOP/Class/Immutable/Class/MOP/Class.pm deleted file mode 100644 index 3eb7be3..0000000 --- a/lib/Class/MOP/Class/Immutable/Class/MOP/Class.pm +++ /dev/null @@ -1,41 +0,0 @@ -package Class::MOP::Class::Immutable::Class::MOP::Class; - -use strict; -use warnings; - -our $VERSION = '0.88'; -$VERSION = eval $VERSION; -our $AUTHORITY = 'cpan:STEVAN'; - -use base qw(Class::MOP::Class::Immutable::Trait Class::MOP::Class); - -1; - -__END__ - -=pod - -=head1 NAME - -Class::MOP::Class::Immutable::Class::MOP::Class - An immutable subclass of Class::MOP::Class - -=head1 DESCRIPTION - -This is an empty class which inherits from -L and L. - -=head1 AUTHOR - -Yuval Kogman Enothingmuch@cpan.orgE - -=head1 COPYRIGHT AND LICENSE - -Copyright 2009 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/lib/Class/MOP/Class/Immutable/Trait.pm b/lib/Class/MOP/Class/Immutable/Trait.pm index fc7af69..0c8a505 100644 --- a/lib/Class/MOP/Class/Immutable/Trait.pm +++ b/lib/Class/MOP/Class/Immutable/Trait.pm @@ -17,59 +17,77 @@ sub get_mutable_metaclass_name { $_[0]{__immutable}{original_class} } sub immutable_options { %{ $_[0]{__immutable}{options} } } -sub is_mutable {0} -sub is_immutable {1} +sub is_mutable { 0 } +sub is_immutable { 1 } sub superclasses { - confess "This method is read-only" if @_ > 1; - $_[0]->next::method; + my $orig = shift; + my $self = shift; + confess "This method is read-only" if @_; + $self->$orig; } sub _immutable_cannot_call { Carp::confess "This method cannot be called on an immutable instance"; } -sub add_method { shift->_immutable_cannot_call } -sub alias_method { shift->_immutable_cannot_call } -sub remove_method { shift->_immutable_cannot_call } -sub add_attribute { shift->_immutable_cannot_call } -sub remove_attribute { shift->_immutable_cannot_call } -sub remove_package_symbol { shift->_immutable_cannot_call } +sub add_method { _immutable_cannot_call() } +sub alias_method { _immutable_cannot_call() } +sub remove_method { _immutable_cannot_call() } +sub add_attribute { _immutable_cannot_call() } +sub remove_attribute { _immutable_cannot_call() } +sub remove_package_symbol { _immutable_cannot_call() } sub class_precedence_list { - @{ $_[0]{__immutable}{class_precedence_list} - ||= [ shift->next::method ] }; + my $orig = shift; + my $self = shift; + @{ $self->{__immutable}{class_precedence_list} + ||= [ $self->$orig ] }; } sub linearized_isa { - @{ $_[0]{__immutable}{linearized_isa} ||= [ shift->next::method ] }; + my $orig = shift; + my $self = shift; + @{ $self->{__immutable}{linearized_isa} ||= [ $self->$orig ] }; } sub get_all_methods { - @{ $_[0]{__immutable}{get_all_methods} ||= [ shift->next::method ] }; + my $orig = shift; + my $self = shift; + @{ $self->{__immutable}{get_all_methods} ||= [ $self->$orig ] }; } sub get_all_method_names { - @{ $_[0]{__immutable}{get_all_method_names} ||= [ shift->next::method ] }; + my $orig = shift; + my $self = shift; + @{ $self->{__immutable}{get_all_method_names} ||= [ $self->$orig ] }; } sub get_all_attributes { - @{ $_[0]{__immutable}{get_all_attributes} ||= [ shift->next::method ] }; + my $orig = shift; + my $self = shift; + @{ $self->{__immutable}{get_all_attributes} ||= [ $self->$orig ] }; } sub get_meta_instance { - $_[0]{__immutable}{get_meta_instance} ||= shift->next::method; + my $orig = shift; + my $self = shift; + $self->{__immutable}{get_meta_instance} ||= $self->$orig; } sub get_method_map { - $_[0]{__immutable}{get_method_map} ||= shift->next::method; + my $orig = shift; + my $self = shift; + $self->{__immutable}{get_method_map} ||= $self->$orig; } sub add_package_symbol { + my $orig = shift; + my $self = shift; confess "Cannot add package symbols to an immutable metaclass" - unless ( caller(1) )[3] eq 'Class::MOP::Package::get_package_symbol'; + unless ( caller(3) )[3] eq 'Class::MOP::Package::get_package_symbol'; - shift->next::method(@_); + $self->$orig(@_); } 1; diff --git a/t/070_immutable_metaclass.t b/t/070_immutable_metaclass.t index d7b1c4d..8d57f5d 100644 --- a/t/070_immutable_metaclass.t +++ b/t/070_immutable_metaclass.t @@ -1,7 +1,7 @@ use strict; use warnings; -use Test::More tests => 75; +use Test::More tests => 73; use Test::Exception; use Class::MOP; @@ -51,9 +51,7 @@ use Class::MOP; is( $immutable_class_name->meta, $immutable_metaclass, '... immutable_metaclass meta hack works' ); - isa_ok( $meta, "Class::MOP::Class::Immutable::Trait" ); isa_ok( $meta, "Class::MOP::Class" ); - } {