From: gfx Date: Mon, 26 Jul 2010 11:26:33 +0000 (+0900) Subject: Fix illegal option process, add tests for it X-Git-Tag: 0.64~4 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=4a07d07686d449924ad2ace3cffa03a79fe75951;p=gitmo%2FMouse.git Fix illegal option process, add tests for it --- diff --git a/lib/Mouse/Meta/Attribute.pm b/lib/Mouse/Meta/Attribute.pm index 12dead6..aa92e70 100644 --- a/lib/Mouse/Meta/Attribute.pm +++ b/lib/Mouse/Meta/Attribute.pm @@ -201,7 +201,7 @@ sub clone_and_inherit_options{ my $args = $self->Mouse::Object::BUILDARGS(@_); foreach my $illegal($self->illegal_options_for_inheritance) { - if(exists $args->{$illegal}) { + if(exists $args->{$illegal} and exists $self->{$illegal}) { $self->throw_error("Illegal inherited option: $illegal"); } } diff --git a/t/020_attributes/022_illegal_options_for_inheritance.t b/t/020_attributes/022_illegal_options_for_inheritance.t new file mode 100644 index 0000000..014d946 --- /dev/null +++ b/t/020_attributes/022_illegal_options_for_inheritance.t @@ -0,0 +1,80 @@ +#!/usr/bin/perl + +use strict; +use warnings; +use Test::More; +use Test::Exception; + +{ + package Foo; + use Mouse; + + has foo => ( + is => 'ro', + ); + + has bar => ( + clearer => 'clear_bar', + ); +} + +{ + package Foo::Sub; + use Mouse; + + extends 'Foo'; + + ::throws_ok { has '+foo' => (is => 'rw') } qr/illegal/, "can't override is"; + ::throws_ok { has '+foo' => (reader => 'bar') } qr/illegal/, "can't override reader"; + ::lives_ok { has '+foo' => (clearer => 'baz') } "can override unspecified things"; + + ::throws_ok { has '+bar' => (clearer => 'quux') } qr/illegal/, "can't override clearer"; + ::lives_ok { has '+bar' => (predicate => 'has_bar') } "can override unspecified things"; +} + +{ + package Bar::Meta::Attribute; + use Mouse::Role; + + has my_illegal_option => (is => 'ro'); + + around illegal_options_for_inheritance => sub { + return (shift->(@_), 'my_illegal_option'); + }; +} + +{ + package Bar; + use Mouse; + + ::lives_ok { + has bar => ( + traits => ['Bar::Meta::Attribute'], + my_illegal_option => 'FOO', + is => 'bare', + ); + } "can use illegal options"; + + has baz => ( + traits => ['Bar::Meta::Attribute'], + is => 'bare', + ); +} + +{ + package Bar::Sub; + use Mouse; + + extends 'Bar'; + + ::throws_ok { has '+bar' => (my_illegal_option => 'BAR') } + qr/illegal/, + "can't override illegal attribute"; + ::lives_ok { has '+baz' => (my_illegal_option => 'BAR') } + "can add illegal option if superclass doesn't set it"; +} + +my $bar_attr = Bar->meta->get_attribute('bar'); +ok((grep { $_ eq 'my_illegal_option' } $bar_attr->illegal_options_for_inheritance) > 0, '... added my_illegal_option as illegal option for inheritance'); + +done_testing; diff --git a/t/020_attributes/failing/022_legal_options_for_inheritance.t b/t/020_attributes/failing/022_legal_options_for_inheritance.t deleted file mode 100644 index 2830506..0000000 --- a/t/020_attributes/failing/022_legal_options_for_inheritance.t +++ /dev/null @@ -1,49 +0,0 @@ -#!/usr/bin/perl - -use strict; -use warnings; -use Test::More tests => 2; - - - -{ - package Bar::Meta::Attribute; - use Mouse; - - extends 'Mouse::Meta::Attribute'; - - has 'my_legal_option' => ( - isa => 'CodeRef', - is => 'rw', - ); - - around legal_options_for_inheritance => sub { - return (shift->(@_), qw/my_legal_option/); - }; - - package Bar; - use Mouse; - - has 'bar' => ( - metaclass => 'Bar::Meta::Attribute', - my_legal_option => sub { 'Bar' }, - is => 'bare', - ); - - package Bar::B; - use Mouse; - - extends 'Bar'; - - has '+bar' => ( - my_legal_option => sub { 'Bar::B' } - ); -} - -my $bar_attr = Bar::B->meta->get_attribute('bar'); -my ($legal_option) = grep { - $_ eq 'my_legal_option' -} $bar_attr->legal_options_for_inheritance; -is($legal_option, 'my_legal_option', - '... added my_legal_option as legal option for inheritance' ); -is($bar_attr->my_legal_option->(), 'Bar::B', '... overloaded my_legal_option');