X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FClass%2FMOP%2FClass.pm;h=2a975e8671f8ee63d8108de71e0d2e3a182fffb3;hb=982b6f24564033d95a3bef722f9deccb24906e4f;hp=88103388fd7528733811d817a67f86eb3c4556bb;hpb=efc98200d49cae9fb74285a58d12e3b988da0a97;p=gitmo%2FClass-MOP.git diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm index 8810338..2a975e8 100644 --- a/lib/Class/MOP/Class.pm +++ b/lib/Class/MOP/Class.pm @@ -10,7 +10,7 @@ use Class::MOP::Method::Accessor; use Class::MOP::Method::Constructor; use Carp 'confess'; -use Scalar::Util 'blessed', 'weaken'; +use Scalar::Util 'blessed', 'reftype', 'weaken'; use Sub::Name 'subname'; use Devel::GlobalDestruction 'in_global_destruction'; @@ -34,7 +34,7 @@ sub initialize { $package_name = $options{package}; } - (defined $package_name && $package_name && !ref($package_name)) + ($package_name && !ref($package_name)) || confess "You must pass a package name and it cannot be blessed"; return Class::MOP::get_metaclass_by_name($package_name) @@ -107,9 +107,13 @@ sub _construct_class_instance { sub _new { my $class = shift; + + return Class::MOP::Class->initialize($class)->new_object(@_) + if $class ne __PACKAGE__; + my $options = @_ == 1 ? $_[0] : {@_}; - bless { + return bless { # inherited from Class::MOP::Package 'package' => $options->{package}, @@ -229,7 +233,7 @@ sub _check_metaclass_compatibility { sub is_anon_class { my $self = shift; no warnings 'uninitialized'; - $self->name =~ /^$ANON_CLASS_PREFIX/; + $self->name =~ /^$ANON_CLASS_PREFIX/o; } sub create_anon_class { @@ -251,7 +255,7 @@ sub _check_metaclass_compatibility { no warnings 'uninitialized'; my $name = $self->name; - return unless $name =~ /^$ANON_CLASS_PREFIX/; + return unless $name =~ /^$ANON_CLASS_PREFIX/o; # Moose does a weird thing where it replaces the metaclass for # class when fixing metaclass incompatibility. In that case, # we don't want to clean out the namespace now. We can detect @@ -260,13 +264,17 @@ sub _check_metaclass_compatibility { my $current_meta = Class::MOP::get_metaclass_by_name($name); return if $current_meta ne $self; - my ($serial_id) = ($name =~ /^$ANON_CLASS_PREFIX(\d+)/); - no strict 'refs'; - @{$name . '::ISA'} = (); - %{$name . '::'} = (); - delete ${$ANON_CLASS_PREFIX}{$serial_id . '::'}; + + @{$self->get_package_symbol({name => 'ISA', type => 'ARRAY', sigil => '$', create => 1 })} = (); + %{ $self->namespace } = (); + + my ($serial_id) = ($name =~ /^$ANON_CLASS_PREFIX(\d+)/o); Class::MOP::remove_metaclass_by_name($name); + + no strict 'refs'; + delete ${$ANON_CLASS_PREFIX}{$serial_id . '::'}; + return; } } @@ -347,6 +355,8 @@ sub constructor_class { $_[0]->{'constructor_class'} } sub constructor_name { $_[0]->{'constructor_name'} } sub destructor_class { $_[0]->{'destructor_class'} } +sub _method_map { $_[0]->{'methods'} } + # Instance Construction & Cloning sub new_object { @@ -383,7 +393,7 @@ sub _construct_instance { # NOTE: # this will only work for a HASH instance type if ($class->is_anon_class) { - (Scalar::Util::reftype($instance) eq 'HASH') + (reftype($instance) eq 'HASH') || confess "Currently only HASH based instances are supported with instance of anon-classes"; # NOTE: # At some point we should make this official @@ -502,7 +512,7 @@ sub rebless_instance_away { sub superclasses { my $self = shift; - my $var_spec = { sigil => '@', type => 'ARRAY', name => 'ISA' }; + my $var_spec = { sigil => '@', type => 'ARRAY', name => 'ISA', create => 1 }; if (@_) { my @supers = @_; @{$self->get_package_symbol($var_spec)} = @supers; @@ -616,15 +626,16 @@ sub add_method { name => $method_name ) if $method->can('clone'); } + + $method->attach_to_class($self); + $self->_method_map->{$method_name} = $method; } else { + # If a raw code reference is supplied, its method object is not created. + # The method object won't be created until required. $body = $method; - $method = $self->wrap_method_body( body => $body, name => $method_name ); } - $method->attach_to_class($self); - - $self->get_method_map->{$method_name} = $method; my ( $current_package, $current_name ) = Class::MOP::get_code_info($body); @@ -655,12 +666,17 @@ sub add_method { # and now make sure to wrap it # even if it is already wrapped # because we need a new sub ref - $method = $wrapped_metaclass->wrap($method); + $method = $wrapped_metaclass->wrap($method, + package_name => $self->name, + name => $method_name, + ); } else { # now make sure we wrap it properly - $method = $wrapped_metaclass->wrap($method) - unless $method->isa($wrapped_metaclass); + $method = $wrapped_metaclass->wrap($method, + package_name => $self->name, + name => $method_name, + ) unless $method->isa($wrapped_metaclass); } $self->add_method($method_name => $method); return $method; @@ -716,12 +732,21 @@ sub alias_method { shift->add_method(@_); } +sub _code_is_mine { + my ( $self, $code ) = @_; + + my ( $code_package, $code_name ) = Class::MOP::get_code_info($code); + + return $code_package && $code_package eq $self->name + || ( $code_package eq 'constant' && $code_name eq '__ANON__' ); +} + sub has_method { my ($self, $method_name) = @_; (defined $method_name && $method_name) || confess "You must define a method name"; - exists $self->get_method_map->{$method_name}; + return defined($self->get_method($method_name)); } sub get_method { @@ -729,7 +754,30 @@ sub get_method { (defined $method_name && $method_name) || confess "You must define a method name"; - return $self->get_method_map->{$method_name}; + my $method_map = $self->_method_map; + my $method_object = $method_map->{$method_name}; + my $code = $self->get_package_symbol({ + name => $method_name, + sigil => '&', + type => 'CODE', + }); + + unless ( $method_object && $method_object->body == ( $code || 0 ) ) { + if ( $code && $self->_code_is_mine($code) ) { + $method_object = $method_map->{$method_name} + = $self->wrap_method_body( + body => $code, + name => $method_name, + associated_metaclass => $self, + ); + } + else { + delete $method_map->{$method_name}; + return undef; + } + } + + return $method_object; } sub remove_method { @@ -752,7 +800,7 @@ sub remove_method { sub get_method_list { my $self = shift; - keys %{$self->get_method_map}; + return grep { $self->has_method($_) } keys %{ $self->namespace }; } sub find_method_by_name { @@ -760,10 +808,8 @@ sub find_method_by_name { (defined $method_name && $method_name) || confess "You must define a method name to find"; foreach my $class ($self->linearized_isa) { - # fetch the meta-class ... - my $meta = $self->initialize($class); - return $meta->get_method($method_name) - if $meta->has_method($method_name); + my $method = $self->initialize($class)->get_method($method_name); + return $method if defined $method; } return; } @@ -790,7 +836,7 @@ sub compute_all_applicable_methods { sub get_all_method_names { my $self = shift; my %uniq; - grep { $uniq{$_}++ == 0 } map { $_->name } $self->get_all_methods; + return grep { !$uniq{$_}++ } map { $self->initialize($_)->get_method_list } $self->linearized_isa; } sub find_all_methods_by_name { @@ -817,10 +863,8 @@ sub find_next_method_by_name { my @cpl = $self->linearized_isa; shift @cpl; # discard ourselves foreach my $class (@cpl) { - # fetch the meta-class ... - my $meta = $self->initialize($class); - return $meta->get_method($method_name) - if $meta->has_method($method_name); + my $method = $self->initialize($class)->get_method($method_name); + return $method if defined $method; } return; } @@ -841,23 +885,25 @@ sub add_attribute { # about the class which it is attached to $attribute->attach_to_class($self); + my $attr_name = $attribute->name; + # then we remove attributes of a conflicting # name here so that we can properly detach # the old attr object, and remove any # accessors it would have generated - if ( $self->has_attribute($attribute->name) ) { - $self->remove_attribute($attribute->name); + if ( $self->has_attribute($attr_name) ) { + $self->remove_attribute($attr_name); } else { $self->invalidate_meta_instances(); } # get our count of previously inserted attributes and # increment by one so this attribute knows its order - my $order = (scalar keys %{$self->get_attribute_map}) - 1; - $attribute->_set_insertion_order($order + 1); + my $order = (scalar keys %{$self->get_attribute_map}); + $attribute->_set_insertion_order($order); # then onto installing the new accessors - $self->get_attribute_map->{$attribute->name} = $attribute; + $self->get_attribute_map->{$attr_name} = $attribute; # invalidate package flag here my $e = do { @@ -867,7 +913,7 @@ sub add_attribute { $@; }; if ( $e ) { - $self->remove_attribute($attribute->name); + $self->remove_attribute($attr_name); die $e; } @@ -1081,7 +1127,8 @@ sub _immutable_metaclass { my $trait = $args{immutable_trait} = $self->immutable_trait || confess "no immutable trait specified for $self"; - my $meta_attr = $self->meta->find_attribute_by_name("immutable_trait"); + my $meta = $self->meta; + my $meta_attr = $meta->find_attribute_by_name("immutable_trait"); my $class_name; @@ -1103,28 +1150,31 @@ sub _immutable_metaclass { # that we preserve that anonymous class (see Fey::ORM for an # example of where this matters). my $meta_name - = $self->meta->is_immutable - ? $self->meta->get_mutable_metaclass_name - : ref $self->meta; + = $meta->is_immutable + ? $meta->get_mutable_metaclass_name + : ref $meta; - my $meta = $meta_name->create( + 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 ) { - next if $meta->has_method( $meth->name ); + my $meth_name = $meth->name; - if ( $meta->find_method_by_name( $meth->name ) ) { - $meta->add_around_method_modifier( $meth->name, $meth->body ); + if ( $immutable_meta->find_method_by_name( $meth_name ) ) { + $immutable_meta->add_around_method_modifier( $meth_name, $meth->body ); } else { - $meta->add_method( $meth->name, $meth->clone ); + $immutable_meta->add_method( $meth_name, $meth->clone ); } } - $meta->make_immutable( inline_constructor => 0 ); + $immutable_meta->make_immutable( + inline_constructor => 0, + inline_accessors => 0, + ); return $class_name; } @@ -1339,11 +1389,7 @@ hash reference are method names, and values are subroutine references. =item * attributes -An optional array reference of attributes. - -An attribute can be passed as an existing L -object, I or as a hash reference of options which will be passed -to the attribute metaclass's constructor. +An optional array reference of L objects. =back