From: Dave Rolsky Date: Sun, 21 Jun 2009 15:20:17 +0000 (-0500) Subject: Add tests for inline {con,de}structor warnings and inlining. Got rid X-Git-Tag: 0.87~15 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=46c48e085637bb0a61e03de193e3aad510964f88;p=gitmo%2FClass-MOP.git Add tests for inline {con,de}structor warnings and inlining. Got rid of tests that need Moose. Added a replace_destructor immutable option, and use the same logic for inlining a destructor as we do for a constructor. --- diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm index a0333ba..45697f2 100644 --- a/lib/Class/MOP/Class.pm +++ b/lib/Class/MOP/Class.pm @@ -1193,11 +1193,11 @@ sub _inline_constructor { sub _inline_destructor { my ( $self, %args ) = @_; - ( exists $args{destructor_class} ) + ( exists $args{destructor_class} && defined $args{destructor_class} ) || confess "The 'inline_destructor' option is present, but " . "no destructor class was specified"; - if ( $self->has_method('DESTROY') ) { + if ( $self->has_method('DESTROY') && ! $args{replace_destructor} ) { my $class = $self->name; warn "Not inlining a destructor for $class since it defines" . " its own destructor.\n"; @@ -1217,9 +1217,10 @@ sub _inline_destructor { name => 'DESTROY' ); - $self->add_method( 'DESTROY' => $destructor ); - - $self->_add_inlined_method($destructor); + if ( $args{replace_destructor} or $destructor->can_be_inlined ) { + $self->add_method( 'DESTROY' => $destructor ); + $self->_add_inlined_method($destructor); + } } 1; diff --git a/lib/Class/MOP/Method/Inlined.pm b/lib/Class/MOP/Method/Inlined.pm index 96899ef..999aa17 100644 --- a/lib/Class/MOP/Method/Inlined.pm +++ b/lib/Class/MOP/Method/Inlined.pm @@ -34,6 +34,22 @@ sub can_be_inlined { my $metaclass = $self->associated_metaclass; my $class = $metaclass->name; + # 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 ( $inherited_method + && $inherited_method->isa('Class::MOP::Method::Wrapped') ) { + warn "Not inlining '" + . $self->name + . "' for $class since it " + . "has method modifiers which would be lost if it were inlined\n"; + + return 0; + } + my $expected_class = $self->_expected_method_class or return 1; @@ -58,15 +74,6 @@ sub can_be_inlined { return 1 if refaddr($expected_method) == refaddr($actual_method); - # 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 - # - # this returns 1 for backwards compatibility for now - my $inherited_method - = $metaclass->find_next_method_by_name( $self->name ) - or return 1; - # otherwise we have to check that the actual method is an inlined # version of what we're expecting if ( $inherited_method->isa(__PACKAGE__) ) { @@ -96,12 +103,6 @@ sub can_be_inlined { . " call to $class->meta->make_immutable\n"; } - $warning - .= " ('" - . $self->name - . "' has method modifiers which would be lost if it were inlined)\n" - if $inherited_method->isa('Class::MOP::Method::Wrapped'); - warn $warning; return 0; diff --git a/t/310_immutable_destroy.t b/t/310_immutable_destroy.t deleted file mode 100644 index 8f54dbe..0000000 --- a/t/310_immutable_destroy.t +++ /dev/null @@ -1,33 +0,0 @@ -use strict; -use warnings; -use Test::More tests => 2; -use Class::MOP; - -SKIP: { - unless (eval { require Moose; Moose->VERSION(0.72); 1 }) { - diag( $@ ); - skip 'This test requires Moose 0.72', 2; - exit 0; - } - - { - local $SIG{__WARN__} = sub {}; - eval <<'EOF'; - package FooBar; - use Moose 0.72; - - has 'name' => ( is => 'ro' ); - - sub DESTROY { shift->name } - - __PACKAGE__->meta->make_immutable; -EOF - } - - ok( ! $@, 'evaled FooBar package' ) - or diag( $@ ); - my $f = FooBar->new( name => 'SUSAN' ); - - is( $f->DESTROY, 'SUSAN', - 'Class::MOP::Class should not override an existing DESTROY method' ); -} diff --git a/t/310_inline_structor.t b/t/310_inline_structor.t new file mode 100644 index 0000000..bbdcce8 --- /dev/null +++ b/t/310_inline_structor.t @@ -0,0 +1,293 @@ +use strict; +use warnings; + +use Test::More; + +BEGIN { + eval "use Test::Output;"; + plan skip_all => "Test::Output is required for this test" if $@; + plan 'no_plan'; +} + +use Class::MOP; + +{ + package HasConstructor; + + sub new { bless {}, $_[0] } + + my $meta = Class::MOP::Class->initialize(__PACKAGE__); + + $meta->superclasses('NotMoose'); + + ::stderr_like( + sub { $meta->make_immutable }, + qr/\QNot inlining a constructor for HasConstructor since it defines its own constructor.\E\s+\QIf you are certain you don't need to inline your constructor, specify inline_constructor => 0 in your call to HasConstructor->meta->make_immutable\E/, + 'got a warning that Foo will not have an inlined constructor because it defines its own new method' + ); + + ::is( + $meta->find_method_by_name('new')->body, + HasConstructor->can('new'), + 'HasConstructor->new was untouched' + ); +} + +{ + package My::Constructor; + + use base 'Class::MOP::Method::Constructor'; + + sub _expected_method_class { 'Base::Class' } +} + +{ + package No::Constructor; +} + +{ + package My::Constructor2; + + use base 'Class::MOP::Method::Constructor'; + + sub _expected_method_class { 'No::Constructor' } +} + +{ + package Base::Class; + + sub new { bless {}, $_[0] } + sub DESTROY { } +} + +{ + package NotMoose; + + sub new { + my $class = shift; + + return bless { not_moose => 1 }, $class; + } +} + +{ + package Foo; + my $meta = Class::MOP::Class->initialize(__PACKAGE__); + + $meta->superclasses('NotMoose'); + + ::stderr_like( + sub { $meta->make_immutable( constructor_class => 'My::Constructor' ) }, + qr/\QNot inlining 'new' for Foo since it is not inheriting the default Base::Class::new\E\s+\QIf you are certain you don't need to inline your constructor, specify inline_constructor => 0 in your call to Foo->meta->make_immutable/, + 'got a warning that Foo will not have an inlined constructor' + ); + + ::is( + $meta->find_method_by_name('new')->body, + NotMoose->can('new'), + 'Foo->new is inherited from NotMoose' + ); +} + +{ + package Bar; + my $meta = Class::MOP::Class->initialize(__PACKAGE__); + + $meta->superclasses('NotMoose'); + + ::stderr_is( + sub { $meta->make_immutable( replace_constructor => 1 ) }, + q{}, + 'no warning when replace_constructor is true' + ); + + ::is( + $meta->find_method_by_name('new')->package_name, + 'Bar', + 'Bar->new is inlined, and not inherited from NotMoose' + ); +} + +{ + package Baz; + Class::MOP::Class->initialize(__PACKAGE__)->make_immutable; +} + +{ + package Quux; + my $meta = Class::MOP::Class->initialize(__PACKAGE__); + + $meta->superclasses('Baz'); + + ::stderr_is( + sub { $meta->make_immutable }, + q{}, + 'no warning when inheriting from a class that has already made itself immutable' + ); +} + +{ + package Whatever; + my $meta = Class::MOP::Class->initialize(__PACKAGE__); + + ::stderr_like( + sub { $meta->make_immutable( constructor_class => 'My::Constructor2' ) }, + qr/\QNot inlining 'new' for Whatever since No::Constructor::new is not defined/, + 'got a warning that Whatever will not have an inlined constructor because its expected inherited method does not exist' + ); +} + +{ + package My::Constructor3; + + use base 'Class::MOP::Method::Constructor'; +} + +{ + package CustomCons; + + Class::MOP::Class->initialize(__PACKAGE__)->make_immutable( constructor_class => 'My::Constructor3' ); +} + +{ + package Subclass; + my $meta = Class::MOP::Class->initialize(__PACKAGE__); + + $meta->superclasses('CustomCons'); + + ::stderr_is( + sub { $meta->make_immutable }, + q{}, + 'no warning when inheriting from a class that has already made itself immutable' + ); +} + +{ + package ModdedNew; + my $meta = Class::MOP::Class->initialize(__PACKAGE__); + + sub new { bless {}, shift } + + $meta->add_before_method_modifier( 'new' => sub { } ); +} + +{ + package ModdedSub; + my $meta = Class::MOP::Class->initialize(__PACKAGE__); + + $meta->superclasses('ModdedNew'); + + ::stderr_like( + sub { $meta->make_immutable }, + qr/\QNot inlining 'new' for ModdedSub since it has method modifiers which would be lost if it were inlined/, + 'got a warning that ModdedSub will not have an inlined constructor since it inherited a wrapped new' + ); +} + +{ + package My::Destructor; + + use base 'Class::MOP::Method::Inlined'; + + sub new { + my $class = shift; + my %options = @_; + + my $self = bless \%options, $class; + $self->_inline_destructor; + + return $self; + } + + sub _inline_destructor { + my $self = shift; + + my $code = $self->_eval_closure( {}, 'sub { }' ); + + $self->{body} = $code; + } + + sub is_needed { 1 } + sub associated_metaclass { $_[0]->{metaclass} } + sub _expected_method_class { 'Base::Class' } +} + +{ + package HasDestructor; + my $meta = Class::MOP::Class->initialize(__PACKAGE__); + + sub DESTROY { } + + ::stderr_like( + sub { + $meta->make_immutable( + inline_destructor => 1, + destructor_class => 'My::Destructor', + ); + }, + qr/Not inlining a destructor for HasDestructor since it defines its own destructor./, + 'got a warning when trying to inline a destructor for a class that already defines DESTROY' + ); + + ::is( + $meta->find_method_by_name('DESTROY')->body, + HasDestructor->can('DESTROY'), + 'HasDestructor->DESTROY was untouched' + ); +} + +{ + package HasDestructor2; + my $meta = Class::MOP::Class->initialize(__PACKAGE__); + + sub DESTROY { } + + $meta->make_immutable( + inline_destructor => 1, + destructor_class => 'My::Destructor', + replace_destructor => 1 + ); + + ::stderr_is( + sub { + $meta->make_immutable( + inline_destructor => 1, + destructor_class => 'My::Destructor', + replace_destructor => 1 + ); + }, + q{}, + 'no warning when replace_destructor is true' + ); + + ::isnt( + $meta->find_method_by_name('new')->body, + HasConstructor2->can('new'), + 'HasConstructor2->new was replaced' + ); +} + +{ + package ParentHasDestructor; + + sub DESTROY { } +} + +{ + package DestructorChild; + + use base 'ParentHasDestructor'; + + my $meta = Class::MOP::Class->initialize(__PACKAGE__); + + ::stderr_like( + sub { + $meta->make_immutable( + inline_destructor => 1, + destructor_class => 'My::Destructor', + ); + }, + qr/Not inlining 'DESTROY' for DestructorChild since it is not inheriting the default Base::Class::DESTROY/, + 'got a warning when trying to inline a destructor in a class that inherits an unexpected DESTROY' + ); +}