X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FClass%2FMOP%2FMethod%2FInlined.pm;h=030907c4e3eba2869910cde7c97a2a3973c112d6;hb=06ea51c77e19bd6d13206e4a5423cf5cd5108267;hp=82bae4cc15f98c01c5c73731d68a5e885000fca2;hpb=f5d984416b35f30d2b66a2f582e695164df08e14;p=gitmo%2FClass-MOP.git diff --git a/lib/Class/MOP/Method/Inlined.pm b/lib/Class/MOP/Method/Inlined.pm index 82bae4c..030907c 100644 --- a/lib/Class/MOP/Method/Inlined.pm +++ b/lib/Class/MOP/Method/Inlined.pm @@ -6,7 +6,7 @@ use warnings; use Carp 'confess'; use Scalar::Util 'blessed', 'weaken', 'looks_like_number', 'refaddr'; -our $VERSION = '0.81'; +our $VERSION = '1.01'; $VERSION = eval $VERSION; our $AUTHORITY = 'cpan:STEVAN'; @@ -17,18 +17,15 @@ sub _expected_method_class { $_[0]{_expected_method_class} } sub _uninlined_body { my $self = shift; - if ( my $super_method + my $super_method = $self->associated_metaclass->find_next_method_by_name( $self->name ) - ) { - if ( $super_method->isa(__PACKAGE__) ) { - return $super_method->_uninlined_body; - } - else { - return $super_method->body; - } + or return; + + if ( $super_method->isa(__PACKAGE__) ) { + return $super_method->_uninlined_body; } else { - return; + return $super_method->body; } } @@ -37,77 +34,121 @@ sub can_be_inlined { my $metaclass = $self->associated_metaclass; my $class = $metaclass->name; - if ( my $expected_class = $self->_expected_method_class ) { + # If we don't find an inherited method, this is a rather weird + # case where we have no method in the inheritance chain even + # though we're expecting one to be there + my $inherited_method + = $metaclass->find_next_method_by_name( $self->name ); - # if we are shadowing a method we first verify that it is - # compatible with the definition we are replacing it with - my $expected_method = $expected_class->can( $self->name ); - - my $warning - = "Not inlining '" + if ( $inherited_method + && $inherited_method->isa('Class::MOP::Method::Wrapped') ) { + warn "Not inlining '" . $self->name - . "' for $class since it is not" - . " inheriting the default ${expected_class}::" - . $self->name . "\n" - . "If you are certain you don't need to inline your"; + . "' for $class since it " + . "has method modifiers which would be lost if it were inlined\n"; - if ( $self->isa("Class::MOP::Method::Constructor") ) { + return 0; + } - # FIXME kludge, refactor warning generation to a method - $warning - .= " constructor, specify inline_constructor => 0 in your" - . " call to $class->meta->make_immutable\n"; - } + my $expected_class = $self->_expected_method_class + or return 1; - if ( my $actual_method = $class->can( $self->name ) ) { - if ( refaddr($expected_method) == refaddr($actual_method) ) { - - # the method is what we wanted (probably Moose::Object::new) - return 1; - } - elsif ( my $inherited_method - = $metaclass->find_next_method_by_name( $self->name ) ) { - - # otherwise we have to check that the actual method is an - # inlined version of what we're expecting - if ( $inherited_method->isa(__PACKAGE__) ) { - if ( refaddr( $inherited_method->_uninlined_body ) - == refaddr($expected_method) ) { - return 1; - } - } - elsif ( refaddr( $inherited_method->body ) - == refaddr($expected_method) ) { - return 1; - } - - # FIXME we can just rewrap them =P - $warning - .= " ('" - . $self->name - . "' has method modifiers which would be lost if it were inlined)\n" - if $inherited_method->isa('Class::MOP::Method::Wrapped'); - } - } - else { + # if we are shadowing a method we first verify that it is + # compatible with the definition we are replacing it with + my $expected_method = $expected_class->can( $self->name ); + + if ( ! $expected_method ) { + warn "Not inlining '" + . $self->name + . "' for $class since ${expected_class}::" + . $self->name + . " is not defined\n"; - # This would be a rather weird case where we have no method - # in the inheritance chain even though we're expecting one to be - # there + return 0; + } + + my $actual_method = $class->can( $self->name ) + or return 1; - # this returns 1 for backwards compatibility for now + # the method is what we wanted (probably Moose::Object::new) + return 1 + if refaddr($expected_method) == refaddr($actual_method); + + # otherwise we have to check that the actual method is an inlined + # version of what we're expecting + if ( $inherited_method->isa(__PACKAGE__) ) { + if ( $inherited_method->_uninlined_body + && refaddr( $inherited_method->_uninlined_body ) + == refaddr($expected_method) ) { return 1; } + } + elsif ( refaddr( $inherited_method->body ) + == refaddr($expected_method) ) { + return 1; + } - warn $warning; + my $warning + = "Not inlining '" + . $self->name + . "' for $class since it is not" + . " inheriting the default ${expected_class}::" + . $self->name . "\n"; - return 0; - } - else { + if ( $self->isa("Class::MOP::Method::Constructor") ) { - # there is no expected class so we just install the constructor as a - # new method - return 1; + # FIXME kludge, refactor warning generation to a method + $warning + .= "If you are certain you don't need to inline your" + . " constructor, specify inline_constructor => 0 in your" + . " call to $class->meta->make_immutable\n"; } + + warn $warning; + + return 0; } +1; + +__END__ + +=pod + +=head1 NAME + +Class::MOP::Method::Inlined - Method base class for methods which have been inlined + +=head1 DESCRIPTION + +This is a L subclass for methods which +can be inlined. + +=head1 METHODS + +=over 4 + +=item B<< $metamethod->can_be_inlined >> + +This method returns true if the method in question can be inlined in +the associated metaclass. + +If it cannot be inlined, it spits out a warning and returns false. + +=back + +=head1 AUTHORS + +Stevan Little Estevan@iinteractive.comE + +=head1 COPYRIGHT AND LICENSE + +Copyright 2006-2010 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 +