X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FClass%2FMOP%2FClass.pm;h=120fa999e7d40b1d7be7afb1e3dc7be11cd76809;hb=refs%2Fheads%2Ftopic%2Finline-constructor-tweak;hp=1482ade88ccffdf5a2c8e07a1801a5a87d74a62c;hpb=acf7adee8538ced9d892117274688a9cbd4e4e64;p=gitmo%2FMoose.git diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm index 1482ade..120fa99 100644 --- a/lib/Class/MOP/Class.pm +++ b/lib/Class/MOP/Class.pm @@ -11,6 +11,7 @@ use Class::MOP::Method::Constructor; use Class::MOP::MiniTrait; use Carp 'confess'; +use Class::Load 'is_class_loaded', 'load_class'; use Scalar::Util 'blessed', 'reftype', 'weaken'; use Sub::Name 'subname'; use Try::Tiny; @@ -26,7 +27,7 @@ sub initialize { my $class = shift; my $package_name; - + if ( @_ % 2 ) { $package_name = shift; } else { @@ -101,7 +102,7 @@ sub _construct_class_instance { } # and check the metaclass compatibility - $meta->_check_metaclass_compatibility(); + $meta->_check_metaclass_compatibility(); Class::MOP::store_metaclass_by_name($package_name, $meta); @@ -625,7 +626,7 @@ sub _inline_init_attr_from_constructor { ); push @initial_value, ( - '$attrs->[' . $idx . ']->set_initial_value(', + '$attrs[' . $idx . ']->set_initial_value(', '$instance,', $attr->_inline_instance_get('$instance'), ');', @@ -644,7 +645,7 @@ sub _inline_init_attr_from_default { my @initial_value = $attr->_inline_set_value('$instance', $default); push @initial_value, ( - '$attrs->[' . $idx . ']->set_initial_value(', + '$attrs[' . $idx . ']->set_initial_value(', '$instance,', $attr->_inline_instance_get('$instance'), ');', @@ -665,10 +666,10 @@ sub _inline_default_value { # in which case we can just deal with them # in the code we eval. if ($attr->is_default_a_coderef) { - return '$defaults->[' . $index . ']->($instance)'; + return '$defaults[' . $index . ']->($instance)'; } else { - return '$defaults->[' . $index . ']'; + return '$defaults[' . $index . ']'; } } elsif ($attr->has_builder) { @@ -700,10 +701,10 @@ sub _eval_environment { my @attrs = sort { $a->name cmp $b->name } $self->get_all_attributes; - my $defaults = [map { $_->default } @attrs]; + my @defaults = map { $_->default } @attrs; return { - '$defaults' => \$defaults, + '@defaults' => \@defaults, }; } @@ -715,7 +716,7 @@ sub get_meta_instance { sub _create_meta_instance { my $self = shift; - + my $instance = $self->instance_metaclass->new( associated_metaclass => $self, attributes => [ $self->get_all_attributes() ], @@ -996,18 +997,18 @@ sub class_precedence_list { my $self = shift; my $name = $self->name; - unless (Class::MOP::IS_RUNNING_ON_5_10()) { + unless (Class::MOP::IS_RUNNING_ON_5_10()) { # NOTE: # We need to check for circular inheritance here - # if we are are not on 5.10, cause 5.8 detects it - # late. This will do nothing if all is well, and + # if we are are not on 5.10, cause 5.8 detects it + # late. This will do nothing if all is well, and # blow up otherwise. Yes, it's an ugly hack, better - # suggestions are welcome. + # suggestions are welcome. # - SL - ($name || return)->isa('This is a test for circular inheritance') + ($name || return)->isa('This is a test for circular inheritance') } - # if our mro is c3, we can + # if our mro is c3, we can # just grab the linear_isa if (mro::get_mro($name) eq 'c3') { return @{ mro::get_linear_isa($name) } @@ -1015,7 +1016,7 @@ sub class_precedence_list { else { # NOTE: # we can't grab the linear_isa for dfs - # since it has all the duplicates + # since it has all the duplicates # already removed. return ( $name, @@ -1026,6 +1027,10 @@ sub class_precedence_list { } } +sub _method_lookup_order { + return (shift->linearized_isa, 'UNIVERSAL'); +} + ## Methods { @@ -1108,7 +1113,7 @@ sub find_method_by_name { my ($self, $method_name) = @_; (defined $method_name && length $method_name) || confess "You must define a method name to find"; - foreach my $class ($self->linearized_isa) { + foreach my $class ($self->_method_lookup_order) { my $method = Class::MOP::Class->initialize($class)->get_method($method_name); return $method if defined $method; } @@ -1119,7 +1124,7 @@ sub get_all_methods { my $self = shift; my %methods; - for my $class ( reverse $self->linearized_isa ) { + for my $class ( reverse $self->_method_lookup_order ) { my $meta = Class::MOP::Class->initialize($class); $methods{ $_->name } = $_ for $meta->_get_local_methods; @@ -1130,8 +1135,7 @@ sub get_all_methods { sub get_all_method_names { my $self = shift; - my %uniq; - return grep { !$uniq{$_}++ } map { Class::MOP::Class->initialize($_)->get_method_list } $self->linearized_isa; + map { $_->name } $self->get_all_methods; } sub find_all_methods_by_name { @@ -1139,7 +1143,7 @@ sub find_all_methods_by_name { (defined $method_name && length $method_name) || confess "You must define a method name to find"; my @methods; - foreach my $class ($self->linearized_isa) { + foreach my $class ($self->_method_lookup_order) { # fetch the meta-class ... my $meta = Class::MOP::Class->initialize($class); push @methods => { @@ -1155,7 +1159,7 @@ sub find_next_method_by_name { my ($self, $method_name) = @_; (defined $method_name && length $method_name) || confess "You must define a method name to find"; - my @cpl = $self->linearized_isa; + my @cpl = ($self->_method_lookup_order); shift @cpl; # discard ourselves foreach my $class (@cpl) { my $method = Class::MOP::Class->initialize($class)->get_method($method_name); @@ -1270,7 +1274,7 @@ sub _immutable_options { sub make_immutable { my ( $self, @args ) = @_; - return unless $self->is_mutable; + return $self unless $self->is_mutable; my ($file, $line) = (caller)[1..2]; @@ -1333,7 +1337,7 @@ sub _immutable_metaclass { } return $class_name - if Class::MOP::is_class_loaded($class_name); + if is_class_loaded($class_name); # If the metaclass is a subclass of CMOP::Class which has had # metaclass roles applied (via Moose), then we want to make sure @@ -1423,7 +1427,7 @@ sub _inline_constructor { my $constructor_class = $args{constructor_class}; - Class::MOP::load_class($constructor_class); + load_class($constructor_class); my $constructor = $constructor_class->new( options => \%args, @@ -1460,7 +1464,7 @@ sub _inline_destructor { my $destructor_class = $args{destructor_class}; - Class::MOP::load_class($destructor_class); + load_class($destructor_class); return unless $destructor_class->is_needed($self); @@ -1950,6 +1954,48 @@ default, this is L. =back +=head2 Overload introspection and creation + +These methods provide an API to the core L functionality. + +=over 4 + +=item B<< $metaclass->is_overloaded >> + +Returns true if overloading is enabled for this class. Corresponds to +L. + +=item B<< $metaclass->get_overloaded_operator($op) >> + +Returns the L object corresponding to the +operator named C<$op>, if one exists for this class. + +=item B<< $metaclass->has_overloaded_operator($op) >> + +Returns whether or not the operator C<$op> is overloaded for this class. + +=item B<< $metaclass->get_overload_list >> + +Returns a list of operator names which have been overloaded (see +L for the list of valid operator names). + +=item B<< $metaclass->get_all_overloaded_operators >> + +Returns a list of L objects corresponding to the +operators that have been overloaded. + +=item B<< $metaclass->add_overloaded_operator($op, $impl) >> + +Overloads the operator C<$op> for this class, with the implementation C<$impl>. +C<$impl> can be either a coderef or a method name. Corresponds to +C<< use overload $op => $impl; >> + +=item B<< $metaclass->remove_overloaded_operator($op) >> + +Remove overloading for operator C<$op>. Corresponds to C<< no overload $op; >> + +=back + =head2 Class Immutability Making a class immutable "freezes" the class definition. You can no @@ -1973,7 +2019,8 @@ of the inlining features than Class::MOP itself does. =item B<< $metaclass->make_immutable(%options) >> This method will create an immutable transformer and use it to make -the class and its metaclass object immutable. +the class and its metaclass object immutable, and returns true +(you should not rely on the details of this value apart from its truth). This method accepts the following options: