From: gfx Date: Thu, 8 Oct 2009 11:06:03 +0000 (+0900) Subject: Import tests for attribute from Mouse's tests X-Git-Tag: 0.37_04~8 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=4060c871da12ba3c5e88986ed121a8254f906bd6;p=gitmo%2FMouse.git Import tests for attribute from Mouse's tests --- diff --git a/t/020_attributes/002_attribute_writer_generation.t b/t/020_attributes/002_attribute_writer_generation.t new file mode 100644 index 0000000..0c49739 --- /dev/null +++ b/t/020_attributes/002_attribute_writer_generation.t @@ -0,0 +1,121 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 29; +use Test::Exception; + +use Scalar::Util 'isweak'; + + + +{ + package Foo; + use Mouse; + + eval { + has 'foo' => ( + reader => 'get_foo', + writer => 'set_foo', + ); + }; + ::ok(!$@, '... created the writer method okay'); + + eval { + has 'foo_required' => ( + reader => 'get_foo_required', + writer => 'set_foo_required', + required => 1, + ); + }; + ::ok(!$@, '... created the required writer method okay'); + + eval { + has 'foo_int' => ( + reader => 'get_foo_int', + writer => 'set_foo_int', + isa => 'Int', + ); + }; + ::ok(!$@, '... created the writer method with type constraint okay'); + + eval { + has 'foo_weak' => ( + reader => 'get_foo_weak', + writer => 'set_foo_weak', + weak_ref => 1 + ); + }; + ::ok(!$@, '... created the writer method with weak_ref okay'); +} + +{ + my $foo = Foo->new(foo_required => 'required'); + isa_ok($foo, 'Foo'); + + # regular writer + + can_ok($foo, 'set_foo'); + is($foo->get_foo(), undef, '... got an unset value'); + lives_ok { + $foo->set_foo(100); + } '... set_foo wrote successfully'; + is($foo->get_foo(), 100, '... got the correct set value'); + + ok(!isweak($foo->{foo}), '... it is not a weak reference'); + + # required writer + + dies_ok { + Foo->new; + } '... cannot create without the required attribute'; + + can_ok($foo, 'set_foo_required'); + is($foo->get_foo_required(), 'required', '... got an unset value'); + lives_ok { + $foo->set_foo_required(100); + } '... set_foo_required wrote successfully'; + is($foo->get_foo_required(), 100, '... got the correct set value'); + + dies_ok { + $foo->set_foo_required(); + } '... set_foo_required died successfully with no value'; + + lives_ok { + $foo->set_foo_required(undef); + } '... set_foo_required did accept undef'; + + ok(!isweak($foo->{foo_required}), '... it is not a weak reference'); + + # with type constraint + + can_ok($foo, 'set_foo_int'); + is($foo->get_foo_int(), undef, '... got an unset value'); + lives_ok { + $foo->set_foo_int(100); + } '... set_foo_int wrote successfully'; + is($foo->get_foo_int(), 100, '... got the correct set value'); + + dies_ok { + $foo->set_foo_int("Foo"); + } '... set_foo_int died successfully'; + + ok(!isweak($foo->{foo_int}), '... it is not a weak reference'); + + # with weak_ref + + my $test = []; + + can_ok($foo, 'set_foo_weak'); + is($foo->get_foo_weak(), undef, '... got an unset value'); + lives_ok { + $foo->set_foo_weak($test); + } '... set_foo_weak wrote successfully'; + is($foo->get_foo_weak(), $test, '... got the correct set value'); + + ok(isweak($foo->{foo_weak}), '... it is a weak reference'); +} + + + diff --git a/t/020_attributes/003_attribute_accessor_generation.t b/t/020_attributes/003_attribute_accessor_generation.t new file mode 100644 index 0000000..4b8620b --- /dev/null +++ b/t/020_attributes/003_attribute_accessor_generation.t @@ -0,0 +1,208 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 57; +use Test::Exception; + +use Scalar::Util 'isweak'; + + + +{ + package Foo; + use Mouse; + + eval { + has 'foo' => ( + accessor => 'foo', + ); + }; + ::ok(!$@, '... created the accessor method okay'); + + eval { + has 'lazy_foo' => ( + accessor => 'lazy_foo', + lazy => 1, + default => sub { 10 } + ); + }; + ::ok(!$@, '... created the lazy accessor method okay'); + + + eval { + has 'foo_required' => ( + accessor => 'foo_required', + required => 1, + ); + }; + ::ok(!$@, '... created the required accessor method okay'); + + eval { + has 'foo_int' => ( + accessor => 'foo_int', + isa => 'Int', + ); + }; + ::ok(!$@, '... created the accessor method with type constraint okay'); + + eval { + has 'foo_weak' => ( + accessor => 'foo_weak', + weak_ref => 1 + ); + }; + ::ok(!$@, '... created the accessor method with weak_ref okay'); + + eval { + has 'foo_deref' => ( + accessor => 'foo_deref', + isa => 'ArrayRef', + auto_deref => 1, + ); + }; + ::ok(!$@, '... created the accessor method with auto_deref okay'); + + eval { + has 'foo_deref_ro' => ( + reader => 'foo_deref_ro', + isa => 'ArrayRef', + auto_deref => 1, + ); + }; + ::ok(!$@, '... created the reader method with auto_deref okay'); + + eval { + has 'foo_deref_hash' => ( + accessor => 'foo_deref_hash', + isa => 'HashRef', + auto_deref => 1, + ); + }; + ::ok(!$@, '... created the reader method with auto_deref okay'); +} + +{ + my $foo = Foo->new(foo_required => 'required'); + isa_ok($foo, 'Foo'); + + # regular accessor + + can_ok($foo, 'foo'); + is($foo->foo(), undef, '... got an unset value'); + lives_ok { + $foo->foo(100); + } '... foo wrote successfully'; + is($foo->foo(), 100, '... got the correct set value'); + + ok(!isweak($foo->{foo}), '... it is not a weak reference'); + + # required writer + + dies_ok { + Foo->new; + } '... cannot create without the required attribute'; + + can_ok($foo, 'foo_required'); + is($foo->foo_required(), 'required', '... got an unset value'); + lives_ok { + $foo->foo_required(100); + } '... foo_required wrote successfully'; + is($foo->foo_required(), 100, '... got the correct set value'); + + lives_ok { + $foo->foo_required(undef); + } '... foo_required did not die with undef'; + + is($foo->foo_required, undef, "value is undef"); + + ok(!isweak($foo->{foo_required}), '... it is not a weak reference'); + + # lazy + + ok(!exists($foo->{lazy_foo}), '... no value in lazy_foo slot'); + + can_ok($foo, 'lazy_foo'); + is($foo->lazy_foo(), 10, '... got an deferred value'); + + # with type constraint + + can_ok($foo, 'foo_int'); + is($foo->foo_int(), undef, '... got an unset value'); + lives_ok { + $foo->foo_int(100); + } '... foo_int wrote successfully'; + is($foo->foo_int(), 100, '... got the correct set value'); + + dies_ok { + $foo->foo_int("Foo"); + } '... foo_int died successfully'; + + ok(!isweak($foo->{foo_int}), '... it is not a weak reference'); + + # with weak_ref + + my $test = []; + + can_ok($foo, 'foo_weak'); + is($foo->foo_weak(), undef, '... got an unset value'); + lives_ok { + $foo->foo_weak($test); + } '... foo_weak wrote successfully'; + is($foo->foo_weak(), $test, '... got the correct set value'); + + ok(isweak($foo->{foo_weak}), '... it is a weak reference'); + + can_ok( $foo, 'foo_deref'); + is_deeply( [$foo->foo_deref()], [], '... default default value'); + my @list; + lives_ok { + @list = $foo->foo_deref(); + } "... doesn't deref undef value"; + is_deeply( \@list, [], "returns empty list in list context"); + + lives_ok { + $foo->foo_deref( [ qw/foo bar gorch/ ] ); + } '... foo_deref wrote successfully'; + + is( Scalar::Util::reftype( scalar $foo->foo_deref() ), "ARRAY", "returns an array reference in scalar context" ); + is_deeply( scalar($foo->foo_deref()), [ qw/foo bar gorch/ ], "correct array" ); + + is( scalar( () = $foo->foo_deref() ), 3, "returns list in list context" ); + is_deeply( [ $foo->foo_deref() ], [ qw/foo bar gorch/ ], "correct list" ); + + + can_ok( $foo, 'foo_deref' ); + is_deeply( [$foo->foo_deref_ro()], [], "... default default value" ); + + dies_ok { + $foo->foo_deref_ro( [] ); + } "... read only"; + + $foo->{foo_deref_ro} = [qw/la la la/]; + + is_deeply( scalar($foo->foo_deref_ro()), [qw/la la la/], "scalar context ro" ); + is_deeply( [ $foo->foo_deref_ro() ], [qw/la la la/], "list context ro" ); + + can_ok( $foo, 'foo_deref_hash' ); + is_deeply( { $foo->foo_deref_hash() }, {}, "... default default value" ); + + my %hash; + lives_ok { + %hash = $foo->foo_deref_hash(); + } "... doesn't deref undef value"; + is_deeply( \%hash, {}, "returns empty list in list context"); + + lives_ok { + $foo->foo_deref_hash( { foo => 1, bar => 2 } ); + } '... foo_deref_hash wrote successfully'; + + is_deeply( scalar($foo->foo_deref_hash), { foo => 1, bar => 2 }, "scalar context" ); + + %hash = $foo->foo_deref_hash; + is_deeply( \%hash, { foo => 1, bar => 2 }, "list context"); +} + + + diff --git a/t/020_attributes/005_attribute_does.t b/t/020_attributes/005_attribute_does.t new file mode 100644 index 0000000..c61f826 --- /dev/null +++ b/t/020_attributes/005_attribute_does.t @@ -0,0 +1,110 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 9; +use Test::Exception; + + + +{ + package Foo::Role; + use Mouse::Role; + use Mouse::Util::TypeConstraints; + + # if does() exists on its own, then + # we create a type constraint for + # it, just as we do for isa() + has 'bar' => (is => 'rw', does => 'Bar::Role'); + has 'baz' => ( + is => 'rw', + does => role_type('Bar::Role') + ); + + package Bar::Role; + use Mouse::Role; + + # if isa and does appear together, then see if Class->does(Role) + # if it does work... then the does() check is actually not needed + # since the isa() check will imply the does() check + has 'foo' => (is => 'rw', isa => 'Foo::Class', does => 'Foo::Role'); + + package Foo::Class; + use Mouse; + + with 'Foo::Role'; + + package Bar::Class; + use Mouse; + + with 'Bar::Role'; + +} + +my $foo = Foo::Class->new; +isa_ok($foo, 'Foo::Class'); + +my $bar = Bar::Class->new; +isa_ok($bar, 'Bar::Class'); + +lives_ok { + $foo->bar($bar); +} '... bar passed the type constraint okay'; + +dies_ok { + $foo->bar($foo); +} '... foo did not pass the type constraint okay'; + +lives_ok { + $foo->baz($bar); +} '... baz passed the type constraint okay'; + +dies_ok { + $foo->baz($foo); +} '... foo did not pass the type constraint okay'; + +lives_ok { + $bar->foo($foo); +} '... foo passed the type constraint okay'; + + + +# some error conditions + +{ + package Baz::Class; + use Test::More; + use Mouse; + + local $TODO = 'setting both isa and does'; + + # if isa and does appear together, then see if Class->does(Role) + # if it does not,.. we have a conflict... so we die loudly + ::dies_ok { + has 'foo' => (isa => 'Foo::Class', does => 'Bar::Class'); + } '... cannot have a does() which is not done by the isa()'; +} + +{ + package Bling; + use strict; + use warnings; + + sub bling { 'Bling::bling' } + + package Bling::Bling; + use Test::More; + use Mouse; + + local $TODO = 'setting both isa and does'; + + # if isa and does appear together, then see if Class->does(Role) + # if it does not,.. we have a conflict... so we die loudly + ::dies_ok { + has 'foo' => (isa => 'Bling', does => 'Bar::Class'); + } '... cannot have a isa() which is cannot does()'; +} + + + diff --git a/t/020_attributes/006_attribute_required.t b/t/020_attributes/006_attribute_required.t new file mode 100644 index 0000000..ba61a74 --- /dev/null +++ b/t/020_attributes/006_attribute_required.t @@ -0,0 +1,68 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 15; +use Test::Exception; + + + +{ + package Foo; + use Mouse; + + has 'bar' => (is => 'ro', required => 1); + has 'baz' => (is => 'rw', default => 100, required => 1); + has 'boo' => (is => 'rw', lazy => 1, default => 50, required => 1); +} + +{ + my $foo = Foo->new(bar => 10, baz => 20, boo => 100); + isa_ok($foo, 'Foo'); + + is($foo->bar, 10, '... got the right bar'); + is($foo->baz, 20, '... got the right baz'); + is($foo->boo, 100, '... got the right boo'); +} + +{ + my $foo = Foo->new(bar => 10, boo => 5); + isa_ok($foo, 'Foo'); + + is($foo->bar, 10, '... got the right bar'); + is($foo->baz, 100, '... got the right baz'); + is($foo->boo, 5, '... got the right boo'); +} + +{ + my $foo = Foo->new(bar => 10); + isa_ok($foo, 'Foo'); + + is($foo->bar, 10, '... got the right bar'); + is($foo->baz, 100, '... got the right baz'); + is($foo->boo, 50, '... got the right boo'); +} + +#Yeah.. this doesn't work like this anymore, see below. (groditi) +#throws_ok { +# Foo->new(bar => 10, baz => undef); +#} qr/^Attribute \(baz\) is required and cannot be undef/, '... must supply all the required attribute'; + +#throws_ok { +# Foo->new(bar => 10, boo => undef); +#} qr/^Attribute \(boo\) is required and cannot be undef/, '... must supply all the required attribute'; + +lives_ok { + Foo->new(bar => 10, baz => undef); +} '... undef is a valid attribute value'; + +lives_ok { + Foo->new(bar => 10, boo => undef); +} '... undef is a valid attribute value'; + + +throws_ok { + Foo->new; +} qr/^Attribute \(bar\) is required/, '... must supply all the required attribute'; + diff --git a/t/020_attributes/007_attribute_custom_metaclass.t b/t/020_attributes/007_attribute_custom_metaclass.t new file mode 100644 index 0000000..1d3c977 --- /dev/null +++ b/t/020_attributes/007_attribute_custom_metaclass.t @@ -0,0 +1,96 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 16; +use Test::Exception; + + + +{ + package Foo::Meta::Attribute; + use Mouse; + + extends 'Mouse::Meta::Attribute'; + + around 'new' => sub { + my $next = shift; + my $self = shift; + my $name = shift; + $next->($self, $name, (is => 'rw', isa => 'Foo'), @_); + }; + + package Foo; + use Mouse; + + has 'foo' => (metaclass => 'Foo::Meta::Attribute'); +} +{ + my $foo = Foo->new; + isa_ok($foo, 'Foo'); + + my $foo_attr = Foo->meta->get_attribute('foo'); + isa_ok($foo_attr, 'Foo::Meta::Attribute'); + isa_ok($foo_attr, 'Mouse::Meta::Attribute'); + + is($foo_attr->name, 'foo', '... got the right name for our meta-attribute'); + ok($foo_attr->has_accessor, '... our meta-attrubute created the accessor for us'); + + ok($foo_attr->has_type_constraint, '... our meta-attrubute created the type_constraint for us'); + + my $foo_attr_type_constraint = $foo_attr->type_constraint; + isa_ok($foo_attr_type_constraint, 'Mouse::Meta::TypeConstraint'); + + is($foo_attr_type_constraint->name, 'Foo', '... got the right type constraint name'); + + local $TODO = '$type_constraint->parent is not reliable'; + is($foo_attr_type_constraint->parent, 'Object', '... got the right type constraint parent name'); +} +{ + package Bar::Meta::Attribute; + use Mouse; + + #extends 'Class::MOP::Attribute'; + extends 'Mouse::Meta::Attribute'; + + package Bar; + use Mouse; + + ::lives_ok { + has 'bar' => (metaclass => 'Bar::Meta::Attribute'); + } '... the attribute metaclass need not be a Mouse::Meta::Attribute as long as it behaves'; +} + +{ + package Mouse::Meta::Attribute::Custom::Foo; + sub register_implementation { 'Foo::Meta::Attribute' } + + package Mouse::Meta::Attribute::Custom::Bar; + use Mouse; + + extends 'Mouse::Meta::Attribute'; + + package Another::Foo; + use Mouse; + + ::lives_ok { + has 'foo' => (metaclass => 'Foo'); + } '... the attribute metaclass alias worked correctly'; + + ::lives_ok { + has 'bar' => (metaclass => 'Bar', is => 'bare'); + } '... the attribute metaclass alias worked correctly'; +} + +{ + my $foo_attr = Another::Foo->meta->get_attribute('foo'); + isa_ok($foo_attr, 'Foo::Meta::Attribute'); + isa_ok($foo_attr, 'Mouse::Meta::Attribute'); + + my $bar_attr = Another::Foo->meta->get_attribute('bar'); + isa_ok($bar_attr, 'Mouse::Meta::Attribute::Custom::Bar'); + isa_ok($bar_attr, 'Mouse::Meta::Attribute'); +} + + diff --git a/t/020_attributes/008_attribute_type_unions.t b/t/020_attributes/008_attribute_type_unions.t new file mode 100644 index 0000000..b1227a5 --- /dev/null +++ b/t/020_attributes/008_attribute_type_unions.t @@ -0,0 +1,99 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 18; +use Test::Exception; + + + +{ + package Foo; + use Mouse; + + has 'bar' => (is => 'rw', isa => 'ArrayRef | HashRef'); +} + +my $foo = Foo->new; +isa_ok($foo, 'Foo'); + +lives_ok { + $foo->bar([]) +} '... set bar successfully with an ARRAY ref'; + +lives_ok { + $foo->bar({}) +} '... set bar successfully with a HASH ref'; + +dies_ok { + $foo->bar(100) +} '... couldnt set bar successfully with a number'; + +dies_ok { + $foo->bar(sub {}) +} '... couldnt set bar successfully with a CODE ref'; + +# check the constructor + +lives_ok { + Foo->new(bar => []) +} '... created new Foo with bar successfully set with an ARRAY ref'; + +lives_ok { + Foo->new(bar => {}) +} '... created new Foo with bar successfully set with a HASH ref'; + +dies_ok { + Foo->new(bar => 50) +} '... didnt create a new Foo with bar as a number'; + +dies_ok { + Foo->new(bar => sub {}) +} '... didnt create a new Foo with bar as a CODE ref'; + +{ + package Bar; + use Mouse; + + has 'baz' => (is => 'rw', isa => 'Str | CodeRef'); +} + +my $bar = Bar->new; +isa_ok($bar, 'Bar'); + +lives_ok { + $bar->baz('a string') +} '... set baz successfully with a string'; + +lives_ok { + $bar->baz(sub { 'a sub' }) +} '... set baz successfully with a CODE ref'; + +dies_ok { + $bar->baz(\(my $var1)) +} '... couldnt set baz successfully with a SCALAR ref'; + +dies_ok { + $bar->baz({}) +} '... couldnt set bar successfully with a HASH ref'; + +# check the constructor + +lives_ok { + Bar->new(baz => 'a string') +} '... created new Bar with baz successfully set with a string'; + +lives_ok { + Bar->new(baz => sub { 'a sub' }) +} '... created new Bar with baz successfully set with a CODE ref'; + +dies_ok { + Bar->new(baz => \(my $var2)) +} '... didnt create a new Bar with baz as a number'; + +dies_ok { + Bar->new(baz => {}) +} '... didnt create a new Bar with baz as a HASH ref'; + + diff --git a/t/020_attributes/015_attribute_traits.t b/t/020_attributes/015_attribute_traits.t index 01e9741..1121d52 100644 --- a/t/020_attributes/015_attribute_traits.t +++ b/t/020_attributes/015_attribute_traits.t @@ -1,11 +1,9 @@ #!/usr/bin/perl -use lib 't/lib'; use strict; use warnings; use Test::More tests => 12; - use Test::Exception; use Test::Mouse; @@ -21,11 +19,9 @@ use Test::Mouse; after 'install_accessors' => sub { my $self = shift; - my $reader = $self->get_read_method_ref; - $self->associated_class->add_method( $self->alias_to, - $reader, + $self->get_read_method_ref ); }; } @@ -58,7 +54,6 @@ can_ok($c, 'baz'); is($c->baz, 100, '... got the right value for baz'); my $bar_attr = $c->meta->get_attribute('bar'); - does_ok($bar_attr, 'My::Attribute::Trait'); ok($bar_attr->has_applied_traits, '... got the applied traits'); is_deeply($bar_attr->applied_traits, [qw/My::Attribute::Trait/], '... got the applied traits'); diff --git a/t/020_attributes/016_attribute_traits_registered.t b/t/020_attributes/016_attribute_traits_registered.t index 1264c68..51640f9 100755 --- a/t/020_attributes/016_attribute_traits_registered.t +++ b/t/020_attributes/016_attribute_traits_registered.t @@ -5,10 +5,10 @@ use warnings; use Test::More tests => 23; use Test::Exception; - -use lib 't/lib'; use Test::Mouse; + + { package My::Attribute::Trait; use Mouse::Role; @@ -87,10 +87,7 @@ does_ok($bar_attr, 'My::Attribute::Trait'); is($bar_attr->foo, "blah", "attr initialized"); ok(!$bar_attr->meta->does_role('Aliased'), "does_role ignores aliases for sanity"); -{ - local $TODO = 'Mouse does not support ->does($aliased)'; - ok($bar_attr->does('Aliased'), "attr->does uses aliases"); -} +ok($bar_attr->does('Aliased'), "attr->does uses aliases"); ok(!$bar_attr->meta->does_role('Fictional'), "does_role returns false for nonexistent roles"); ok(!$bar_attr->does('Fictional'), "attr->does returns false for nonexistent roles"); @@ -111,10 +108,7 @@ does_ok($derived_bar_attr, 'My::Other::Attribute::Trait' ); is($derived_bar_attr->the_other_attr, "oink", "attr initialized" ); ok(!$derived_bar_attr->meta->does_role('Aliased'), "does_role ignores aliases for sanity"); -{ - local $TODO = 'Mouse does not support ->does($aliased)'; - ok($derived_bar_attr->does('Aliased'), "attr->does uses aliases"); -} +ok($derived_bar_attr->does('Aliased'), "attr->does uses aliases"); ok(!$derived_bar_attr->meta->does_role('Fictional'), "does_role returns false for nonexistent roles"); ok(!$derived_bar_attr->does('Fictional'), "attr->does returns false for nonexistent roles"); diff --git a/t/020_attributes/017_attribute_traits_n_meta.t b/t/020_attributes/017_attribute_traits_n_meta.t index 253a345..4f8b685 100755 --- a/t/020_attributes/017_attribute_traits_n_meta.t +++ b/t/020_attributes/017_attribute_traits_n_meta.t @@ -5,10 +5,10 @@ use warnings; use Test::More tests => 7; use Test::Exception; - -use lib 't/lib'; use Test::Mouse; + + { package My::Meta::Attribute::DefaultReadOnly; use Mouse; diff --git a/t/020_attributes/failing/001_attribute_reader_generation.t b/t/020_attributes/failing/001_attribute_reader_generation.t new file mode 100644 index 0000000..6e2f233 --- /dev/null +++ b/t/020_attributes/failing/001_attribute_reader_generation.t @@ -0,0 +1,87 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 20; +use Test::Exception; + + + +{ + package Foo; + use Mouse; + + eval { + has 'foo' => ( + reader => 'get_foo' + ); + }; + ::ok(!$@, '... created the reader method okay'); + + eval { + has 'lazy_foo' => ( + reader => 'get_lazy_foo', + lazy => 1, + default => sub { 10 } + ); + }; + ::ok(!$@, '... created the lazy reader method okay') or warn $@; + + my $warn; + + eval { + local $SIG{__WARN__} = sub { $warn = $_[0] }; + has 'mtfnpy' => ( + reder => 'get_mftnpy' + ); + }; + ::ok($warn, '... got a warning for mispelled attribute argument'); +} + +{ + my $foo = Foo->new; + isa_ok($foo, 'Foo'); + + can_ok($foo, 'get_foo'); + is($foo->get_foo(), undef, '... got an undefined value'); + dies_ok { + $foo->get_foo(100); + } '... get_foo is a read-only'; + + ok(!exists($foo->{lazy_foo}), '... no value in get_lazy_foo slot'); + + can_ok($foo, 'get_lazy_foo'); + is($foo->get_lazy_foo(), 10, '... got an deferred value'); + dies_ok { + $foo->get_lazy_foo(100); + } '... get_lazy_foo is a read-only'; +} + +{ + my $foo = Foo->new; + isa_ok($foo, 'Foo'); + + my $attr = $foo->meta->find_attribute_by_name("lazy_foo"); + + isa_ok( $attr, "Mouse::Meta::Attribute" ); + + ok( $attr->is_lazy, "it's lazy" ); + + is( $attr->get_raw_value($foo), undef, "raw value" ); + + is( $attr->get_value($foo), 10, "lazy value" ); + + is( $attr->get_raw_value($foo), 10, "raw value" ); +} + +{ + my $foo = Foo->new(foo => 10, lazy_foo => 100); + isa_ok($foo, 'Foo'); + + is($foo->get_foo(), 10, '... got the correct value'); + is($foo->get_lazy_foo(), 100, '... got the correct value'); +} + + + diff --git a/t/020_attributes/failing/004_attribute_triggers.t b/t/020_attributes/failing/004_attribute_triggers.t new file mode 100644 index 0000000..d7dd0e6 --- /dev/null +++ b/t/020_attributes/failing/004_attribute_triggers.t @@ -0,0 +1,222 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Scalar::Util 'isweak'; + +use Test::More tests => 43; +use Test::Exception; + + + +{ + package Foo; + use Mouse; + + has 'bar' => (is => 'rw', + isa => 'Maybe[Bar]', + trigger => sub { + my ($self, $bar) = @_; + $bar->foo($self) if defined $bar; + }); + + has 'baz' => (writer => 'set_baz', + reader => 'get_baz', + isa => 'Baz', + trigger => sub { + my ($self, $baz) = @_; + $baz->foo($self); + }); + + + package Bar; + use Mouse; + + has 'foo' => (is => 'rw', isa => 'Foo', weak_ref => 1); + + package Baz; + use Mouse; + + has 'foo' => (is => 'rw', isa => 'Foo', weak_ref => 1); +} + +{ + my $foo = Foo->new; + isa_ok($foo, 'Foo'); + + my $bar = Bar->new; + isa_ok($bar, 'Bar'); + + my $baz = Baz->new; + isa_ok($baz, 'Baz'); + + lives_ok { + $foo->bar($bar); + } '... did not die setting bar'; + + is($foo->bar, $bar, '... set the value foo.bar correctly'); + is($bar->foo, $foo, '... which in turn set the value bar.foo correctly'); + + ok(isweak($bar->{foo}), '... bar.foo is a weak reference'); + + lives_ok { + $foo->bar(undef); + } '... did not die un-setting bar'; + + is($foo->bar, undef, '... set the value foo.bar correctly'); + is($bar->foo, $foo, '... which in turn set the value bar.foo correctly'); + + # test the writer + + lives_ok { + $foo->set_baz($baz); + } '... did not die setting baz'; + + is($foo->get_baz, $baz, '... set the value foo.baz correctly'); + is($baz->foo, $foo, '... which in turn set the value baz.foo correctly'); + + ok(isweak($baz->{foo}), '... baz.foo is a weak reference'); +} + +{ + my $bar = Bar->new; + isa_ok($bar, 'Bar'); + + my $baz = Baz->new; + isa_ok($baz, 'Baz'); + + my $foo = Foo->new(bar => $bar, baz => $baz); + isa_ok($foo, 'Foo'); + + is($foo->bar, $bar, '... set the value foo.bar correctly'); + is($bar->foo, $foo, '... which in turn set the value bar.foo correctly'); + + ok(isweak($bar->{foo}), '... bar.foo is a weak reference'); + + is($foo->get_baz, $baz, '... set the value foo.baz correctly'); + is($baz->foo, $foo, '... which in turn set the value baz.foo correctly'); + + ok(isweak($baz->{foo}), '... baz.foo is a weak reference'); +} + +# some errors + +{ + package Bling; + use Mouse; + + ::dies_ok { + has('bling' => (is => 'rw', trigger => 'Fail')); + } '... a trigger must be a CODE ref'; + + ::dies_ok { + has('bling' => (is => 'rw', trigger => [])); + } '... a trigger must be a CODE ref'; +} + +# Triggers do not fire on built values + +{ + package Blarg; + use Mouse; + + our %trigger_calls; + our %trigger_vals; + has foo => (is => 'rw', default => sub { 'default foo value' }, + trigger => sub { my ($self, $val, $attr) = @_; + $trigger_calls{foo}++; + $trigger_vals{foo} = $val }); + has bar => (is => 'rw', lazy_build => 1, + trigger => sub { my ($self, $val, $attr) = @_; + $trigger_calls{bar}++; + $trigger_vals{bar} = $val }); + sub _build_bar { return 'default bar value' } + has baz => (is => 'rw', builder => '_build_baz', + trigger => sub { my ($self, $val, $attr) = @_; + $trigger_calls{baz}++; + $trigger_vals{baz} = $val }); + sub _build_baz { return 'default baz value' } +} + +{ + my $blarg; + lives_ok { $blarg = Blarg->new; } 'Blarg->new() lives'; + ok($blarg, 'Have a $blarg'); + foreach my $attr (qw/foo bar baz/) { + is($blarg->$attr(), "default $attr value", "$attr has default value"); + } + is_deeply(\%Blarg::trigger_calls, {}, 'No triggers fired'); + foreach my $attr (qw/foo bar baz/) { + $blarg->$attr("Different $attr value"); + } + is_deeply(\%Blarg::trigger_calls, { map { $_ => 1 } qw/foo bar baz/ }, 'All triggers fired once on assign'); + is_deeply(\%Blarg::trigger_vals, { map { $_ => "Different $_ value" } qw/foo bar baz/ }, 'All triggers given assigned values'); + + lives_ok { $blarg => Blarg->new( map { $_ => "Yet another $_ value" } qw/foo bar baz/ ) } '->new() with parameters'; + is_deeply(\%Blarg::trigger_calls, { map { $_ => 2 } qw/foo bar baz/ }, 'All triggers fired once on construct'); + is_deeply(\%Blarg::trigger_vals, { map { $_ => "Yet another $_ value" } qw/foo bar baz/ }, 'All triggers given assigned values'); +} + +# Triggers do not receive the meta-attribute as an argument, but do +# receive the old value + +{ + package Foo; + use Mouse; + our @calls; + has foo => (is => 'rw', trigger => sub { push @calls, [@_] }); +} + +{ + my $attr = Foo->meta->get_attribute('foo'); + + my $foo = Foo->new; + $attr->set_value( $foo, 2 ); + + is_deeply( + \@Foo::calls, + [ [ $foo, 2 ] ], + 'trigger called correctly on initial set via meta-API', + ); + @Foo::calls = (); + + $attr->set_value( $foo, 3 ); + + is_deeply( + \@Foo::calls, + [ [ $foo, 3, 2 ] ], + 'trigger called correctly on second set via meta-API', + ); + @Foo::calls = (); + + $attr->set_raw_value( $foo, 4 ); + + is_deeply( + \@Foo::calls, + [ ], + 'trigger not called using set_raw_value method', + ); + @Foo::calls = (); +} + +{ + my $foo = Foo->new(foo => 2); + is_deeply( + \@Foo::calls, + [ [ $foo, 2 ] ], + 'trigger called correctly on construction', + ); + @Foo::calls = (); + + $foo->foo(3); + is_deeply( + \@Foo::calls, + [ [ $foo, 3, 2 ] ], + 'trigger called correctly on set (with old value)', + ); + @Foo::calls = (); + Foo->meta->make_immutable, redo if Foo->meta->is_mutable; +} + + diff --git a/t/020_attributes/failing/009_attribute_inherited_slot_specs.t b/t/020_attributes/failing/009_attribute_inherited_slot_specs.t new file mode 100644 index 0000000..058331a --- /dev/null +++ b/t/020_attributes/failing/009_attribute_inherited_slot_specs.t @@ -0,0 +1,270 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 84; +use Test::Exception; + + + +{ + package Thing; + use Mouse; + + sub hello { 'Hello World (from Thing)' } + sub goodbye { 'Goodbye World (from Thing)' } + + package Foo; + use Mouse; + use Mouse::Util::TypeConstraints; + + subtype 'FooStr' + => as 'Str' + => where { /Foo/ }; + + coerce 'FooStr' + => from ArrayRef + => via { 'FooArrayRef' }; + + has 'bar' => (is => 'ro', isa => 'Str', default => 'Foo::bar'); + has 'baz' => (is => 'rw', isa => 'Ref'); + has 'foo' => (is => 'rw', isa => 'FooStr'); + + has 'gorch' => (is => 'ro'); + has 'gloum' => (is => 'ro', default => sub {[]}); + has 'fleem' => (is => 'ro'); + + has 'bling' => (is => 'ro', isa => 'Thing'); + has 'blang' => (is => 'ro', isa => 'Thing', handles => ['goodbye']); + + has 'bunch_of_stuff' => (is => 'rw', isa => 'ArrayRef'); + + has 'one_last_one' => (is => 'rw', isa => 'Ref'); + + # this one will work here .... + has 'fail' => (isa => 'CodeRef', is => 'bare'); + has 'other_fail' => (is => 'bare'); + + package Bar; + use Mouse; + use Mouse::Util::TypeConstraints; + + extends 'Foo'; + + ::lives_ok { + has '+bar' => (default => 'Bar::bar'); + } '... we can change the default attribute option'; + + ::lives_ok { + has '+baz' => (isa => 'ArrayRef'); + } '... we can add change the isa as long as it is a subtype'; + + ::lives_ok { + has '+foo' => (coerce => 1); + } '... we can change/add coerce as an attribute option'; + + ::lives_ok { + has '+gorch' => (required => 1); + } '... we can change/add required as an attribute option'; + + ::lives_ok { + has '+gloum' => (lazy => 1); + } '... we can change/add lazy as an attribute option'; + + ::lives_ok { + has '+gloum' => (lazy_build => 1); + } '... we can add lazy_build as an attribute option'; + + ::lives_ok { + has '+bunch_of_stuff' => (isa => 'ArrayRef[Int]'); + } '... extend an attribute with parameterized type'; + + ::lives_ok { + has '+one_last_one' => (isa => subtype('Ref', where { blessed $_ eq 'CODE' })); + } '... extend an attribute with anon-subtype'; + + ::lives_ok { + has '+one_last_one' => (isa => 'Value'); + } '... now can extend an attribute with a non-subtype'; + + ::lives_ok { + has '+fleem' => (weak_ref => 1); + } '... now allowed to add the weak_ref option via inheritance'; + + ::lives_ok { + has '+bling' => (handles => ['hello']); + } '... we can add the handles attribute option'; + + # this one will *not* work here .... + ::dies_ok { + has '+blang' => (handles => ['hello']); + } '... we can not alter the handles attribute option'; + ::lives_ok { + has '+fail' => (isa => 'Ref'); + } '... can now create an attribute with an improper subtype relation'; + ::dies_ok { + has '+other_fail' => (trigger => sub {}); + } '... cannot create an attribute with an illegal option'; + ::throws_ok { + has '+does_not_exist' => (isa => 'Str'); + } qr/in Bar/, '... cannot extend a non-existing attribute'; +} + +my $foo = Foo->new; +isa_ok($foo, 'Foo'); + +is($foo->foo, undef, '... got the right undef default value'); +lives_ok { $foo->foo('FooString') } '... assigned foo correctly'; +is($foo->foo, 'FooString', '... got the right value for foo'); + +dies_ok { $foo->foo([]) } '... foo is not coercing (as expected)'; + +is($foo->bar, 'Foo::bar', '... got the right default value'); +dies_ok { $foo->bar(10) } '... Foo::bar is a read/only attr'; + +is($foo->baz, undef, '... got the right undef default value'); + +{ + my $hash_ref = {}; + lives_ok { $foo->baz($hash_ref) } '... Foo::baz accepts hash refs'; + is($foo->baz, $hash_ref, '... got the right value assigned to baz'); + + my $array_ref = []; + lives_ok { $foo->baz($array_ref) } '... Foo::baz accepts an array ref'; + is($foo->baz, $array_ref, '... got the right value assigned to baz'); + + my $scalar_ref = \(my $var); + lives_ok { $foo->baz($scalar_ref) } '... Foo::baz accepts scalar ref'; + is($foo->baz, $scalar_ref, '... got the right value assigned to baz'); + + lives_ok { $foo->bunch_of_stuff([qw[one two three]]) } '... Foo::bunch_of_stuff accepts an array of strings'; + + lives_ok { $foo->one_last_one(sub { 'Hello World'}) } '... Foo::one_last_one accepts a code ref'; + + my $code_ref = sub { 1 }; + lives_ok { $foo->baz($code_ref) } '... Foo::baz accepts a code ref'; + is($foo->baz, $code_ref, '... got the right value assigned to baz'); +} + +dies_ok { + Bar->new; +} '... cannot create Bar without required gorch param'; + +my $bar = Bar->new(gorch => 'Bar::gorch'); +isa_ok($bar, 'Bar'); +isa_ok($bar, 'Foo'); + +is($bar->foo, undef, '... got the right undef default value'); +lives_ok { $bar->foo('FooString') } '... assigned foo correctly'; +is($bar->foo, 'FooString', '... got the right value for foo'); +lives_ok { $bar->foo([]) } '... assigned foo correctly'; +is($bar->foo, 'FooArrayRef', '... got the right value for foo'); + +is($bar->gorch, 'Bar::gorch', '... got the right default value'); + +is($bar->bar, 'Bar::bar', '... got the right default value'); +dies_ok { $bar->bar(10) } '... Bar::bar is a read/only attr'; + +is($bar->baz, undef, '... got the right undef default value'); + +{ + my $hash_ref = {}; + dies_ok { $bar->baz($hash_ref) } '... Bar::baz does not accept hash refs'; + + my $array_ref = []; + lives_ok { $bar->baz($array_ref) } '... Bar::baz can accept an array ref'; + is($bar->baz, $array_ref, '... got the right value assigned to baz'); + + my $scalar_ref = \(my $var); + dies_ok { $bar->baz($scalar_ref) } '... Bar::baz does not accept a scalar ref'; + + lives_ok { $bar->bunch_of_stuff([1, 2, 3]) } '... Bar::bunch_of_stuff accepts an array of ints'; + dies_ok { $bar->bunch_of_stuff([qw[one two three]]) } '... Bar::bunch_of_stuff does not accept an array of strings'; + + my $code_ref = sub { 1 }; + dies_ok { $bar->baz($code_ref) } '... Bar::baz does not accept a code ref'; +} + +# check some meta-stuff + +ok(Bar->meta->has_attribute('foo'), '... Bar has a foo attr'); +ok(Bar->meta->has_attribute('bar'), '... Bar has a bar attr'); +ok(Bar->meta->has_attribute('baz'), '... Bar has a baz attr'); +ok(Bar->meta->has_attribute('gorch'), '... Bar has a gorch attr'); +ok(Bar->meta->has_attribute('gloum'), '... Bar has a gloum attr'); +ok(Bar->meta->has_attribute('bling'), '... Bar has a bling attr'); +ok(Bar->meta->has_attribute('bunch_of_stuff'), '... Bar does have a bunch_of_stuff attr'); +{ +local $TODO = 'not supported'; +ok(!Bar->meta->has_attribute('blang'), '... Bar does not have a blang attr'); +} +ok(Bar->meta->has_attribute('fail'), '... Bar has a fail attr'); +{ +local $TODO = 'not supported'; +ok(!Bar->meta->has_attribute('other_fail'), '... Bar does not have an other_fail attr'); +} + +isnt(Foo->meta->get_attribute('foo'), + Bar->meta->get_attribute('foo'), + '... Foo and Bar have different copies of foo'); +isnt(Foo->meta->get_attribute('bar'), + Bar->meta->get_attribute('bar'), + '... Foo and Bar have different copies of bar'); +isnt(Foo->meta->get_attribute('baz'), + Bar->meta->get_attribute('baz'), + '... Foo and Bar have different copies of baz'); +isnt(Foo->meta->get_attribute('gorch'), + Bar->meta->get_attribute('gorch'), + '... Foo and Bar have different copies of gorch'); +isnt(Foo->meta->get_attribute('gloum'), + Bar->meta->get_attribute('gloum'), + '... Foo and Bar have different copies of gloum'); +isnt(Foo->meta->get_attribute('bling'), + Bar->meta->get_attribute('bling'), + '... Foo and Bar have different copies of bling'); +isnt(Foo->meta->get_attribute('bunch_of_stuff'), + Bar->meta->get_attribute('bunch_of_stuff'), + '... Foo and Bar have different copies of bunch_of_stuff'); + +ok(Bar->meta->get_attribute('bar')->has_type_constraint, + '... Bar::bar inherited the type constraint too'); +ok(Bar->meta->get_attribute('baz')->has_type_constraint, + '... Bar::baz inherited the type constraint too'); + +is(Bar->meta->get_attribute('bar')->type_constraint->name, + 'Str', '... Bar::bar inherited the right type constraint too'); + +is(Foo->meta->get_attribute('baz')->type_constraint->name, + 'Ref', '... Foo::baz inherited the right type constraint too'); +is(Bar->meta->get_attribute('baz')->type_constraint->name, + 'ArrayRef', '... Bar::baz inherited the right type constraint too'); + +ok(!Foo->meta->get_attribute('gorch')->is_required, + '... Foo::gorch is not a required attr'); +ok(Bar->meta->get_attribute('gorch')->is_required, + '... Bar::gorch is a required attr'); + +is(Foo->meta->get_attribute('bunch_of_stuff')->type_constraint->name, + 'ArrayRef', + '... Foo::bunch_of_stuff is an ArrayRef'); +is(Bar->meta->get_attribute('bunch_of_stuff')->type_constraint->name, + 'ArrayRef[Int]', + '... Bar::bunch_of_stuff is an ArrayRef[Int]'); + +ok(!Foo->meta->get_attribute('gloum')->is_lazy, + '... Foo::gloum is not a required attr'); +ok(Bar->meta->get_attribute('gloum')->is_lazy, + '... Bar::gloum is a required attr'); + +ok(!Foo->meta->get_attribute('foo')->should_coerce, + '... Foo::foo should not coerce'); +ok(Bar->meta->get_attribute('foo')->should_coerce, + '... Bar::foo should coerce'); + +ok(!Foo->meta->get_attribute('bling')->has_handles, + '... Foo::foo should not handles'); +ok(Bar->meta->get_attribute('bling')->has_handles, + '... Bar::foo should handles'); + + diff --git a/t/020_attributes/failing/010_attribute_delegation.t b/t/020_attributes/failing/010_attribute_delegation.t new file mode 100644 index 0000000..9dd746a --- /dev/null +++ b/t/020_attributes/failing/010_attribute_delegation.t @@ -0,0 +1,436 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 92; +use Test::Exception; + + + +# ------------------------------------------------------------------- +# HASH handles +# ------------------------------------------------------------------- +# the canonical form of of the 'handles' +# option is the hash ref mapping a +# method name to the delegated method name + +{ + package Foo; + use Mouse; + + has 'bar' => (is => 'rw', default => 10); + + sub baz { 42 } + + package Bar; + use Mouse; + + has 'foo' => ( + is => 'rw', + default => sub { Foo->new }, + handles => { + 'foo_bar' => 'bar', + foo_baz => 'baz', + 'foo_bar_to_20' => [ bar => 20 ], + }, + ); +} + +my $bar = Bar->new; +isa_ok($bar, 'Bar'); + +ok($bar->foo, '... we have something in bar->foo'); +isa_ok($bar->foo, 'Foo'); + +my $meth = Bar->meta->get_method('foo_bar'); +isa_ok($meth, 'Mouse::Meta::Method::Delegation'); +is($meth->associated_attribute->name, 'foo', + 'associated_attribute->name for this method is foo'); + +is($bar->foo->bar, 10, '... bar->foo->bar returned the right default'); + +can_ok($bar, 'foo_bar'); +is($bar->foo_bar, 10, '... bar->foo_bar delegated correctly'); + +# change the value ... + +$bar->foo->bar(30); + +# and make sure the delegation picks it up + +is($bar->foo->bar, 30, '... bar->foo->bar returned the right (changed) value'); +is($bar->foo_bar, 30, '... bar->foo_bar delegated correctly'); + +# change the value through the delegation ... + +$bar->foo_bar(50); + +# and make sure everyone sees it + +is($bar->foo->bar, 50, '... bar->foo->bar returned the right (changed) value'); +is($bar->foo_bar, 50, '... bar->foo_bar delegated correctly'); + +# change the object we are delegating too + +my $foo = Foo->new(bar => 25); +isa_ok($foo, 'Foo'); + +is($foo->bar, 25, '... got the right foo->bar'); + +lives_ok { + $bar->foo($foo); +} '... assigned the new Foo to Bar->foo'; + +is($bar->foo, $foo, '... assigned bar->foo with the new Foo'); + +is($bar->foo->bar, 25, '... bar->foo->bar returned the right result'); +is($bar->foo_bar, 25, '... and bar->foo_bar delegated correctly again'); + +# curried handles +$bar->foo_bar_to_20; +is($bar->foo_bar, 20, '... correctly curried a single argument'); + +# ------------------------------------------------------------------- +# ARRAY handles +# ------------------------------------------------------------------- +# we also support an array based format +# which assumes that the name is the same +# on either end + +{ + package Engine; + use Mouse; + + sub go { 'Engine::go' } + sub stop { 'Engine::stop' } + + package Car; + use Mouse; + + has 'engine' => ( + is => 'rw', + default => sub { Engine->new }, + handles => [ 'go', 'stop' ] + ); +} + +my $car = Car->new; +isa_ok($car, 'Car'); + +isa_ok($car->engine, 'Engine'); +can_ok($car->engine, 'go'); +can_ok($car->engine, 'stop'); + +is($car->engine->go, 'Engine::go', '... got the right value from ->engine->go'); +is($car->engine->stop, 'Engine::stop', '... got the right value from ->engine->stop'); + +can_ok($car, 'go'); +can_ok($car, 'stop'); + +is($car->go, 'Engine::go', '... got the right value from ->go'); +is($car->stop, 'Engine::stop', '... got the right value from ->stop'); + +# ------------------------------------------------------------------- +# REGEXP handles +# ------------------------------------------------------------------- +# and we support regexp delegation + +{ + package Baz; + use Mouse; + + sub foo { 'Baz::foo' } + sub bar { 'Baz::bar' } + sub boo { 'Baz::boo' } + + package Baz::Proxy1; + use Mouse; + + has 'baz' => ( + is => 'ro', + isa => 'Baz', + default => sub { Baz->new }, + handles => qr/.*/ + ); + + package Baz::Proxy2; + use Mouse; + + has 'baz' => ( + is => 'ro', + isa => 'Baz', + default => sub { Baz->new }, + handles => qr/.oo/ + ); + + package Baz::Proxy3; + use Mouse; + + has 'baz' => ( + is => 'ro', + isa => 'Baz', + default => sub { Baz->new }, + handles => qr/b.*/ + ); +} + +{ + my $baz_proxy = Baz::Proxy1->new; + isa_ok($baz_proxy, 'Baz::Proxy1'); + + can_ok($baz_proxy, 'baz'); + isa_ok($baz_proxy->baz, 'Baz'); + + can_ok($baz_proxy, 'foo'); + can_ok($baz_proxy, 'bar'); + can_ok($baz_proxy, 'boo'); + + is($baz_proxy->foo, 'Baz::foo', '... got the right proxied return value'); + is($baz_proxy->bar, 'Baz::bar', '... got the right proxied return value'); + is($baz_proxy->boo, 'Baz::boo', '... got the right proxied return value'); +} +{ + my $baz_proxy = Baz::Proxy2->new; + isa_ok($baz_proxy, 'Baz::Proxy2'); + + can_ok($baz_proxy, 'baz'); + isa_ok($baz_proxy->baz, 'Baz'); + + can_ok($baz_proxy, 'foo'); + can_ok($baz_proxy, 'boo'); + + is($baz_proxy->foo, 'Baz::foo', '... got the right proxied return value'); + is($baz_proxy->boo, 'Baz::boo', '... got the right proxied return value'); +} +{ + my $baz_proxy = Baz::Proxy3->new; + isa_ok($baz_proxy, 'Baz::Proxy3'); + + can_ok($baz_proxy, 'baz'); + isa_ok($baz_proxy->baz, 'Baz'); + + can_ok($baz_proxy, 'bar'); + can_ok($baz_proxy, 'boo'); + + is($baz_proxy->bar, 'Baz::bar', '... got the right proxied return value'); + is($baz_proxy->boo, 'Baz::boo', '... got the right proxied return value'); +} + +# ------------------------------------------------------------------- +# ROLE handles +# ------------------------------------------------------------------- + +{ + package Foo::Bar; + use Mouse::Role; + + requires 'foo'; + requires 'bar'; + + package Foo::Baz; + use Mouse; + + sub foo { 'Foo::Baz::FOO' } + sub bar { 'Foo::Baz::BAR' } + sub baz { 'Foo::Baz::BAZ' } + + package Foo::Thing; + use Mouse; + + has 'thing' => ( + is => 'rw', + isa => 'Foo::Baz', + handles => 'Foo::Bar', + ); + +} + +{ + my $foo = Foo::Thing->new(thing => Foo::Baz->new); + isa_ok($foo, 'Foo::Thing'); + isa_ok($foo->thing, 'Foo::Baz'); + + ok($foo->meta->has_method('foo'), '... we have the method we expect'); + ok($foo->meta->has_method('bar'), '... we have the method we expect'); + ok(!$foo->meta->has_method('baz'), '... we dont have the method we expect'); + + is($foo->foo, 'Foo::Baz::FOO', '... got the right value'); + is($foo->bar, 'Foo::Baz::BAR', '... got the right value'); + is($foo->thing->baz, 'Foo::Baz::BAZ', '... got the right value'); +} + +# ------------------------------------------------------------------- +# AUTOLOAD & handles +# ------------------------------------------------------------------- + +{ + package Foo::Autoloaded; + use Mouse; + + sub AUTOLOAD { + my $self = shift; + + my $name = our $AUTOLOAD; + $name =~ s/.*://; # strip fully-qualified portion + + if (@_) { + return $self->{$name} = shift; + } else { + return $self->{$name}; + } + } + + package Bar::Autoloaded; + use Mouse; + + has 'foo' => ( + is => 'rw', + default => sub { Foo::Autoloaded->new }, + handles => { 'foo_bar' => 'bar' } + ); + + package Baz::Autoloaded; + use Mouse; + + has 'foo' => ( + is => 'rw', + default => sub { Foo::Autoloaded->new }, + handles => ['bar'] + ); + + package Goorch::Autoloaded; + use Mouse; + + ::dies_ok { + has 'foo' => ( + is => 'rw', + default => sub { Foo::Autoloaded->new }, + handles => qr/bar/ + ); + } '... you cannot delegate to AUTOLOADED class with regexp'; +} + +# check HASH based delegation w/ AUTOLOAD + +{ + my $bar = Bar::Autoloaded->new; + isa_ok($bar, 'Bar::Autoloaded'); + + ok($bar->foo, '... we have something in bar->foo'); + isa_ok($bar->foo, 'Foo::Autoloaded'); + + # change the value ... + + $bar->foo->bar(30); + + # and make sure the delegation picks it up + + is($bar->foo->bar, 30, '... bar->foo->bar returned the right (changed) value'); + is($bar->foo_bar, 30, '... bar->foo_bar delegated correctly'); + + # change the value through the delegation ... + + $bar->foo_bar(50); + + # and make sure everyone sees it + + is($bar->foo->bar, 50, '... bar->foo->bar returned the right (changed) value'); + is($bar->foo_bar, 50, '... bar->foo_bar delegated correctly'); + + # change the object we are delegating too + + my $foo = Foo::Autoloaded->new; + isa_ok($foo, 'Foo::Autoloaded'); + + $foo->bar(25); + + is($foo->bar, 25, '... got the right foo->bar'); + + lives_ok { + $bar->foo($foo); + } '... assigned the new Foo to Bar->foo'; + + is($bar->foo, $foo, '... assigned bar->foo with the new Foo'); + + is($bar->foo->bar, 25, '... bar->foo->bar returned the right result'); + is($bar->foo_bar, 25, '... and bar->foo_bar delegated correctly again'); +} + +# check ARRAY based delegation w/ AUTOLOAD + +{ + my $baz = Baz::Autoloaded->new; + isa_ok($baz, 'Baz::Autoloaded'); + + ok($baz->foo, '... we have something in baz->foo'); + isa_ok($baz->foo, 'Foo::Autoloaded'); + + # change the value ... + + $baz->foo->bar(30); + + # and make sure the delegation picks it up + + is($baz->foo->bar, 30, '... baz->foo->bar returned the right (changed) value'); + is($baz->bar, 30, '... baz->foo_bar delegated correctly'); + + # change the value through the delegation ... + + $baz->bar(50); + + # and make sure everyone sees it + + is($baz->foo->bar, 50, '... baz->foo->bar returned the right (changed) value'); + is($baz->bar, 50, '... baz->foo_bar delegated correctly'); + + # change the object we are delegating too + + my $foo = Foo::Autoloaded->new; + isa_ok($foo, 'Foo::Autoloaded'); + + $foo->bar(25); + + is($foo->bar, 25, '... got the right foo->bar'); + + lives_ok { + $baz->foo($foo); + } '... assigned the new Foo to Baz->foo'; + + is($baz->foo, $foo, '... assigned baz->foo with the new Foo'); + + is($baz->foo->bar, 25, '... baz->foo->bar returned the right result'); + is($baz->bar, 25, '... and baz->foo_bar delegated correctly again'); +} + +# Check that removing attributes removes their handles methods also. +{ + { + package Quux; + use Mouse; + has foo => ( + isa => 'Foo', + default => sub { Foo->new }, + handles => { 'foo_bar' => 'bar' } + ); + } + my $i = Quux->new; + ok($i->meta->has_method('foo_bar'), 'handles method foo_bar is present'); + $i->meta->remove_attribute('foo'); + ok(!$i->meta->has_method('foo_bar'), 'handles method foo_bar is removed'); +} + +# Make sure that a useful error message is thrown when the delegation target is +# not an object +{ + my $i = Bar->new(foo => undef); + throws_ok { $i->foo_bar } qr/is not defined/, + 'useful error from unblessed reference'; + + my $j = Bar->new(foo => []); + throws_ok { $j->foo_bar } qr/is not an object \(got 'ARRAY/, + 'useful error from unblessed reference'; + + my $k = Bar->new(foo => "Foo"); + lives_ok { $k->foo_baz } "but not for class name"; +} diff --git a/t/020_attributes/failing/011_more_attr_delegation.t b/t/020_attributes/failing/011_more_attr_delegation.t new file mode 100644 index 0000000..75d6fa1 --- /dev/null +++ b/t/020_attributes/failing/011_more_attr_delegation.t @@ -0,0 +1,217 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 39; +use Test::Exception; + +=pod + +This tests the more complex +delegation cases and that they +do not fail at compile time. + +=cut + +{ + + package ChildASuper; + use Mouse; + + sub child_a_super_method { "as" } + + package ChildA; + use Mouse; + + extends "ChildASuper"; + + sub child_a_method_1 { "a1" } + sub child_a_method_2 { Scalar::Util::blessed($_[0]) . " a2" } + + package ChildASub; + use Mouse; + + extends "ChildA"; + + sub child_a_method_3 { "a3" } + + package ChildB; + use Mouse; + + sub child_b_method_1 { "b1" } + sub child_b_method_2 { "b2" } + sub child_b_method_3 { "b3" } + + package ChildC; + use Mouse; + + sub child_c_method_1 { "c1" } + sub child_c_method_2 { "c2" } + sub child_c_method_3_la { "c3" } + sub child_c_method_4_la { "c4" } + + package ChildD; + use Mouse; + + sub child_d_method_1 { "d1" } + sub child_d_method_2 { "d2" } + + package ChildE; + # no Mouse + + sub new { bless {}, shift } + sub child_e_method_1 { "e1" } + sub child_e_method_2 { "e2" } + + package ChildF; + # no Mouse + + sub new { bless {}, shift } + sub child_f_method_1 { "f1" } + sub child_f_method_2 { "f2" } + + package ChildG; + use Mouse; + + sub child_g_method_1 { "g1" } + + package Parent; + use Mouse; + + ::dies_ok { + has child_a => ( + is => "ro", + default => sub { ChildA->new }, + handles => qr/.*/, + ); + } "all_methods requires explicit isa"; + + ::lives_ok { + has child_a => ( + isa => "ChildA", + is => "ro", + default => sub { ChildA->new }, + handles => qr/.*/, + ); + } "allow all_methods with explicit isa"; + + ::lives_ok { + has child_b => ( + is => 'ro', + default => sub { ChildB->new }, + handles => [qw/child_b_method_1/], + ); + } "don't need to declare isa if method list is predefined"; + + ::lives_ok { + has child_c => ( + isa => "ChildC", + is => "ro", + default => sub { ChildC->new }, + handles => qr/_la$/, + ); + } "can declare regex collector"; + + ::dies_ok { + has child_d => ( + is => "ro", + default => sub { ChildD->new }, + handles => sub { + my ( $class, $delegate_class ) = @_; + } + ); + } "can't create attr with generative handles parameter and no isa"; + + ::lives_ok { + has child_d => ( + isa => "ChildD", + is => "ro", + default => sub { ChildD->new }, + handles => sub { + my ( $class, $delegate_class ) = @_; + return; + } + ); + } "can't create attr with generative handles parameter and no isa"; + + ::lives_ok { + has child_e => ( + isa => "ChildE", + is => "ro", + default => sub { ChildE->new }, + handles => ["child_e_method_2"], + ); + } "can delegate to non moose class using explicit method list"; + + my $delegate_class; + ::lives_ok { + has child_f => ( + isa => "ChildF", + is => "ro", + default => sub { ChildF->new }, + handles => sub { + $delegate_class = $_[1]->name; + return; + }, + ); + } "subrefs on non moose class give no meta"; + + ::is( $delegate_class, "ChildF", "plain classes are handed down to subs" ); + + ::lives_ok { + has child_g => ( + isa => "ChildG", + default => sub { ChildG->new }, + handles => ["child_g_method_1"], + ); + } "can delegate to object even without explicit reader"; + + sub parent_method { "p" } +} + +# sanity + +isa_ok( my $p = Parent->new, "Parent" ); +isa_ok( $p->child_a, "ChildA" ); +isa_ok( $p->child_b, "ChildB" ); +isa_ok( $p->child_c, "ChildC" ); +isa_ok( $p->child_d, "ChildD" ); +isa_ok( $p->child_e, "ChildE" ); +isa_ok( $p->child_f, "ChildF" ); + +ok(!$p->can('child_g'), '... no child_g accessor defined'); + + +is( $p->parent_method, "p", "parent method" ); +is( $p->child_a->child_a_super_method, "as", "child supermethod" ); +is( $p->child_a->child_a_method_1, "a1", "child method" ); + +can_ok( $p, "child_a_super_method" ); +can_ok( $p, "child_a_method_1" ); +can_ok( $p, "child_a_method_2" ); +ok( !$p->can( "child_a_method_3" ), "but not subclass of delegate class" ); + +is( $p->child_a_method_1, $p->child_a->child_a_method_1, "delegate behaves the same" ); +is( $p->child_a_method_2, "ChildA a2", "delegates are their own invocants" ); + + +can_ok( $p, "child_b_method_1" ); +ok( !$p->can("child_b_method_2"), "but not ChildB's unspecified siblings" ); + + +ok( !$p->can($_), "none of ChildD's methods ($_)" ) + for grep { /^child/ } map { $_->name } ChildD->meta->get_all_methods(); + +can_ok( $p, "child_c_method_3_la" ); +can_ok( $p, "child_c_method_4_la" ); + +is( $p->child_c_method_3_la, "c3", "ChildC method delegated OK" ); + +can_ok( $p, "child_e_method_2" ); +ok( !$p->can("child_e_method_1"), "but not child_e_method_1"); + +is( $p->child_e_method_2, "e2", "delegate to non moose class (child_e_method_2)" ); + +can_ok( $p, "child_g_method_1" ); +is( $p->child_g_method_1, "g1", "delegate to moose class without reader (child_g_method_1)" ); diff --git a/t/020_attributes/failing/012_misc_attribute_tests.t b/t/020_attributes/failing/012_misc_attribute_tests.t new file mode 100644 index 0000000..ac46d5a --- /dev/null +++ b/t/020_attributes/failing/012_misc_attribute_tests.t @@ -0,0 +1,279 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 43; +use Test::Exception; + +use lib 't/lib'; +use Test::Mouse; + +{ + { + package Test::Attribute::Inline::Documentation; + use Mouse; + + has 'foo' => ( + documentation => q{ + The 'foo' attribute is my favorite + attribute in the whole wide world. + }, + is => 'bare', + ); + } + + my $foo_attr = Test::Attribute::Inline::Documentation->meta->get_attribute('foo'); + + ok($foo_attr->has_documentation, '... the foo has docs'); + is($foo_attr->documentation, + q{ + The 'foo' attribute is my favorite + attribute in the whole wide world. + }, + '... got the foo docs'); +} + +{ + { + package Test::For::Lazy::TypeConstraint; + use Mouse; + use Mouse::Util::TypeConstraints; + + has 'bad_lazy_attr' => ( + is => 'rw', + isa => 'ArrayRef', + lazy => 1, + default => sub { "test" }, + ); + + has 'good_lazy_attr' => ( + is => 'rw', + isa => 'ArrayRef', + lazy => 1, + default => sub { [] }, + ); + + } + + my $test = Test::For::Lazy::TypeConstraint->new; + isa_ok($test, 'Test::For::Lazy::TypeConstraint'); + + dies_ok { + $test->bad_lazy_attr; + } '... this does not work'; + + lives_ok { + $test->good_lazy_attr; + } '... this does work'; +} + +{ + { + package Test::Arrayref::Attributes; + use Mouse; + + has [qw(foo bar baz)] => ( + is => 'rw', + ); + + } + + my $test = Test::Arrayref::Attributes->new; + isa_ok($test, 'Test::Arrayref::Attributes'); + can_ok($test, qw(foo bar baz)); + +} + +{ + { + package Test::Arrayref::RoleAttributes::Role; + use Mouse::Role; + + has [qw(foo bar baz)] => ( + is => 'rw', + ); + + } + { + package Test::Arrayref::RoleAttributes; + use Mouse; + with 'Test::Arrayref::RoleAttributes::Role'; + } + + my $test = Test::Arrayref::RoleAttributes->new; + isa_ok($test, 'Test::Arrayref::RoleAttributes'); + can_ok($test, qw(foo bar baz)); + +} + +{ + { + package Test::UndefDefault::Attributes; + use Mouse; + + has 'foo' => ( + is => 'ro', + isa => 'Str', + default => sub { return } + ); + + } + + dies_ok { + Test::UndefDefault::Attributes->new; + } '... default must return a value which passes the type constraint'; + +} + +{ + { + package OverloadedStr; + use Mouse; + use overload '""' => sub { 'this is *not* a string' }; + + has 'a_str' => ( isa => 'Str' , is => 'rw' ); + } + + my $moose_obj = OverloadedStr->new; + + is($moose_obj->a_str( 'foobar' ), 'foobar', 'setter took string'); + ok($moose_obj, 'this is a *not* a string'); + + throws_ok { + $moose_obj->a_str( $moose_obj ) + } qr/Attribute \(a_str\) does not pass the type constraint because\: Validation failed for 'Str' failed with value OverloadedStr=HASH\(0x.+?\)/, + '... dies without overloading the string'; + +} + +{ + { + package OverloadBreaker; + use Mouse; + + has 'a_num' => ( isa => 'Int' , is => 'rw', default => 7.5 ); + } + + throws_ok { + OverloadBreaker->new; + } qr/Attribute \(a_num\) does not pass the type constraint because\: Validation failed for 'Int' failed with value 7\.5/, + '... this doesnt trip overload to break anymore '; + + lives_ok { + OverloadBreaker->new(a_num => 5); + } '... this works fine though'; + +} + +{ + { + package Test::Builder::Attribute; + use Mouse; + + has 'foo' => ( required => 1, builder => 'build_foo', is => 'ro'); + sub build_foo { return "works" }; + } + + my $meta = Test::Builder::Attribute->meta; + my $foo_attr = $meta->get_attribute("foo"); + + ok($foo_attr->is_required, "foo is required"); + ok($foo_attr->has_builder, "foo has builder"); + is($foo_attr->builder, "build_foo", ".. and it's named build_foo"); + + my $instance = Test::Builder::Attribute->new; + is($instance->foo, 'works', "foo builder works"); +} + +{ + { + package Test::Builder::Attribute::Broken; + use Mouse; + + has 'foo' => ( required => 1, builder => 'build_foo', is => 'ro'); + } + + dies_ok { + Test::Builder::Attribute::Broken->new; + } '... no builder, wtf'; +} + + +{ + { + package Test::LazyBuild::Attribute; + use Mouse; + + has 'foo' => ( lazy_build => 1, is => 'ro'); + has '_foo' => ( lazy_build => 1, is => 'ro'); + has 'fool' => ( lazy_build => 1, is => 'ro'); + sub _build_foo { return "works" }; + sub _build__foo { return "works too" }; + } + + my $meta = Test::LazyBuild::Attribute->meta; + my $foo_attr = $meta->get_attribute("foo"); + my $_foo_attr = $meta->get_attribute("_foo"); + + ok($foo_attr->is_lazy, "foo is lazy"); + ok($foo_attr->is_lazy_build, "foo is lazy_build"); + + ok($foo_attr->has_clearer, "foo has clearer"); + is($foo_attr->clearer, "clear_foo", ".. and it's named clear_foo"); + + ok($foo_attr->has_builder, "foo has builder"); + is($foo_attr->builder, "_build_foo", ".. and it's named build_foo"); + + ok($foo_attr->has_predicate, "foo has predicate"); + is($foo_attr->predicate, "has_foo", ".. and it's named has_foo"); + + ok($_foo_attr->is_lazy, "_foo is lazy"); + ok(!$_foo_attr->is_required, "lazy_build attributes are no longer automatically required"); + ok($_foo_attr->is_lazy_build, "_foo is lazy_build"); + + ok($_foo_attr->has_clearer, "_foo has clearer"); + is($_foo_attr->clearer, "_clear_foo", ".. and it's named _clear_foo"); + + ok($_foo_attr->has_builder, "_foo has builder"); + is($_foo_attr->builder, "_build__foo", ".. and it's named _build_foo"); + + ok($_foo_attr->has_predicate, "_foo has predicate"); + is($_foo_attr->predicate, "_has_foo", ".. and it's named _has_foo"); + + my $instance = Test::LazyBuild::Attribute->new; + ok(!$instance->has_foo, "noo foo value yet"); + ok(!$instance->_has_foo, "noo _foo value yet"); + is($instance->foo, 'works', "foo builder works"); + is($instance->_foo, 'works too', "foo builder works too"); + dies_ok { $instance->fool } +# throws_ok { $instance->fool } +# qr/Test::LazyBuild::Attribute does not support builder method \'_build_fool\' for attribute \'fool\'/, + "Correct error when a builder method is not present"; + +} + +{ + package OutOfClassTest; + + use Mouse; +} + +# Mouse::Exporter does not support 'with_meta' +#lives_ok { OutOfClassTest::has('foo', is => 'bare'); } 'create attr via direct sub call'; +#lives_ok { OutOfClassTest->can('has')->('bar', is => 'bare'); } 'create attr via can'; + +#ok(OutOfClassTest->meta->get_attribute('foo'), 'attr created from sub call'); +#ok(OutOfClassTest->meta->get_attribute('bar'), 'attr created from can'); + + +{ + { + package Foo; + use Mouse; + + ::throws_ok { has 'foo' => ( 'ro', isa => 'Str' ) } + qr/^Usage/, 'has throws error with odd number of attribute options'; + } + +} diff --git a/t/020_attributes/failing/013_attr_dereference_test.t b/t/020_attributes/failing/013_attr_dereference_test.t new file mode 100644 index 0000000..7389df8 --- /dev/null +++ b/t/020_attributes/failing/013_attr_dereference_test.t @@ -0,0 +1,81 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 11; +use Test::Exception; + + + +{ + package Customer; + use Mouse; + + package Firm; + use Mouse; + use Mouse::Util::TypeConstraints; + + ::lives_ok { + has 'customers' => ( + is => 'ro', + isa => subtype('ArrayRef' => where { + (blessed($_) && $_->isa('Customer') || return) for @$_; 1 }), + auto_deref => 1, + ); + } '... successfully created attr'; +} + +{ + my $customer = Customer->new; + isa_ok($customer, 'Customer'); + + my $firm = Firm->new(customers => [ $customer ]); + isa_ok($firm, 'Firm'); + + can_ok($firm, 'customers'); + + is_deeply( + [ $firm->customers ], + [ $customer ], + '... got the right dereferenced value' + ); +} + +{ + my $firm = Firm->new(); + isa_ok($firm, 'Firm'); + + can_ok($firm, 'customers'); + + is_deeply( + [ $firm->customers ], + [], + '... got the right dereferenced value' + ); +} + +{ + package AutoDeref; + use Mouse; + + has 'bar' => ( + is => 'rw', + isa => 'ArrayRef[Int]', + auto_deref => 1, + ); +} + +{ + my $autoderef = AutoDeref->new; + + dies_ok { + $autoderef->bar(1, 2, 3); + } '... its auto-de-ref-ing, not auto-en-ref-ing'; + + lives_ok { + $autoderef->bar([ 1, 2, 3 ]) + } '... set the results of bar correctly'; + + is_deeply [ $autoderef->bar ], [ 1, 2, 3 ], '... auto-dereffed correctly'; +} diff --git a/t/020_attributes/failing/014_misc_attribute_coerce_lazy.t b/t/020_attributes/failing/014_misc_attribute_coerce_lazy.t new file mode 100644 index 0000000..ccd8883 --- /dev/null +++ b/t/020_attributes/failing/014_misc_attribute_coerce_lazy.t @@ -0,0 +1,51 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 2; +use Test::Exception; + + + +{ + package HTTPHeader; + use Mouse; + + has 'array' => (is => 'ro'); + has 'hash' => (is => 'ro'); +} + +{ + package Request; + use Mouse; + use Mouse::Util::TypeConstraints; + + subtype Header => + => as Object + => where { $_->isa('HTTPHeader') }; + + coerce Header + => from ArrayRef + => via { HTTPHeader->new(array => $_[0]) } + => from HashRef + => via { HTTPHeader->new(hash => $_[0]) }; + + has 'headers' => ( + is => 'rw', + isa => 'Header', + coerce => 1, + lazy => 1, + default => sub { [ 'content-type', 'text/html' ] } + ); +} + +my $r = Request->new; +isa_ok($r, 'Request'); + +lives_ok { + $r->headers; +} '... this coerces and passes the type constraint even with lazy'; + + + diff --git a/t/020_attributes/failing/018_no_init_arg.t b/t/020_attributes/failing/018_no_init_arg.t new file mode 100644 index 0000000..40b53cc --- /dev/null +++ b/t/020_attributes/failing/018_no_init_arg.t @@ -0,0 +1,33 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 4; +use Test::Exception; + + + +{ + package Foo; + use Mouse; + + eval { + has 'foo' => ( + is => "rw", + init_arg => undef, + ); + }; + ::ok(!$@, '... created the attr okay'); +} + +{ + my $foo = Foo->new( foo => "bar" ); + isa_ok($foo, 'Foo'); + + is( $foo->foo, undef, "field is not set via init arg" ); + + $foo->foo("blah"); + + is( $foo->foo, "blah", "field is set via setter" ); +} diff --git a/t/020_attributes/failing/019_attribute_lazy_initializer.t b/t/020_attributes/failing/019_attribute_lazy_initializer.t new file mode 100644 index 0000000..5e72276 --- /dev/null +++ b/t/020_attributes/failing/019_attribute_lazy_initializer.t @@ -0,0 +1,150 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 23; +use Test::Exception; + + + +{ + package Foo; + use Mouse; + + has 'foo' => ( + reader => 'get_foo', + writer => 'set_foo', + initializer => sub { + my ($self, $value, $callback, $attr) = @_; + + ::isa_ok($attr, 'Mouse::Meta::Attribute'); + ::is($attr->name, 'foo', '... got the right name'); + + $callback->($value * 2); + }, + ); + + has 'lazy_foo' => ( + reader => 'get_lazy_foo', + lazy => 1, + default => 10, + initializer => sub { + my ($self, $value, $callback, $attr) = @_; + + ::isa_ok($attr, 'Mouse::Meta::Attribute'); + ::is($attr->name, 'lazy_foo', '... got the right name'); + + $callback->($value * 2); + }, + ); + + has 'lazy_foo_w_type' => ( + reader => 'get_lazy_foo_w_type', + isa => 'Int', + lazy => 1, + default => 20, + initializer => sub { + my ($self, $value, $callback, $attr) = @_; + + ::isa_ok($attr, 'Mouse::Meta::Attribute'); + ::is($attr->name, 'lazy_foo_w_type', '... got the right name'); + + $callback->($value * 2); + }, + ); + + has 'lazy_foo_builder' => ( + reader => 'get_lazy_foo_builder', + builder => 'get_foo_builder', + initializer => sub { + my ($self, $value, $callback, $attr) = @_; + + ::isa_ok($attr, 'Mouse::Meta::Attribute'); + ::is($attr->name, 'lazy_foo_builder', '... got the right name'); + + $callback->($value * 2); + }, + ); + + has 'lazy_foo_builder_w_type' => ( + reader => 'get_lazy_foo_builder_w_type', + isa => 'Int', + builder => 'get_foo_builder_w_type', + initializer => sub { + my ($self, $value, $callback, $attr) = @_; + + ::isa_ok($attr, 'Mouse::Meta::Attribute'); + ::is($attr->name, 'lazy_foo_builder_w_type', '... got the right name'); + + $callback->($value * 2); + }, + ); + + sub get_foo_builder { 100 } + sub get_foo_builder_w_type { 1000 } +} + +{ + my $foo = Foo->new(foo => 10); + isa_ok($foo, 'Foo'); + + is($foo->get_foo, 20, 'initial value set to 2x given value'); + is($foo->get_lazy_foo, 20, 'initial lazy value set to 2x given value'); + is($foo->get_lazy_foo_w_type, 40, 'initial lazy value with type set to 2x given value'); + is($foo->get_lazy_foo_builder, 200, 'initial lazy value with builder set to 2x given value'); + is($foo->get_lazy_foo_builder_w_type, 2000, 'initial lazy value with builder and type set to 2x given value'); +} + +{ + package Bar; + use Mouse; + + has 'foo' => ( + reader => 'get_foo', + writer => 'set_foo', + initializer => sub { + my ($self, $value, $callback, $attr) = @_; + + ::isa_ok($attr, 'Mouse::Meta::Attribute'); + ::is($attr->name, 'foo', '... got the right name'); + + $callback->($value * 2); + }, + ); + + __PACKAGE__->meta->make_immutable; +} + +{ + my $bar = Bar->new(foo => 10); + isa_ok($bar, 'Bar'); + + is($bar->get_foo, 20, 'initial value set to 2x given value'); +} + +{ + package Fail::Bar; + use Mouse; + + has 'foo' => ( + reader => 'get_foo', + writer => 'set_foo', + isa => 'Int', + initializer => sub { + my ($self, $value, $callback, $attr) = @_; + + ::isa_ok($attr, 'Mouse::Meta::Attribute'); + ::is($attr->name, 'foo', '... got the right name'); + + $callback->("Hello $value World"); + }, + ); + + __PACKAGE__->meta->make_immutable; +} + +dies_ok { + Fail::Bar->new(foo => 10) +} '... this fails, because initializer returns a bad type'; + diff --git a/t/020_attributes/failing/020_trigger_and_coerce.t b/t/020_attributes/failing/020_trigger_and_coerce.t new file mode 100644 index 0000000..38d3e91 --- /dev/null +++ b/t/020_attributes/failing/020_trigger_and_coerce.t @@ -0,0 +1,56 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 11; +use Test::Exception; + + + +{ + + package Fake::DateTime; + use Mouse; + + has 'string_repr' => ( is => 'ro' ); + + package Mortgage; + use Mouse; + use Mouse::Util::TypeConstraints; + + coerce 'Fake::DateTime' => from 'Str' => + via { Fake::DateTime->new( string_repr => $_ ) }; + + has 'closing_date' => ( + is => 'rw', + isa => 'Fake::DateTime', + coerce => 1, + trigger => sub { + my ( $self, $val ) = @_; + ::pass('... trigger is being called'); + ::isa_ok( $self->closing_date, 'Fake::DateTime' ); + ::isa_ok( $val, 'Fake::DateTime' ); + } + ); +} + +{ + my $mtg = Mortgage->new( closing_date => 'yesterday' ); + isa_ok( $mtg, 'Mortgage' ); + + # check that coercion worked + isa_ok( $mtg->closing_date, 'Fake::DateTime' ); +} + +Mortgage->meta->make_immutable; +ok( Mortgage->meta->is_immutable, '... Mortgage is now immutable' ); + +{ + my $mtg = Mortgage->new( closing_date => 'yesterday' ); + isa_ok( $mtg, 'Mortgage' ); + + # check that coercion worked + isa_ok( $mtg->closing_date, 'Fake::DateTime' ); +} + diff --git a/t/020_attributes/failing/021_method_generation_rules.t b/t/020_attributes/failing/021_method_generation_rules.t new file mode 100644 index 0000000..2169780 --- /dev/null +++ b/t/020_attributes/failing/021_method_generation_rules.t @@ -0,0 +1,63 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 17; +use Test::Exception; + + + +=pod + + is => rw, writer => _foo # turns into (reader => foo, writer => _foo) + is => ro, writer => _foo # turns into (reader => foo, writer => _foo) as before + is => rw, accessor => _foo # turns into (accessor => _foo) + is => ro, accessor => _foo # error, accesor is rw + +=cut + +sub make_class { + my ($is, $attr, $class) = @_; + + eval "package $class; use Mouse; has 'foo' => ( is => '$is', $attr => '_foo' );"; + + return $@ ? die $@ : $class; +} + +my $obj; +my $class; + +$class = make_class('rw', 'writer', 'Test::Class::WriterRW'); +ok($class, "Can define attr with rw + writer"); + +$obj = $class->new(); + +can_ok($obj, qw/foo _foo/); +lives_ok {$obj->_foo(1)} "$class->_foo is writer"; +is($obj->foo(), 1, "$class->foo is reader"); +dies_ok {$obj->foo(2)} "$class->foo is not writer"; # this should fail +ok(!defined $obj->_foo(), "$class->_foo is not reader"); + +$class = make_class('ro', 'writer', 'Test::Class::WriterRO'); +ok($class, "Can define attr with ro + writer"); + +$obj = $class->new(); + +can_ok($obj, qw/foo _foo/); +lives_ok {$obj->_foo(1)} "$class->_foo is writer"; +is($obj->foo(), 1, "$class->foo is reader"); +dies_ok {$obj->foo(1)} "$class->foo is not writer"; +isnt($obj->_foo(), 1, "$class->_foo is not reader"); + +$class = make_class('rw', 'accessor', 'Test::Class::AccessorRW'); +ok($class, "Can define attr with rw + accessor"); + +$obj = $class->new(); + +can_ok($obj, qw/_foo/); +lives_ok {$obj->_foo(1)} "$class->_foo is writer"; +is($obj->_foo(), 1, "$class->foo is reader"); + +dies_ok { make_class('ro', 'accessor', "Test::Class::AccessorRO"); } "Cant define attr with ro + accessor"; + diff --git a/t/020_attributes/failing/022_legal_options_for_inheritance.t b/t/020_attributes/failing/022_legal_options_for_inheritance.t new file mode 100644 index 0000000..2830506 --- /dev/null +++ b/t/020_attributes/failing/022_legal_options_for_inheritance.t @@ -0,0 +1,49 @@ +#!/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'); diff --git a/t/020_attributes/failing/023_attribute_names.t b/t/020_attributes/failing/023_attribute_names.t new file mode 100644 index 0000000..f98d556 --- /dev/null +++ b/t/020_attributes/failing/023_attribute_names.t @@ -0,0 +1,58 @@ +#!/usr/bin/perl + +use strict; +use warnings; +use Test::More tests => 8; +use Test::Exception; + +my $exception_regex = qr/You must provide a name for the attribute/; +{ + package My::Role; + use Mouse::Role; + + ::throws_ok { + has; + } $exception_regex, 'has; fails'; + + ::throws_ok { + has undef; + } $exception_regex, 'has undef; fails'; + + ::lives_ok { + has "" => ( + is => 'bare', + ); + } 'has ""; works now'; + + ::lives_ok { + has 0 => ( + is => 'bare', + ); + } 'has 0; works now'; +} + +{ + package My::Class; + use Mouse; + + ::throws_ok { + has; + } $exception_regex, 'has; fails'; + + ::throws_ok { + has undef; + } $exception_regex, 'has undef; fails'; + + ::lives_ok { + has "" => ( + is => 'bare', + ); + } 'has ""; works now'; + + ::lives_ok { + has 0 => ( + is => 'bare', + ); + } 'has 0; works now'; +} + diff --git a/t/020_attributes/failing/024_attribute_traits_parameterized.t b/t/020_attributes/failing/024_attribute_traits_parameterized.t new file mode 100644 index 0000000..57a3d05 --- /dev/null +++ b/t/020_attributes/failing/024_attribute_traits_parameterized.t @@ -0,0 +1,57 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More tests => 5; + +{ + package My::Attribute::Trait; + use Mouse::Role; + + sub reversed_name { + my $self = shift; + scalar reverse $self->name; + } +} + +{ + package My::Class; + use Mouse; + + has foo => ( + traits => [ + 'My::Attribute::Trait' => { + -alias => { + reversed_name => 'eman', + }, + }, + ], + is => 'bare', + ); +} + +{ + package My::Other::Class; + use Mouse; + + has foo => ( + traits => [ + 'My::Attribute::Trait' => { + -alias => { + reversed_name => 'reversed', + }, + -excludes => 'reversed_name', + }, + ], + is => 'bare', + ); +} + +my $attr = My::Class->meta->get_attribute('foo'); +is($attr->eman, 'oof', 'the aliased method is in the attribute'); +ok(!$attr->can('reversed'), "the method was not installed under the other class' alias"); + +my $other_attr = My::Other::Class->meta->get_attribute('foo'); +is($other_attr->reversed, 'oof', 'the aliased method is in the attribute'); +ok(!$other_attr->can('enam'), "the method was not installed under the other class' alias"); +ok(!$other_attr->can('reversed_name'), "the method was not installed under the original name when that was excluded"); + diff --git a/t/020_attributes/failing/025_chained_coercion.t b/t/020_attributes/failing/025_chained_coercion.t new file mode 100644 index 0000000..894d6ea --- /dev/null +++ b/t/020_attributes/failing/025_chained_coercion.t @@ -0,0 +1,49 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 4; +use Test::Exception; + +{ + package Baz; + use Mouse; + use Mouse::Util::TypeConstraints; + + coerce 'Baz' => from 'HashRef' => via { Baz->new($_) }; + + has 'hello' => ( + is => 'ro', + isa => 'Str', + ); + + package Bar; + use Mouse; + use Mouse::Util::TypeConstraints; + + coerce 'Bar' => from 'HashRef' => via { Bar->new($_) }; + + has 'baz' => ( + is => 'ro', + isa => 'Baz', + coerce => 1 + ); + + package Foo; + use Mouse; + + has 'bar' => ( + is => 'ro', + isa => 'Bar', + coerce => 1, + ); +} + +my $foo = Foo->new(bar => { baz => { hello => 'World' } }); +isa_ok($foo, 'Foo'); +isa_ok($foo->bar, 'Bar'); +isa_ok($foo->bar->baz, 'Baz'); +is($foo->bar->baz->hello, 'World', '... this all worked fine'); + + diff --git a/t/020_attributes/failing/026_attribute_without_any_methods.t b/t/020_attributes/failing/026_attribute_without_any_methods.t new file mode 100644 index 0000000..ece05db --- /dev/null +++ b/t/020_attributes/failing/026_attribute_without_any_methods.t @@ -0,0 +1,22 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 2; + +use Mouse (); +use Mouse::Meta::Class; + +my $meta = Mouse::Meta::Class->create('Banana'); + +my $warn; +$SIG{__WARN__} = sub { $warn = "@_" }; + +$meta->add_attribute('foo'); +like $warn, qr/Attribute \(foo\) of class Banana has no associated methods/, + 'correct error message'; + +$warn = ''; +$meta->add_attribute('bar', is => 'bare'); +is $warn, '', 'add attribute with no methods and is => "bare"'; diff --git a/t/020_attributes/failing/027_accessor_override_method.t b/t/020_attributes/failing/027_accessor_override_method.t new file mode 100644 index 0000000..8285b69 --- /dev/null +++ b/t/020_attributes/failing/027_accessor_override_method.t @@ -0,0 +1,33 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; + +BEGIN { + eval "use Test::Output;"; + plan skip_all => "Test::Output is required for this test" if $@; + plan tests => 5; +} + +{ + package Foo; + use Mouse; + + sub get_a { } + sub set_b { } + sub has_c { } + sub clear_d { } + sub e { } +} + +my $foo_meta = Foo->meta; +stderr_like(sub { $foo_meta->add_attribute(a => (reader => 'get_a')) }, + qr/^You are overwriting a locally defined method \(get_a\) with an accessor/, 'reader overriding gives proper warning'); +stderr_like(sub { $foo_meta->add_attribute(b => (writer => 'set_b')) }, + qr/^You are overwriting a locally defined method \(set_b\) with an accessor/, 'writer overriding gives proper warning'); +stderr_like(sub { $foo_meta->add_attribute(c => (predicate => 'has_c')) }, + qr/^You are overwriting a locally defined method \(has_c\) with an accessor/, 'predicate overriding gives proper warning'); +stderr_like(sub { $foo_meta->add_attribute(d => (clearer => 'clear_d')) }, + qr/^You are overwriting a locally defined method \(clear_d\) with an accessor/, 'clearer overriding gives proper warning'); +stderr_like(sub { $foo_meta->add_attribute(e => (is => 'rw')) }, + qr/^You are overwriting a locally defined method \(e\) with an accessor/, 'accessor overriding gives proper warning'); diff --git a/t/020_attributes/failing/028_no_slot_access.t b/t/020_attributes/failing/028_no_slot_access.t new file mode 100644 index 0000000..12ff7b0 --- /dev/null +++ b/t/020_attributes/failing/028_no_slot_access.t @@ -0,0 +1,90 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +{ + package SomeAwesomeDB; + + sub new_row { } + sub read { } + sub write { } +} + +{ + package MouseX::SomeAwesomeDBFields; + + # implementation of methods not called in the example deliberately + # omitted + + use Mouse::Role; + + sub inline_create_instance { + my ( $self, $classvar ) = @_; + + "bless SomeAwesomeDB::new_row(), $classvar"; + } + + sub inline_get_slot_value { + my ( $self, $invar, $slot ) = @_; + + "SomeAwesomeDB::read($invar, \"$slot\")"; + } + + sub inline_set_slot_value { + my ( $self, $invar, $slot, $valexp ) = @_; + + "SomeAwesomeDB::write($invar, \"$slot\", $valexp)"; + } + + sub inline_is_slot_initialized { + my ( $self, $invar, $slot ) = @_; + + "1"; + } + + sub inline_initialize_slot { + my ( $self, $invar, $slot ) = @_; + + ""; + } + + sub inline_slot_access { + die "inline_slot_access should not have been used"; + } +} + +{ + package Toy; + + use Mouse; + use Mouse::Util::MetaRole; + + use Test::More tests => 3; + use Test::Exception; + + Mouse::Util::MetaRole::apply_metaclass_roles( + for_class => __PACKAGE__, + instance_metaclass_roles => ['MouseX::SomeAwesomeDBFields'] + ); + + lives_ok { + has lazy_attr => ( + is => 'ro', + isa => 'Bool', + lazy => 1, + default => sub {0}, + ); + } + "Adding lazy accessor does not use inline_slot_access"; + + lives_ok { + has rw_attr => ( + is => 'rw', + ); + } + "Adding read-write accessor does not use inline_slot_access"; + + lives_ok { __PACKAGE__->meta->make_immutable; } + "Inling constructor does not use inline_slot_access"; +} diff --git a/t/020_attributes/failing/029_accessor_context.t b/t/020_attributes/failing/029_accessor_context.t new file mode 100644 index 0000000..b959f31 --- /dev/null +++ b/t/020_attributes/failing/029_accessor_context.t @@ -0,0 +1,68 @@ +#!/usr/bin/perl + +use strict; +use warnings; +use Test::More tests => 14; +use Test::Exception; + +lives_ok { + package My::Class; + use Mouse; + + has s_rw => ( + is => 'rw', + ); + + has s_ro => ( + is => 'ro', + ); + + has a_rw => ( + is => 'rw', + isa => 'ArrayRef', + + auto_deref => 1, + ); + + has a_ro => ( + is => 'ro', + isa => 'ArrayRef', + + auto_deref => 1, + ); + + has h_rw => ( + is => 'rw', + isa => 'HashRef', + + auto_deref => 1, + ); + + has h_ro => ( + is => 'ro', + isa => 'HashRef', + + auto_deref => 1, + ); +} 'class definition'; + +lives_ok { + my $o = My::Class->new(); + + is_deeply [scalar $o->s_rw], [undef], 'uninitialized scalar attribute/rw in scalar context'; + is_deeply [$o->s_rw], [undef], 'uninitialized scalar attribute/rw in list context'; + is_deeply [scalar $o->s_ro], [undef], 'uninitialized scalar attribute/ro in scalar context'; + is_deeply [$o->s_ro], [undef], 'uninitialized scalar attribute/ro in list context'; + + + is_deeply [scalar $o->a_rw], [undef], 'uninitialized ArrayRef attribute/rw in scalar context'; + is_deeply [$o->a_rw], [], 'uninitialized ArrayRef attribute/rw in list context'; + is_deeply [scalar $o->a_ro], [undef], 'uninitialized ArrayRef attribute/ro in scalar context'; + is_deeply [$o->a_ro], [], 'uninitialized ArrayRef attribute/ro in list context'; + + is_deeply [scalar $o->h_rw], [undef], 'uninitialized HashRef attribute/rw in scalar context'; + is_deeply [$o->h_rw], [], 'uninitialized HashRef attribute/rw in list context'; + is_deeply [scalar $o->h_ro], [undef], 'uninitialized HashRef attribute/ro in scalar context'; + is_deeply [$o->h_ro], [], 'uninitialized HashRef attribute/ro in list context'; + +} 'testing'; diff --git a/t/020_attributes/failing/030_non_alpha_attr_names.t b/t/020_attributes/failing/030_non_alpha_attr_names.t new file mode 100644 index 0000000..81105a8 --- /dev/null +++ b/t/020_attributes/failing/030_non_alpha_attr_names.t @@ -0,0 +1,41 @@ +use strict; +use warnings; + +use Test::More tests => 12; + +{ + package Foo; + use Mouse; + has 'type' => ( + required => 0, + reader => 'get_type', + default => 1, + ); + + has '@type' => ( + required => 0, + reader => 'get_at_type', + default => 2, + ); + + has 'has spaces' => ( + required => 0, + reader => 'get_hs', + default => 42, + ); + + no Mouse; +} + +{ + my $foo = Foo->new; + + ok( Foo->meta->has_attribute($_), "Foo has '$_' attribute" ) + for 'type', '@type', 'has spaces'; + + is( $foo->get_type, 1, q{'type' attribute default is 1} ); + is( $foo->get_at_type, 2, q{'@type' attribute default is 1} ); + is( $foo->get_hs, 42, q{'has spaces' attribute default is 42} ); + + Foo->meta->make_immutable, redo if Foo->meta->is_mutable; +} diff --git a/t/020_attributes/failing/031_delegation_and_modifiers.t b/t/020_attributes/failing/031_delegation_and_modifiers.t new file mode 100644 index 0000000..2a8d62a --- /dev/null +++ b/t/020_attributes/failing/031_delegation_and_modifiers.t @@ -0,0 +1,63 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 5; +use Test::Exception; + +{ + package Bar; + use Mouse; + + sub baz { 'Bar::baz' } + sub gorch { 'Bar::gorch' } + + package Foo; + use Mouse; + + has 'bar' => ( + is => 'ro', + isa => 'Bar', + lazy => 1, + default => sub { Bar->new }, + handles => [qw[ baz gorch ]] + ); + + package Foo::Extended; + use Mouse; + + extends 'Foo'; + + has 'test' => ( + is => 'rw', + isa => 'Bool', + default => sub { 0 }, + ); + + around 'bar' => sub { + my $next = shift; + my $self = shift; + + $self->test(1); + $self->$next(); + }; +} + +my $foo = Foo::Extended->new; +isa_ok($foo, 'Foo::Extended'); +isa_ok($foo, 'Foo'); + +ok(!$foo->test, '... the test value has not been changed'); + +is($foo->baz, 'Bar::baz', '... got the right delegated method'); + +ok($foo->test, '... the test value has now been changed'); + + + + + + + + diff --git a/t/050_metaclasses/001_custom_attr_meta_with_roles.t b/t/050_metaclasses/001_custom_attr_meta_with_roles.t new file mode 100644 index 0000000..613e0f9 --- /dev/null +++ b/t/050_metaclasses/001_custom_attr_meta_with_roles.t @@ -0,0 +1,43 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 3; +use Test::Exception; + + + +{ + package My::Custom::Meta::Attr; + use Mouse; + + extends 'Mouse::Meta::Attribute'; +} + +{ + package My::Fancy::Role; + use Mouse::Role; + + has 'bling_bling' => ( + metaclass => 'My::Custom::Meta::Attr', + is => 'rw', + isa => 'Str', + ); +} + +{ + package My::Class; + use Mouse; + + with 'My::Fancy::Role'; +} + +my $c = My::Class->new; +isa_ok($c, 'My::Class'); + +ok($c->meta->has_attribute('bling_bling'), '... got the attribute'); + +isa_ok($c->meta->get_attribute('bling_bling'), 'My::Custom::Meta::Attr'); + + diff --git a/t/050_metaclasses/002_custom_attr_meta_as_role.t b/t/050_metaclasses/002_custom_attr_meta_as_role.t new file mode 100644 index 0000000..106f19c --- /dev/null +++ b/t/050_metaclasses/002_custom_attr_meta_as_role.t @@ -0,0 +1,22 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 2; +use Test::Exception; + +; + +lives_ok { + package MouseX::Attribute::Test; + use Mouse::Role; +} 'creating custom attribute "metarole" is okay'; + +lives_ok { + package Mouse::Meta::Attribute::Custom::Test; + use Mouse; + + extends 'Mouse::Meta::Attribute'; + with 'MouseX::Attribute::Test'; +} 'custom attribute metaclass extending role is okay'; diff --git a/t/lib/Test/Mouse.pm b/t/lib/Test/Mouse.pm index 84f1973..e654cdf 100644 --- a/t/lib/Test/Mouse.pm +++ b/t/lib/Test/Mouse.pm @@ -91,6 +91,9 @@ package Mouse::Meta::Attribute; sub applied_traits{ $_[0]->{traits} } # TEST ONLY sub has_applied_traits{ exists $_[0]->{traits} } # TEST ONLY +sub has_documentation{ exists $_[0]->{documentation} } # TEST ONLY +sub documentation{ $_[0]->{documentation} } # TEST ONLY + 1; __END__