X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FClass%2FMOP%2FClass.pm;h=b3b6b97b0bfcf86d2b4d1c2e04d7fbd7dca56c1f;hb=7d1a576bad6260090ba0d40950f861227ead48a8;hp=325c913590d11e8f2273acb881f78d0326ccc878;hpb=b74f98bec65307feced9de906140546c4dbc31d8;p=gitmo%2FClass-MOP.git diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm index 325c913..b3b6b97 100644 --- a/lib/Class/MOP/Class.pm +++ b/lib/Class/MOP/Class.pm @@ -8,6 +8,7 @@ use Class::MOP::Instance; use Class::MOP::Method::Wrapped; use Class::MOP::Method::Accessor; use Class::MOP::Method::Constructor; +use Class::MOP::MiniTrait; use Carp 'confess'; use Scalar::Util 'blessed', 'reftype', 'weaken'; @@ -16,7 +17,7 @@ use Devel::GlobalDestruction 'in_global_destruction'; use Try::Tiny; use List::MoreUtils 'all'; -our $VERSION = '1.01'; +our $VERSION = '1.08'; $VERSION = eval $VERSION; our $AUTHORITY = 'cpan:STEVAN'; @@ -190,29 +191,31 @@ sub update_package_cache_flag { sub _check_metaclass_compatibility { my $self = shift; - if (my @superclasses = $self->superclasses) { - $self->_fix_metaclass_incompatibility(@superclasses); + my @superclasses = $self->superclasses + or return; + + $self->_fix_metaclass_incompatibility(@superclasses); - my %base_metaclass = $self->_base_metaclasses; + my %base_metaclass = $self->_base_metaclasses; - # this is always okay ... - return if ref($self) eq 'Class::MOP::Class' + # this is always okay ... + return + if ref($self) eq 'Class::MOP::Class' && all { my $meta = $self->$_; - !defined($meta) || $meta eq $base_metaclass{$_} - } keys %base_metaclass; - - for my $superclass (@superclasses) { - $self->_check_class_metaclass_compatibility($superclass); + !defined($meta) || $meta eq $base_metaclass{$_}; } + keys %base_metaclass; - for my $metaclass_type (keys %base_metaclass) { - next unless defined $self->$metaclass_type; - for my $superclass (@superclasses) { - $self->_check_single_metaclass_compatibility( - $metaclass_type, $superclass - ); - } + for my $superclass (@superclasses) { + $self->_check_class_metaclass_compatibility($superclass); + } + + for my $metaclass_type ( keys %base_metaclass ) { + next unless defined $self->$metaclass_type; + for my $superclass (@superclasses) { + $self->_check_single_metaclass_compatibility( $metaclass_type, + $superclass ); } } } @@ -257,8 +260,10 @@ sub _single_metaclass_is_compatible { return 1 unless $super_meta->can($metaclass_type); # for instance, Moose::Meta::Class has a destructor_class, but # Class::MOP::Class doesn't - this shouldn't be an error - return 1 if defined $self->$metaclass_type - && !defined $super_meta->$metaclass_type; + return 1 unless defined $super_meta->$metaclass_type; + # if metaclass is defined in superclass but not here, it's not compatible + # this is a really odd case + return 0 unless defined $self->$metaclass_type; return $self->$metaclass_type->isa($super_meta->$metaclass_type); } @@ -276,7 +281,7 @@ sub _check_single_metaclass_compatibility { . $self->name . " (" . ($self->$metaclass_type) . ")" . " is not compatible with the " . "$metaclass_type_name metaclass of its " - . "superclass, " . $superclass_name . " (" + . "superclass, $superclass_name (" . ($super_meta->$metaclass_type) . ")"; } } @@ -301,8 +306,11 @@ sub _can_fix_single_metaclass_incompatibility_by_subclassing { # for instance, Moose::Meta::Class has a destructor_class, but # Class::MOP::Class doesn't - this shouldn't be an error - return if defined $specific_meta - && !defined $super_specific_meta; + return unless defined $super_specific_meta; + + # if metaclass is defined in superclass but not here, it's fixable + # this is a really odd case + return 1 unless defined $specific_meta; return $specific_meta ne $super_specific_meta && $super_specific_meta->isa($specific_meta); @@ -316,7 +324,6 @@ sub _can_fix_metaclass_incompatibility_by_subclassing { my %base_metaclass = $self->_base_metaclasses; for my $metaclass_type (keys %base_metaclass) { - next unless defined $self->$metaclass_type; return 1 if $self->_can_fix_single_metaclass_incompatibility_by_subclassing($metaclass_type, $super_meta); } @@ -330,16 +337,16 @@ sub _can_fix_metaclass_incompatibility { sub _fix_metaclass_incompatibility { my $self = shift; - my @supers = @_; + my @supers = map { Class::MOP::Class->initialize($_) } @_; my $necessary = 0; - for my $super (map { Class::MOP::Class->initialize($_) } @supers) { + for my $super (@supers) { $necessary = 1 if $self->_can_fix_metaclass_incompatibility($super); } return unless $necessary; - for my $super (map { Class::MOP::Class->initialize($_) } @supers) { + for my $super (@supers) { if (!$self->_class_metaclass_is_compatible($super->name)) { $self->_fix_class_metaclass_incompatibility($super); } @@ -347,8 +354,7 @@ sub _fix_metaclass_incompatibility { my %base_metaclass = $self->_base_metaclasses; for my $metaclass_type (keys %base_metaclass) { - next unless defined $self->$metaclass_type; - for my $super (map { Class::MOP::Class->initialize($_) } @supers) { + for my $super (@supers) { if (!$self->_single_metaclass_is_compatible($metaclass_type, $super->name)) { $self->_fix_single_metaclass_incompatibility( $metaclass_type, $super @@ -478,6 +484,7 @@ sub create { superclasses attributes methods + no_meta version authority )}; @@ -487,8 +494,16 @@ sub create { # FIXME totally lame $meta->add_method('meta' => sub { + if (Class::MOP::DEBUG_NO_META()) { + my ($self) = @_; + if (my $meta = try { $self->SUPER::meta }) { + return $meta if $meta->isa('Class::MOP::Class'); + } + confess "'meta' method called by MOP internals" + if caller =~ /Class::MOP|metaclass/; + } $class->initialize(ref($_[0]) || $_[0]); - }); + }) unless $options{no_meta}; $meta->superclasses(@{$options{superclasses}}) if exists $options{superclasses}; @@ -598,6 +613,13 @@ sub _create_meta_instance { return $instance; } +sub inline_create_instance { + my $self = shift; + my ($class) = @_; + + return $self->get_meta_instance->inline_create_instance($class); +} + sub clone_object { my $class = shift; my $instance = shift; @@ -757,10 +779,13 @@ sub get_all_attributes { sub superclasses { my $self = shift; - my $var_spec = { sigil => '@', type => 'ARRAY', name => 'ISA' }; + + my $isa = $self->get_or_add_package_symbol( + { sigil => '@', type => 'ARRAY', name => 'ISA' } ); + if (@_) { my @supers = @_; - @{$self->get_package_symbol($var_spec)} = @supers; + @{$isa} = @supers; # NOTE: # on 5.8 and below, we need to call @@ -779,7 +804,8 @@ sub superclasses { $self->_check_metaclass_compatibility(); $self->_superclasses_updated(); } - @{$self->get_package_symbol($var_spec)}; + + return @{$isa}; } sub _superclasses_updated { @@ -939,8 +965,7 @@ sub get_all_methods { for my $class ( reverse $self->linearized_isa ) { my $meta = Class::MOP::Class->initialize($class); - $methods{$_} = $meta->get_method($_) - for $meta->get_method_list; + $methods{ $_->name } = $_ for $meta->_get_local_methods; } return values %methods; @@ -1153,27 +1178,14 @@ sub _immutable_metaclass { # metaclass roles applied (via Moose), then we want to make sure # that we preserve that anonymous class (see Fey::ORM for an # example of where this matters). - my $meta_name - = $meta->is_immutable - ? $meta->_get_mutable_metaclass_name - : ref $meta; + my $meta_name = $meta->_real_ref_name; my $immutable_meta = $meta_name->create( $class_name, superclasses => [ ref $self ], ); - Class::MOP::load_class($trait); - for my $meth ( Class::MOP::Class->initialize($trait)->get_all_methods ) { - my $meth_name = $meth->name; - - if ( $immutable_meta->find_method_by_name( $meth_name ) ) { - $immutable_meta->add_around_method_modifier( $meth_name, $meth->body ); - } - else { - $immutable_meta->add_method( $meth_name, $meth->clone ); - } - } + Class::MOP::MiniTrait::apply( $immutable_meta, $trait ); $immutable_meta->make_immutable( inline_constructor => 0, @@ -1397,6 +1409,10 @@ hash reference are method names and values are subroutine references. An optional array reference of L objects. +=item * no_meta + +If true, a C method will not be installed into the class. + =back =item B<< Class::MOP::Class->create_anon_class(%options) >> @@ -1508,6 +1524,11 @@ metaclass. Returns an instance of the C to be used in the construction of a new instance of the class. +=item B<< $metaclass->inline_create_instance($class_var) >> + +This method takes a variable name, and uses it create an inline snippet of +code that will create a new instance of the class. + =back =head2 Informational predicates @@ -1706,7 +1727,8 @@ classes. =item B<< $metaclass->get_attribute_list >> This will return a list of attributes I for all attributes -defined in this class. +defined in this class. Note that this operates on the current class +only, it does not traverse the inheritance hierarchy. =item B<< $metaclass->get_all_attributes >>