diff options
Diffstat (limited to 't/attributes')
43 files changed, 4210 insertions, 0 deletions
diff --git a/t/attributes/accessor_context.t b/t/attributes/accessor_context.t new file mode 100644 index 0000000..f07a499 --- /dev/null +++ b/t/attributes/accessor_context.t @@ -0,0 +1,68 @@ +use strict; +use warnings; +use Test::More; +use Test::Fatal; + +is( exception { + package My::Class; + use Moose; + + 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, + ); +}, undef, 'class definition' ); + +is( exception { + 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'; + +}, undef, 'testing' ); + +done_testing; diff --git a/t/attributes/accessor_inlining.t b/t/attributes/accessor_inlining.t new file mode 100644 index 0000000..8212e53 --- /dev/null +++ b/t/attributes/accessor_inlining.t @@ -0,0 +1,32 @@ +use strict; +use warnings; +use Test::More; + +my $called; +{ + package Foo::Meta::Instance; + use Moose::Role; + + sub is_inlinable { 0 } + + after get_slot_value => sub { $called++ }; +} + +{ + package Foo; + use Moose; + Moose::Util::MetaRole::apply_metaroles( + for => __PACKAGE__, + class_metaroles => { + instance => ['Foo::Meta::Instance'], + }, + ); + + has foo => (is => 'ro'); +} + +my $foo = Foo->new(foo => 1); +is($foo->foo, 1, "got the right value"); +is($called, 1, "reader was called"); + +done_testing; diff --git a/t/attributes/accessor_override_method.t b/t/attributes/accessor_override_method.t new file mode 100644 index 0000000..10343b9 --- /dev/null +++ b/t/attributes/accessor_override_method.t @@ -0,0 +1,57 @@ +use strict; +use warnings; +use Test::More; + +use Test::Requires 'Test::Output'; # skip all if not installed + +{ + + package Foo; + use Moose; + + sub get_a { } + sub set_b { } + sub has_c { } + sub clear_d { } + sub e { } + sub stub; +} + +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' +); +stderr_is( + sub { $foo_meta->add_attribute( stub => ( is => 'rw' ) ) }, + q{}, + 'overriding a stub with an accessor does not warn' +); +stderr_like( + sub { $foo_meta->add_attribute( has => ( is => 'rw' ) ) }, + qr/^You are overwriting a locally defined function \(has\) with an accessor/, + 'function overriding gives proper warning' +); + +done_testing; diff --git a/t/attributes/accessor_overwrite_warning.t b/t/attributes/accessor_overwrite_warning.t new file mode 100644 index 0000000..aa659f7 --- /dev/null +++ b/t/attributes/accessor_overwrite_warning.t @@ -0,0 +1,25 @@ +use strict; +use warnings; + +use Test::More; + +use Test::Requires 'Test::Output'; + +{ + package Bar; + use Moose; + + has has_attr => ( + is => 'ro', + ); + + ::stderr_like{ has attr => ( + is => 'ro', + predicate => 'has_attr', + ) + } + qr/\QYou are overwriting an accessor (has_attr) for the has_attr attribute with a new accessor method for the attr attribute/, + 'overwriting an accessor for another attribute causes a warning'; +} + +done_testing; diff --git a/t/attributes/attr_dereference_test.t b/t/attributes/attr_dereference_test.t new file mode 100644 index 0000000..1aeea9c --- /dev/null +++ b/t/attributes/attr_dereference_test.t @@ -0,0 +1,80 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +{ + package Customer; + use Moose; + + package Firm; + use Moose; + use Moose::Util::TypeConstraints; + + ::is( ::exception { + has 'customers' => ( + is => 'ro', + isa => subtype('ArrayRef' => where { + (blessed($_) && $_->isa('Customer') || return) for @$_; 1 }), + auto_deref => 1, + ); + }, undef, '... 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 Moose; + + has 'bar' => ( + is => 'rw', + isa => 'ArrayRef[Int]', + auto_deref => 1, + ); +} + +{ + my $autoderef = AutoDeref->new; + + isnt( exception { + $autoderef->bar(1, 2, 3); + }, undef, '... its auto-de-ref-ing, not auto-en-ref-ing' ); + + is( exception { + $autoderef->bar([ 1, 2, 3 ]) + }, undef, '... set the results of bar correctly' ); + + is_deeply [ $autoderef->bar ], [ 1, 2, 3 ], '... auto-dereffed correctly'; +} + +done_testing; diff --git a/t/attributes/attribute_accessor_generation.t b/t/attributes/attribute_accessor_generation.t new file mode 100644 index 0000000..e72ea7d --- /dev/null +++ b/t/attributes/attribute_accessor_generation.t @@ -0,0 +1,204 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Scalar::Util 'isweak'; + + +{ + package Foo; + use Moose; + + 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'); + is( exception { + $foo->foo(100); + }, undef, '... foo wrote successfully' ); + is($foo->foo(), 100, '... got the correct set value'); + + ok(!isweak($foo->{foo}), '... it is not a weak reference'); + + # required writer + + isnt( exception { + Foo->new; + }, undef, '... cannot create without the required attribute' ); + + can_ok($foo, 'foo_required'); + is($foo->foo_required(), 'required', '... got an unset value'); + is( exception { + $foo->foo_required(100); + }, undef, '... foo_required wrote successfully' ); + is($foo->foo_required(), 100, '... got the correct set value'); + + is( exception { + $foo->foo_required(undef); + }, 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'); + is( exception { + $foo->foo_int(100); + }, undef, '... foo_int wrote successfully' ); + is($foo->foo_int(), 100, '... got the correct set value'); + + isnt( exception { + $foo->foo_int("Foo"); + }, undef, '... 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'); + is( exception { + $foo->foo_weak($test); + }, undef, '... 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; + is( exception { + @list = $foo->foo_deref(); + }, undef, "... doesn't deref undef value" ); + is_deeply( \@list, [], "returns empty list in list context"); + + is( exception { + $foo->foo_deref( [ qw/foo bar gorch/ ] ); + }, undef, '... 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" ); + + isnt( exception { + $foo->foo_deref_ro( [] ); + }, undef, "... 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; + is( exception { + %hash = $foo->foo_deref_hash(); + }, undef, "... doesn't deref undef value" ); + is_deeply( \%hash, {}, "returns empty list in list context"); + + is( exception { + $foo->foo_deref_hash( { foo => 1, bar => 2 } ); + }, undef, '... 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"); +} + +done_testing; diff --git a/t/attributes/attribute_custom_metaclass.t b/t/attributes/attribute_custom_metaclass.t new file mode 100644 index 0000000..2778de5 --- /dev/null +++ b/t/attributes/attribute_custom_metaclass.t @@ -0,0 +1,90 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +{ + package Foo::Meta::Attribute; + use Moose; + + extends 'Moose::Meta::Attribute'; + + around 'new' => sub { + my $next = shift; + my $self = shift; + my $name = shift; + $next->($self, $name, (is => 'rw', isa => 'Foo'), @_); + }; + + package Foo; + use Moose; + + 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, 'Moose::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, 'Moose::Meta::TypeConstraint'); + + is($foo_attr_type_constraint->name, 'Foo', '... got the right type constraint name'); + is($foo_attr_type_constraint->parent->name, 'Object', '... got the right type constraint parent name'); +} +{ + package Bar::Meta::Attribute; + use Moose; + + extends 'Class::MOP::Attribute'; + + package Bar; + use Moose; + + ::is( ::exception { + has 'bar' => (metaclass => 'Bar::Meta::Attribute'); + }, undef, '... the attribute metaclass need not be a Moose::Meta::Attribute as long as it behaves' ); +} + +{ + package Moose::Meta::Attribute::Custom::Foo; + sub register_implementation { 'Foo::Meta::Attribute' } + + package Moose::Meta::Attribute::Custom::Bar; + use Moose; + + extends 'Moose::Meta::Attribute'; + + package Another::Foo; + use Moose; + + ::is( ::exception { + has 'foo' => (metaclass => 'Foo'); + }, undef, '... the attribute metaclass alias worked correctly' ); + + ::is( ::exception { + has 'bar' => (metaclass => 'Bar', is => 'bare'); + }, undef, '... 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, 'Moose::Meta::Attribute'); + + my $bar_attr = Another::Foo->meta->get_attribute('bar'); + isa_ok($bar_attr, 'Moose::Meta::Attribute::Custom::Bar'); + isa_ok($bar_attr, 'Moose::Meta::Attribute'); +} + +done_testing; diff --git a/t/attributes/attribute_delegation.t b/t/attributes/attribute_delegation.t new file mode 100644 index 0000000..3c61edd --- /dev/null +++ b/t/attributes/attribute_delegation.t @@ -0,0 +1,483 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +# ------------------------------------------------------------------- +# 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 Moose; + + has 'bar' => (is => 'rw', default => 10); + + sub baz { 42 } + + package Bar; + use Moose; + + 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, 'Moose::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'); + +is( exception { + $bar->foo($foo); +}, undef, '... 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 Moose; + + sub go { 'Engine::go' } + sub stop { 'Engine::stop' } + + package Car; + use Moose; + + 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 Moose; + + sub foo { 'Baz::foo' } + sub bar { 'Baz::bar' } + sub boo { 'Baz::boo' } + + package Baz::Proxy1; + use Moose; + + has 'baz' => ( + is => 'ro', + isa => 'Baz', + default => sub { Baz->new }, + handles => qr/.*/ + ); + + package Baz::Proxy2; + use Moose; + + has 'baz' => ( + is => 'ro', + isa => 'Baz', + default => sub { Baz->new }, + handles => qr/.oo/ + ); + + package Baz::Proxy3; + use Moose; + + 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 Moose::Role; + + requires 'foo'; + requires 'bar'; + + package Foo::Baz; + use Moose; + + sub foo { 'Foo::Baz::FOO' } + sub bar { 'Foo::Baz::BAR' } + sub baz { 'Foo::Baz::BAZ' } + + package Foo::Thing; + use Moose; + + has 'thing' => ( + is => 'rw', + isa => 'Foo::Baz', + handles => 'Foo::Bar', + ); + + package Foo::OtherThing; + use Moose; + use Moose::Util::TypeConstraints; + + has 'other_thing' => ( + is => 'rw', + isa => 'Foo::Baz', + handles => Moose::Util::TypeConstraints::find_type_constraint('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'); +} + +{ + my $foo = Foo::OtherThing->new(other_thing => Foo::Baz->new); + isa_ok($foo, 'Foo::OtherThing'); + isa_ok($foo->other_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->other_thing->baz, 'Foo::Baz::BAZ', '... got the right value'); +} +# ------------------------------------------------------------------- +# AUTOLOAD & handles +# ------------------------------------------------------------------- + +{ + package Foo::Autoloaded; + use Moose; + + 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 Moose; + + has 'foo' => ( + is => 'rw', + default => sub { Foo::Autoloaded->new }, + handles => { 'foo_bar' => 'bar' } + ); + + package Baz::Autoloaded; + use Moose; + + has 'foo' => ( + is => 'rw', + default => sub { Foo::Autoloaded->new }, + handles => ['bar'] + ); + + package Goorch::Autoloaded; + use Moose; + + ::isnt( ::exception { + has 'foo' => ( + is => 'rw', + default => sub { Foo::Autoloaded->new }, + handles => qr/bar/ + ); + }, undef, '... 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'); + + is( exception { + $bar->foo($foo); + }, undef, '... 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'); + + is( exception { + $baz->foo($foo); + }, undef, '... 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 Moose; + 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); + like( exception { $i->foo_bar }, qr/is not defined/, 'useful error from unblessed reference' ); + + my $j = Bar->new(foo => []); + like( exception { $j->foo_bar }, qr/is not an object \(got 'ARRAY/, 'useful error from unblessed reference' ); + + my $k = Bar->new(foo => "Foo"); + is( exception { $k->foo_baz }, undef, "but not for class name" ); +} + +{ + package Delegator; + use Moose; + + sub full { 1 } + sub stub; + + ::like( + ::exception{ has d1 => ( + isa => 'X', + handles => ['full'], + ); + }, + qr/\QYou cannot overwrite a locally defined method (full) with a delegation/, + 'got an error when trying to declare a delegation method that overwrites a local method' + ); + + ::is( + ::exception{ has d2 => ( + isa => 'X', + handles => ['stub'], + ); + }, + undef, + 'no error when trying to declare a delegation method that overwrites a stub method' + ); +} + +done_testing; diff --git a/t/attributes/attribute_does.t b/t/attributes/attribute_does.t new file mode 100644 index 0000000..32279a5 --- /dev/null +++ b/t/attributes/attribute_does.t @@ -0,0 +1,99 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +{ + package Foo::Role; + use Moose::Role; + use Moose::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 Foo::Class; + use Moose; + + with 'Foo::Role'; + + package Bar::Role; + use Moose::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 Bar::Class; + use Moose; + + with 'Bar::Role'; +} + +my $foo = Foo::Class->new; +isa_ok($foo, 'Foo::Class'); + +my $bar = Bar::Class->new; +isa_ok($bar, 'Bar::Class'); + +is( exception { + $foo->bar($bar); +}, undef, '... bar passed the type constraint okay' ); + +isnt( exception { + $foo->bar($foo); +}, undef, '... foo did not pass the type constraint okay' ); + +is( exception { + $foo->baz($bar); +}, undef, '... baz passed the type constraint okay' ); + +isnt( exception { + $foo->baz($foo); +}, undef, '... foo did not pass the type constraint okay' ); + +is( exception { + $bar->foo($foo); +}, undef, '... foo passed the type constraint okay' ); + + + +# some error conditions + +{ + package Baz::Class; + use Moose; + + # if isa and does appear together, then see if Class->does(Role) + # if it does not,.. we have a conflict... so we die loudly + ::isnt( ::exception { + has 'foo' => (isa => 'Foo::Class', does => 'Bar::Class'); + }, undef, '... 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 Moose; + + # if isa and does appear together, then see if Class->does(Role) + # if it does not,.. we have a conflict... so we die loudly + ::isnt( ::exception { + has 'foo' => (isa => 'Bling', does => 'Bar::Class'); + }, undef, '... cannot have a isa() which is cannot does()' ); +} + +done_testing; diff --git a/t/attributes/attribute_inherited_slot_specs.t b/t/attributes/attribute_inherited_slot_specs.t new file mode 100644 index 0000000..2556e9a --- /dev/null +++ b/t/attributes/attribute_inherited_slot_specs.t @@ -0,0 +1,269 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +{ + package Thing::Meta::Attribute; + use Moose; + + extends 'Moose::Meta::Attribute'; + around illegal_options_for_inheritance => sub { + return (shift->(@_), qw/trigger/); + }; + + package Thing; + use Moose; + + sub hello { 'Hello World (from Thing)' } + sub goodbye { 'Goodbye World (from Thing)' } + + package Foo; + use Moose; + use Moose::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' => (metaclass => 'Thing::Meta::Attribute', is => 'bare', trigger => sub { }); + + package Bar; + use Moose; + use Moose::Util::TypeConstraints; + + extends 'Foo'; + + ::is( ::exception { + has '+bar' => (default => 'Bar::bar'); + }, undef, '... we can change the default attribute option' ); + + ::is( ::exception { + has '+baz' => (isa => 'ArrayRef'); + }, undef, '... we can add change the isa as long as it is a subtype' ); + + ::is( ::exception { + has '+foo' => (coerce => 1); + }, undef, '... we can change/add coerce as an attribute option' ); + + ::is( ::exception { + has '+gorch' => (required => 1); + }, undef, '... we can change/add required as an attribute option' ); + + ::is( ::exception { + has '+gloum' => (lazy => 1); + }, undef, '... we can change/add lazy as an attribute option' ); + + ::is( ::exception { + has '+fleem' => (lazy_build => 1); + }, undef, '... we can add lazy_build as an attribute option' ); + + ::is( ::exception { + has '+bunch_of_stuff' => (isa => 'ArrayRef[Int]'); + }, undef, '... extend an attribute with parameterized type' ); + + ::is( ::exception { + has '+one_last_one' => (isa => subtype('Ref', where { blessed $_ eq 'CODE' })); + }, undef, '... extend an attribute with anon-subtype' ); + + ::is( ::exception { + has '+one_last_one' => (isa => 'Value'); + }, undef, '... now can extend an attribute with a non-subtype' ); + + ::is( ::exception { + has '+fleem' => (weak_ref => 1); + }, undef, '... now allowed to add the weak_ref option via inheritance' ); + + ::is( ::exception { + has '+bling' => (handles => ['hello']); + }, undef, '... we can add the handles attribute option' ); + + # this one will *not* work here .... + ::isnt( ::exception { + has '+blang' => (handles => ['hello']); + }, undef, '... we can not alter the handles attribute option' ); + ::is( ::exception { + has '+fail' => (isa => 'Ref'); + }, undef, '... can now create an attribute with an improper subtype relation' ); + ::isnt( ::exception { + has '+other_fail' => (trigger => sub {}); + }, undef, '... cannot create an attribute with an illegal option' ); + ::like( ::exception { + 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'); +is( exception { $foo->foo('FooString') }, undef, '... assigned foo correctly' ); +is($foo->foo, 'FooString', '... got the right value for foo'); + +isnt( exception { $foo->foo([]) }, undef, '... foo is not coercing (as expected)' ); + +is($foo->bar, 'Foo::bar', '... got the right default value'); +isnt( exception { $foo->bar(10) }, undef, '... Foo::bar is a read/only attr' ); + +is($foo->baz, undef, '... got the right undef default value'); + +{ + my $hash_ref = {}; + is( exception { $foo->baz($hash_ref) }, undef, '... Foo::baz accepts hash refs' ); + is($foo->baz, $hash_ref, '... got the right value assigned to baz'); + + my $array_ref = []; + is( exception { $foo->baz($array_ref) }, undef, '... Foo::baz accepts an array ref' ); + is($foo->baz, $array_ref, '... got the right value assigned to baz'); + + my $scalar_ref = \(my $var); + is( exception { $foo->baz($scalar_ref) }, undef, '... Foo::baz accepts scalar ref' ); + is($foo->baz, $scalar_ref, '... got the right value assigned to baz'); + + is( exception { $foo->bunch_of_stuff([qw[one two three]]) }, undef, '... Foo::bunch_of_stuff accepts an array of strings' ); + + is( exception { $foo->one_last_one(sub { 'Hello World'}) }, undef, '... Foo::one_last_one accepts a code ref' ); + + my $code_ref = sub { 1 }; + is( exception { $foo->baz($code_ref) }, undef, '... Foo::baz accepts a code ref' ); + is($foo->baz, $code_ref, '... got the right value assigned to baz'); +} + +isnt( exception { + Bar->new; +}, undef, '... 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'); +is( exception { $bar->foo('FooString') }, undef, '... assigned foo correctly' ); +is($bar->foo, 'FooString', '... got the right value for foo'); +is( exception { $bar->foo([]) }, undef, '... 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'); +isnt( exception { $bar->bar(10) }, undef, '... Bar::bar is a read/only attr' ); + +is($bar->baz, undef, '... got the right undef default value'); + +{ + my $hash_ref = {}; + isnt( exception { $bar->baz($hash_ref) }, undef, '... Bar::baz does not accept hash refs' ); + + my $array_ref = []; + is( exception { $bar->baz($array_ref) }, undef, '... Bar::baz can accept an array ref' ); + is($bar->baz, $array_ref, '... got the right value assigned to baz'); + + my $scalar_ref = \(my $var); + isnt( exception { $bar->baz($scalar_ref) }, undef, '... Bar::baz does not accept a scalar ref' ); + + is( exception { $bar->bunch_of_stuff([1, 2, 3]) }, undef, '... Bar::bunch_of_stuff accepts an array of ints' ); + isnt( exception { $bar->bunch_of_stuff([qw[one two three]]) }, undef, '... Bar::bunch_of_stuff does not accept an array of strings' ); + + my $code_ref = sub { 1 }; + isnt( exception { $bar->baz($code_ref) }, undef, '... 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'); +ok(!Bar->meta->has_attribute('blang'), '... Bar has a blang attr'); +ok(Bar->meta->has_attribute('fail'), '... Bar has a fail attr'); +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'); + +done_testing; diff --git a/t/attributes/attribute_lazy_initializer.t b/t/attributes/attribute_lazy_initializer.t new file mode 100644 index 0000000..7651ea4 --- /dev/null +++ b/t/attributes/attribute_lazy_initializer.t @@ -0,0 +1,148 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +{ + package Foo; + use Moose; + + has 'foo' => ( + reader => 'get_foo', + writer => 'set_foo', + initializer => sub { + my ($self, $value, $callback, $attr) = @_; + + ::isa_ok($attr, 'Moose::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, 'Moose::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, 'Moose::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, 'Moose::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, 'Moose::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 Moose; + + has 'foo' => ( + reader => 'get_foo', + writer => 'set_foo', + initializer => sub { + my ($self, $value, $callback, $attr) = @_; + + ::isa_ok($attr, 'Moose::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 Moose; + + has 'foo' => ( + reader => 'get_foo', + writer => 'set_foo', + isa => 'Int', + initializer => sub { + my ($self, $value, $callback, $attr) = @_; + + ::isa_ok($attr, 'Moose::Meta::Attribute'); + ::is($attr->name, 'foo', '... got the right name'); + + $callback->("Hello $value World"); + }, + ); + + __PACKAGE__->meta->make_immutable; +} + +isnt( exception { + Fail::Bar->new(foo => 10) +}, undef, '... this fails, because initializer returns a bad type' ); + +done_testing; diff --git a/t/attributes/attribute_names.t b/t/attributes/attribute_names.t new file mode 100644 index 0000000..af6ee1e --- /dev/null +++ b/t/attributes/attribute_names.t @@ -0,0 +1,57 @@ +use strict; +use warnings; +use Test::More; +use Test::Fatal; + +my $exception_regex = qr/You must provide a name for the attribute/; +{ + package My::Role; + use Moose::Role; + + ::like( ::exception { + has; + }, $exception_regex, 'has; fails' ); + + ::like( ::exception { + has undef; + }, $exception_regex, 'has undef; fails' ); + + ::is( ::exception { + has "" => ( + is => 'bare', + ); + }, undef, 'has ""; works now' ); + + ::is( ::exception { + has 0 => ( + is => 'bare', + ); + }, undef, 'has 0; works now' ); +} + +{ + package My::Class; + use Moose; + + ::like( ::exception { + has; + }, $exception_regex, 'has; fails' ); + + ::like( ::exception { + has undef; + }, $exception_regex, 'has undef; fails' ); + + ::is( ::exception { + has "" => ( + is => 'bare', + ); + }, undef, 'has ""; works now' ); + + ::is( ::exception { + has 0 => ( + is => 'bare', + ); + }, undef, 'has 0; works now' ); +} + +done_testing; diff --git a/t/attributes/attribute_reader_generation.t b/t/attributes/attribute_reader_generation.t new file mode 100644 index 0000000..8c2e257 --- /dev/null +++ b/t/attributes/attribute_reader_generation.t @@ -0,0 +1,103 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +{ + package Foo; + use Moose; + + 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 $@; + + eval { + has 'lazy_weak_foo' => ( + reader => 'get_lazy_weak_foo', + lazy => 1, + default => sub { our $AREF = [] }, + weak_ref => 1, + ); + }; + ::ok(!$@, '... created the lazy weak 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'); + isnt( exception { + $foo->get_foo(100); + }, undef, '... 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'); + isnt( exception { + $foo->get_lazy_foo(100); + }, undef, '... get_lazy_foo is a read-only' ); + + is($foo->get_lazy_weak_foo(), $Foo::AREF, 'got the right value'); + ok($foo->meta->get_meta_instance->slot_value_is_weak($foo, 'lazy_weak_foo'), + '... and it is weak'); +} + +{ + my $foo = Foo->new; + isa_ok($foo, 'Foo'); + + my $attr = $foo->meta->find_attribute_by_name("lazy_foo"); + + isa_ok( $attr, "Moose::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 $lazy_weak_attr = $foo->meta->find_attribute_by_name("lazy_weak_foo"); + + is( $lazy_weak_attr->get_value($foo), $Foo::AREF, "it's the right value" ); + + ok( $foo->meta->get_meta_instance->slot_value_is_weak($foo, 'lazy_weak_foo'), "and it is weak"); +} + +{ + 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'); +} + +done_testing; diff --git a/t/attributes/attribute_required.t b/t/attributes/attribute_required.t new file mode 100644 index 0000000..f0b39b2 --- /dev/null +++ b/t/attributes/attribute_required.t @@ -0,0 +1,66 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +{ + package Foo; + use Moose; + + 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'; + +is( exception { + Foo->new(bar => 10, baz => undef); +}, undef, '... undef is a valid attribute value' ); + +is( exception { + Foo->new(bar => 10, boo => undef); +}, undef, '... undef is a valid attribute value' ); + + +like( exception { + Foo->new; +}, qr/^Attribute \(bar\) is required/, '... must supply all the required attribute' ); + +done_testing; diff --git a/t/attributes/attribute_traits.t b/t/attributes/attribute_traits.t new file mode 100644 index 0000000..bcdf491 --- /dev/null +++ b/t/attributes/attribute_traits.t @@ -0,0 +1,63 @@ +use strict; +use warnings; + +use Test::More; +use Test::Moose; + + +{ + package My::Attribute::Trait; + use Moose::Role; + + has 'alias_to' => (is => 'ro', isa => 'Str'); + + has foo => ( is => "ro", default => "blah" ); + + after 'install_accessors' => sub { + my $self = shift; + $self->associated_class->add_method( + $self->alias_to, + $self->get_read_method_ref + ); + }; +} + +{ + package My::Class; + use Moose; + + has 'bar' => ( + traits => [qw/My::Attribute::Trait/], + is => 'ro', + isa => 'Int', + alias_to => 'baz', + ); + + has 'gorch' => ( + is => 'ro', + isa => 'Int', + default => sub { 10 } + ); +} + +my $c = My::Class->new(bar => 100); +isa_ok($c, 'My::Class'); + +is($c->bar, 100, '... got the right value for bar'); +is($c->gorch, 10, '... got the right value for gorch'); + +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'); +is($bar_attr->foo, "blah", "attr initialized"); + +my $gorch_attr = $c->meta->get_attribute('gorch'); +ok(!$gorch_attr->does('My::Attribute::Trait'), '... gorch doesnt do the trait'); +ok(!$gorch_attr->has_applied_traits, '... no traits applied'); +is($gorch_attr->applied_traits, undef, '... no traits applied'); + +done_testing; diff --git a/t/attributes/attribute_traits_n_meta.t b/t/attributes/attribute_traits_n_meta.t new file mode 100644 index 0000000..dd43a45 --- /dev/null +++ b/t/attributes/attribute_traits_n_meta.t @@ -0,0 +1,63 @@ +use strict; +use warnings; + +use Test::More; +use Test::Moose; + + + +{ + package My::Meta::Attribute::DefaultReadOnly; + use Moose; + + extends 'Moose::Meta::Attribute'; + + around 'new' => sub { + my $next = shift; + my ($self, $name, %options) = @_; + $options{is} = 'ro' + unless exists $options{is}; + $next->($self, $name, %options); + }; +} + +{ + package My::Attribute::Trait; + use Moose::Role; + + has 'alias_to' => (is => 'ro', isa => 'Str'); + + after 'install_accessors' => sub { + my $self = shift; + $self->associated_class->add_method( + $self->alias_to, + $self->get_read_method_ref + ); + }; +} + +{ + package My::Class; + use Moose; + + has 'bar' => ( + metaclass => 'My::Meta::Attribute::DefaultReadOnly', + traits => [qw/My::Attribute::Trait/], + isa => 'Int', + alias_to => 'baz', + ); +} + +my $c = My::Class->new(bar => 100); +isa_ok($c, 'My::Class'); + +is($c->bar, 100, '... got the right value for bar'); + +can_ok($c, 'baz'); +is($c->baz, 100, '... got the right value for baz'); + +isa_ok($c->meta->get_attribute('bar'), 'My::Meta::Attribute::DefaultReadOnly'); +does_ok($c->meta->get_attribute('bar'), 'My::Attribute::Trait'); +is($c->meta->get_attribute('bar')->_is_metadata, 'ro', '... got the right metaclass customization'); + +done_testing; diff --git a/t/attributes/attribute_traits_parameterized.t b/t/attributes/attribute_traits_parameterized.t new file mode 100644 index 0000000..cdf84b0 --- /dev/null +++ b/t/attributes/attribute_traits_parameterized.t @@ -0,0 +1,57 @@ +use strict; +use warnings; +use Test::More; + +{ + package My::Attribute::Trait; + use Moose::Role; + + sub reversed_name { + my $self = shift; + scalar reverse $self->name; + } +} + +{ + package My::Class; + use Moose; + + has foo => ( + traits => [ + 'My::Attribute::Trait' => { + -alias => { + reversed_name => 'eman', + }, + }, + ], + is => 'bare', + ); +} + +{ + package My::Other::Class; + use Moose; + + 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"); + +done_testing; diff --git a/t/attributes/attribute_traits_registered.t b/t/attributes/attribute_traits_registered.t new file mode 100644 index 0000000..3ce332a --- /dev/null +++ b/t/attributes/attribute_traits_registered.t @@ -0,0 +1,114 @@ +use strict; +use warnings; + +use Test::More; +use Test::Moose; + + +{ + package My::Attribute::Trait; + use Moose::Role; + + has 'alias_to' => (is => 'ro', isa => 'Str'); + + has foo => ( is => "ro", default => "blah" ); + + after 'install_accessors' => sub { + my $self = shift; + $self->associated_class->add_method( + $self->alias_to, + $self->get_read_method_ref + ); + }; + + package Moose::Meta::Attribute::Custom::Trait::Aliased; + sub register_implementation { 'My::Attribute::Trait' } +} + +{ + package My::Other::Attribute::Trait; + use Moose::Role; + + my $method = sub { + 42; + }; + + has the_other_attr => ( isa => "Str", is => "rw", default => "oink" ); + + after 'install_accessors' => sub { + my $self = shift; + $self->associated_class->add_method( + 'additional_method', + $method + ); + }; + + package Moose::Meta::Attribute::Custom::Trait::Other; + sub register_implementation { 'My::Other::Attribute::Trait' } +} + +{ + package My::Class; + use Moose; + + has 'bar' => ( + traits => [qw/Aliased/], + is => 'ro', + isa => 'Int', + alias_to => 'baz', + ); +} + +{ + package My::Derived::Class; + use Moose; + + extends 'My::Class'; + + has '+bar' => ( + traits => [qw/Other/], + ); +} + +my $c = My::Class->new(bar => 100); +isa_ok($c, 'My::Class'); + +is($c->bar, 100, '... got the right value for bar'); + +can_ok($c, 'baz') and +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'); +is($bar_attr->foo, "blah", "attr initialized"); + +ok(!$bar_attr->meta->does_role('Aliased'), "does_role ignores aliases for sanity"); +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"); + +my $quux = My::Derived::Class->new(bar => 1000); + +is($quux->bar, 1000, '... got the right value for bar'); + +can_ok($quux, 'baz'); +is($quux->baz, 1000, '... got the right value for baz'); + +my $derived_bar_attr = $quux->meta->get_attribute("bar"); +does_ok($derived_bar_attr, 'My::Attribute::Trait' ); + +is( $derived_bar_attr->foo, "blah", "attr initialized" ); + +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"); +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"); + +can_ok($quux, 'additional_method'); +is(eval { $quux->additional_method }, 42, '... got the right value for additional_method'); + +done_testing; diff --git a/t/attributes/attribute_triggers.t b/t/attributes/attribute_triggers.t new file mode 100644 index 0000000..5b86ac6 --- /dev/null +++ b/t/attributes/attribute_triggers.t @@ -0,0 +1,219 @@ +use strict; +use warnings; + +use Scalar::Util 'isweak'; + +use Test::More; +use Test::Fatal; + + +{ + package Foo; + use Moose; + + 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 Moose; + + has 'foo' => (is => 'rw', isa => 'Foo', weak_ref => 1); + + package Baz; + use Moose; + + 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'); + + is( exception { + $foo->bar($bar); + }, undef, '... 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'); + + is( exception { + $foo->bar(undef); + }, 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 + + is( exception { + $foo->set_baz($baz); + }, undef, '... 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 Moose; + + ::isnt( ::exception { + has('bling' => (is => 'rw', trigger => 'Fail')); + }, undef, '... a trigger must be a CODE ref' ); + + ::isnt( ::exception { + has('bling' => (is => 'rw', trigger => [])); + }, undef, '... a trigger must be a CODE ref' ); +} + +# Triggers do not fire on built values + +{ + package Blarg; + use Moose; + + 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; + is( exception { $blarg = Blarg->new; }, undef, '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'); + + is( exception { $blarg => Blarg->new( map { $_ => "Yet another $_ value" } qw/foo bar baz/ ) }, undef, '->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 Moose; + 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; +} + +done_testing; diff --git a/t/attributes/attribute_type_unions.t b/t/attributes/attribute_type_unions.t new file mode 100644 index 0000000..ab0ed60 --- /dev/null +++ b/t/attributes/attribute_type_unions.t @@ -0,0 +1,96 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +{ + package Foo; + use Moose; + + has 'bar' => (is => 'rw', isa => 'ArrayRef | HashRef'); +} + +my $foo = Foo->new; +isa_ok($foo, 'Foo'); + +is( exception { + $foo->bar([]) +}, undef, '... set bar successfully with an ARRAY ref' ); + +is( exception { + $foo->bar({}) +}, undef, '... set bar successfully with a HASH ref' ); + +isnt( exception { + $foo->bar(100) +}, undef, '... couldnt set bar successfully with a number' ); + +isnt( exception { + $foo->bar(sub {}) +}, undef, '... couldnt set bar successfully with a CODE ref' ); + +# check the constructor + +is( exception { + Foo->new(bar => []) +}, undef, '... created new Foo with bar successfully set with an ARRAY ref' ); + +is( exception { + Foo->new(bar => {}) +}, undef, '... created new Foo with bar successfully set with a HASH ref' ); + +isnt( exception { + Foo->new(bar => 50) +}, undef, '... didnt create a new Foo with bar as a number' ); + +isnt( exception { + Foo->new(bar => sub {}) +}, undef, '... didnt create a new Foo with bar as a CODE ref' ); + +{ + package Bar; + use Moose; + + has 'baz' => (is => 'rw', isa => 'Str | CodeRef'); +} + +my $bar = Bar->new; +isa_ok($bar, 'Bar'); + +is( exception { + $bar->baz('a string') +}, undef, '... set baz successfully with a string' ); + +is( exception { + $bar->baz(sub { 'a sub' }) +}, undef, '... set baz successfully with a CODE ref' ); + +isnt( exception { + $bar->baz(\(my $var1)) +}, undef, '... couldnt set baz successfully with a SCALAR ref' ); + +isnt( exception { + $bar->baz({}) +}, undef, '... couldnt set bar successfully with a HASH ref' ); + +# check the constructor + +is( exception { + Bar->new(baz => 'a string') +}, undef, '... created new Bar with baz successfully set with a string' ); + +is( exception { + Bar->new(baz => sub { 'a sub' }) +}, undef, '... created new Bar with baz successfully set with a CODE ref' ); + +isnt( exception { + Bar->new(baz => \(my $var2)) +}, undef, '... didnt create a new Bar with baz as a number' ); + +isnt( exception { + Bar->new(baz => {}) +}, undef, '... didnt create a new Bar with baz as a HASH ref' ); + +done_testing; diff --git a/t/attributes/attribute_without_any_methods.t b/t/attributes/attribute_without_any_methods.t new file mode 100644 index 0000000..f1310fb --- /dev/null +++ b/t/attributes/attribute_without_any_methods.t @@ -0,0 +1,22 @@ +use strict; +use warnings; + +use Test::More; + +use Moose (); +use Moose::Meta::Class; + +my $meta = Moose::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"'; + +done_testing; diff --git a/t/attributes/attribute_writer_generation.t b/t/attributes/attribute_writer_generation.t new file mode 100644 index 0000000..ceb5acb --- /dev/null +++ b/t/attributes/attribute_writer_generation.t @@ -0,0 +1,117 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use Scalar::Util 'isweak'; + + +{ + package Foo; + use Moose; + + 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'); + is( exception { + $foo->set_foo(100); + }, undef, '... 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 + + isnt( exception { + Foo->new; + }, undef, '... cannot create without the required attribute' ); + + can_ok($foo, 'set_foo_required'); + is($foo->get_foo_required(), 'required', '... got an unset value'); + is( exception { + $foo->set_foo_required(100); + }, undef, '... set_foo_required wrote successfully' ); + is($foo->get_foo_required(), 100, '... got the correct set value'); + + isnt( exception { + $foo->set_foo_required(); + }, undef, '... set_foo_required died successfully with no value' ); + + is( exception { + $foo->set_foo_required(undef); + }, 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'); + is( exception { + $foo->set_foo_int(100); + }, undef, '... set_foo_int wrote successfully' ); + is($foo->get_foo_int(), 100, '... got the correct set value'); + + isnt( exception { + $foo->set_foo_int("Foo"); + }, undef, '... 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'); + is( exception { + $foo->set_foo_weak($test); + }, undef, '... 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'); +} + +done_testing; diff --git a/t/attributes/bad_coerce.t b/t/attributes/bad_coerce.t new file mode 100644 index 0000000..daffe91 --- /dev/null +++ b/t/attributes/bad_coerce.t @@ -0,0 +1,33 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +{ + package Foo; + + use Moose; + + ::like(::exception { + has foo => ( + is => 'ro', + isa => 'Str', + coerce => 1, + ); + }, + qr/\QYou cannot coerce an attribute (foo) unless its type (Str) has a coercion/, + 'Cannot coerce unless the type has a coercion'); + + ::like(::exception { + has bar => ( + is => 'ro', + isa => 'Str', + coerce => 1, + ); + }, + qr/\QYou cannot coerce an attribute (bar) unless its type (Str) has a coercion/, + 'Cannot coerce unless the type has a coercion - different attribute'); +} + +done_testing; diff --git a/t/attributes/chained_coercion.t b/t/attributes/chained_coercion.t new file mode 100644 index 0000000..853f251 --- /dev/null +++ b/t/attributes/chained_coercion.t @@ -0,0 +1,46 @@ +use strict; +use warnings; + +use Test::More; + +{ + package Baz; + use Moose; + use Moose::Util::TypeConstraints; + + coerce 'Baz' => from 'HashRef' => via { Baz->new($_) }; + + has 'hello' => ( + is => 'ro', + isa => 'Str', + ); + + package Bar; + use Moose; + use Moose::Util::TypeConstraints; + + coerce 'Bar' => from 'HashRef' => via { Bar->new($_) }; + + has 'baz' => ( + is => 'ro', + isa => 'Baz', + coerce => 1 + ); + + package Foo; + use Moose; + + 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'); + +done_testing; diff --git a/t/attributes/clone_weak.t b/t/attributes/clone_weak.t new file mode 100644 index 0000000..1f5162d --- /dev/null +++ b/t/attributes/clone_weak.t @@ -0,0 +1,177 @@ +use strict; +use warnings; +use Test::More; + +{ + package Foo; + use Moose; + + has bar => ( + is => 'ro', + weak_ref => 1, + ); +} + +{ + package MyScopeGuard; + + sub new { + my ($class, $cb) = @_; + bless { cb => $cb }, $class; + } + + sub DESTROY { shift->{cb}->() } +} + +{ + my $destroyed = 0; + + my $foo = do { + my $bar = MyScopeGuard->new(sub { $destroyed++ }); + my $foo = Foo->new({ bar => $bar }); + my $clone = $foo->meta->clone_object($foo); + + is $destroyed, 0; + + $clone; + }; + + isa_ok($foo, 'Foo'); + is $foo->bar, undef; + is $destroyed, 1; +} + +{ + my $clone; + { + my $anon = Moose::Meta::Class->create_anon_class; + + my $foo = $anon->new_object; + isa_ok($foo, $anon->name); + ok(Class::MOP::class_of($foo), "has a metaclass"); + + $clone = $anon->clone_object($foo); + isa_ok($clone, $anon->name); + ok(Class::MOP::class_of($clone), "has a metaclass"); + } + + ok(Class::MOP::class_of($clone), "still has a metaclass"); +} + +{ + package Foo::Meta::Attr::Trait; + use Moose::Role; + + has value_slot => ( + is => 'ro', + isa => 'Str', + lazy => 1, + default => sub { shift->name }, + ); + + has count_slot => ( + is => 'ro', + isa => 'Str', + lazy => 1, + default => sub { '<<COUNT>>' . shift->name }, + ); + + sub slots { + my $self = shift; + return ($self->value_slot, $self->count_slot); + } + + sub _set_count { + my $self = shift; + my ($instance) = @_; + my $mi = $self->associated_class->get_meta_instance; + $mi->set_slot_value( + $instance, + $self->count_slot, + ($mi->get_slot_value($instance, $self->count_slot) || 0) + 1, + ); + } + + sub _clear_count { + my $self = shift; + my ($instance) = @_; + $self->associated_class->get_meta_instance->deinitialize_slot( + $instance, $self->count_slot + ); + } + + sub has_count { + my $self = shift; + my ($instance) = @_; + $self->associated_class->get_meta_instance->has_slot_value( + $instance, $self->count_slot + ); + } + + sub count { + my $self = shift; + my ($instance) = @_; + $self->associated_class->get_meta_instance->get_slot_value( + $instance, $self->count_slot + ); + } + + after set_initial_value => sub { + shift->_set_count(@_); + }; + + after set_value => sub { + shift->_set_count(@_); + }; + + around _inline_instance_set => sub { + my $orig = shift; + my $self = shift; + my ($instance) = @_; + + my $mi = $self->associated_class->get_meta_instance; + + return 'do { ' + . $mi->inline_set_slot_value( + $instance, + $self->count_slot, + $mi->inline_get_slot_value( + $instance, $self->count_slot + ) . ' + 1' + ) . ';' + . $self->$orig(@_) + . '}'; + }; + + after clear_value => sub { + shift->_clear_count(@_); + }; +} + +{ + package Bar; + use Moose; + Moose::Util::MetaRole::apply_metaroles( + for => __PACKAGE__, + class_metaroles => { + attribute => ['Foo::Meta::Attr::Trait'], + }, + ); + + has baz => ( is => 'rw' ); +} + +{ + my $attr = Bar->meta->find_attribute_by_name('baz'); + + my $bar = Bar->new(baz => 1); + is($attr->count($bar), 1, "right count"); + + $bar->baz(2); + is($attr->count($bar), 2, "right count"); + + my $clone = $bar->meta->clone_object($bar); + is($attr->count($clone), $attr->count($bar), "right count"); +} + +done_testing; diff --git a/t/attributes/default_class_role_types.t b/t/attributes/default_class_role_types.t new file mode 100644 index 0000000..c0590ce --- /dev/null +++ b/t/attributes/default_class_role_types.t @@ -0,0 +1,47 @@ +use strict; +use warnings; +use Test::More; +use Test::Fatal; + +use Moose::Util::TypeConstraints; + +{ + package Foo; + use Moose; + + has unknown_class => ( + is => 'ro', + isa => 'UnknownClass', + ); + + has unknown_role => ( + is => 'ro', + does => 'UnknownRole', + ); +} + +{ + my $meta = Foo->meta; + + my $class_tc = $meta->get_attribute('unknown_class')->type_constraint; + isa_ok($class_tc, 'Moose::Meta::TypeConstraint::Class'); + is($class_tc, find_type_constraint('UnknownClass'), + "class type is registered"); + like( + exception { subtype 'UnknownClass', as 'Str'; }, + qr/The type constraint 'UnknownClass' has already been created in Foo and cannot be created again in main/, + "Can't redefine implicitly defined class types" + ); + + my $role_tc = $meta->get_attribute('unknown_role')->type_constraint; + isa_ok($role_tc, 'Moose::Meta::TypeConstraint::Role'); + is($role_tc, find_type_constraint('UnknownRole'), + "role type is registered"); + like( + exception { subtype 'UnknownRole', as 'Str'; }, + qr/The type constraint 'UnknownRole' has already been created in Foo and cannot be created again in main/, + "Can't redefine implicitly defined class types" + ); +} + +done_testing; diff --git a/t/attributes/default_undef.t b/t/attributes/default_undef.t new file mode 100644 index 0000000..5c4bb55 --- /dev/null +++ b/t/attributes/default_undef.t @@ -0,0 +1,23 @@ +use strict; +use warnings; +use Test::More; +use Test::Moose; + +{ + package Foo; + use Moose; + + has foo => ( + is => 'ro', + isa => 'Maybe[Int]', + default => undef, + predicate => 'has_foo', + ); +} + +with_immutable { + is(Foo->new->foo, undef); + ok(Foo->new->has_foo); +} 'Foo'; + +done_testing; diff --git a/t/attributes/delegation_and_modifiers.t b/t/attributes/delegation_and_modifiers.t new file mode 100644 index 0000000..a0b9114 --- /dev/null +++ b/t/attributes/delegation_and_modifiers.t @@ -0,0 +1,54 @@ +use strict; +use warnings; + +use Test::More; + +{ + package Bar; + use Moose; + + sub baz { 'Bar::baz' } + sub gorch { 'Bar::gorch' } + + package Foo; + use Moose; + + has 'bar' => ( + is => 'ro', + isa => 'Bar', + lazy => 1, + default => sub { Bar->new }, + handles => [qw[ baz gorch ]] + ); + + package Foo::Extended; + use Moose; + + 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'); + +done_testing; diff --git a/t/attributes/delegation_arg_aliasing.t b/t/attributes/delegation_arg_aliasing.t new file mode 100644 index 0000000..58a6b0a --- /dev/null +++ b/t/attributes/delegation_arg_aliasing.t @@ -0,0 +1,40 @@ +use strict; +use warnings; +use Test::More; + +{ + package Foo; + use Moose; + + sub aliased { + my $self = shift; + $_[1] = $_[0]; + } +} + +{ + package HasFoo; + use Moose; + + has foo => ( + is => 'ro', + isa => 'Foo', + handles => { + foo_aliased => 'aliased', + foo_aliased_curried => ['aliased', 'bar'], + } + ); +} + +my $hasfoo = HasFoo->new(foo => Foo->new); +my $x; +$hasfoo->foo->aliased('foo', $x); +is($x, 'foo', "direct aliasing works"); +undef $x; +$hasfoo->foo_aliased('foo', $x); +is($x, 'foo', "delegated aliasing works"); +undef $x; +$hasfoo->foo_aliased_curried($x); +is($x, 'bar', "delegated aliasing with currying works"); + +done_testing; diff --git a/t/attributes/delegation_target_not_loaded.t b/t/attributes/delegation_target_not_loaded.t new file mode 100644 index 0000000..3938786 --- /dev/null +++ b/t/attributes/delegation_target_not_loaded.t @@ -0,0 +1,35 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +{ + package X; + + use Moose; + + ::like( + ::exception{ has foo => ( + is => 'ro', + isa => 'Foo', + handles => qr/.*/, + ) + }, + qr/\QThe foo attribute is trying to delegate to a class which has not been loaded - Foo/, + 'cannot delegate to a class which is not yet loaded' + ); + + ::like( + ::exception{ has foo => ( + is => 'ro', + does => 'Role::Foo', + handles => qr/.*/, + ) + }, + qr/\QThe foo attribute is trying to delegate to a role which has not been loaded - Role::Foo/, + 'cannot delegate to a role which is not yet loaded' + ); +} + +done_testing; diff --git a/t/attributes/illegal_options_for_inheritance.t b/t/attributes/illegal_options_for_inheritance.t new file mode 100644 index 0000000..59ce26e --- /dev/null +++ b/t/attributes/illegal_options_for_inheritance.t @@ -0,0 +1,75 @@ +use strict; +use warnings; +use Test::More; +use Test::Fatal; + +{ + package Foo; + use Moose; + + has foo => ( + is => 'ro', + ); + + has bar => ( + clearer => 'clear_bar', + ); +} + +{ + package Foo::Sub; + use Moose; + + extends 'Foo'; + + ::is( ::exception { has '+foo' => (is => 'rw') }, undef, "can override is" ); + ::like( ::exception { has '+foo' => (reader => 'bar') }, qr/illegal/, "can't override reader" ); + ::is( ::exception { has '+foo' => (clearer => 'baz') }, undef, "can override unspecified things" ); + + ::like( ::exception { has '+bar' => (clearer => 'quux') }, qr/illegal/, "can't override clearer" ); + ::is( ::exception { has '+bar' => (predicate => 'has_bar') }, undef, "can override unspecified things" ); +} + +{ + package Bar::Meta::Attribute; + use Moose::Role; + + has my_illegal_option => (is => 'ro'); + + around illegal_options_for_inheritance => sub { + return (shift->(@_), 'my_illegal_option'); + }; +} + +{ + package Bar; + use Moose; + + ::is( ::exception { + has bar => ( + traits => ['Bar::Meta::Attribute'], + my_illegal_option => 'FOO', + is => 'bare', + ); + }, undef, "can use illegal options" ); + + has baz => ( + traits => ['Bar::Meta::Attribute'], + is => 'bare', + ); +} + +{ + package Bar::Sub; + use Moose; + + extends 'Bar'; + + ::like( ::exception { has '+bar' => (my_illegal_option => 'BAR') }, qr/illegal/, "can't override illegal attribute" ); + ::is( ::exception { has '+baz' => (my_illegal_option => 'BAR') }, undef, "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/attributes/inherit_lazy_build.t b/t/attributes/inherit_lazy_build.t new file mode 100644 index 0000000..35919e5 --- /dev/null +++ b/t/attributes/inherit_lazy_build.t @@ -0,0 +1,75 @@ +use strict; +use warnings; + +use Test::More; + +{ + + package Parent; + use Moose; + has attr => ( is => 'rw', isa => 'Str' ); +} + +{ + package Child; + use Moose; + extends 'Parent'; + + has '+attr' => ( lazy_build => 1 ); + + sub _build_attr { + return 'value'; + } +} + +my $parent = Parent->new(); +my $child = Child->new(); + +ok( + !$parent->meta->get_attribute('attr')->is_lazy_build, + 'attribute in parent does not have lazy_build trait' +); +ok( + !$parent->meta->get_attribute('attr')->is_lazy, + 'attribute in parent does not have lazy trait' +); +ok( + !$parent->meta->get_attribute('attr')->has_builder, + 'attribute in parent does not have a builder method' +); +ok( + !$parent->meta->get_attribute('attr')->has_clearer, + 'attribute in parent does not have a clearer method' +); +ok( + !$parent->meta->get_attribute('attr')->has_predicate, + 'attribute in parent does not have a predicate method' +); + +ok( + $child->meta->get_attribute('attr')->is_lazy_build, + 'attribute in child has the lazy_build trait' +); +ok( + $child->meta->get_attribute('attr')->is_lazy, + 'attribute in child has the lazy trait' +); +ok( + $child->meta->get_attribute('attr')->has_builder, + 'attribute in child has a builder method' +); +ok( + $child->meta->get_attribute('attr')->has_clearer, + 'attribute in child has a clearer method' +); +ok( + $child->meta->get_attribute('attr')->has_predicate, + 'attribute in child has a predicate method' +); + +is( + $child->attr, 'value', + 'attribute defined as lazy_build in child is properly built' +); + +done_testing; diff --git a/t/attributes/lazy_no_default.t b/t/attributes/lazy_no_default.t new file mode 100644 index 0000000..c2ff635 --- /dev/null +++ b/t/attributes/lazy_no_default.t @@ -0,0 +1,22 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +{ + package Foo; + use Moose; + + ::like( + ::exception{ has foo => ( + is => 'ro', + lazy => 1, + ); + }, + qr/\QYou cannot have a lazy attribute (foo) without specifying a default value for it/, + 'lazy without a default or builder throws an error' + ); +} + +done_testing; diff --git a/t/attributes/method_generation_rules.t b/t/attributes/method_generation_rules.t new file mode 100644 index 0000000..15cabc0 --- /dev/null +++ b/t/attributes/method_generation_rules.t @@ -0,0 +1,61 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +=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 Moose; 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/); +is( exception {$obj->_foo(1)}, undef, "$class->_foo is writer" ); +is($obj->foo(), 1, "$class->foo is reader"); +isnt( exception {$obj->foo(2)}, undef, "$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/); +is( exception {$obj->_foo(1)}, undef, "$class->_foo is writer" ); +is($obj->foo(), 1, "$class->foo is reader"); +isnt( exception {$obj->foo(1)}, undef, "$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/); +is( exception {$obj->_foo(1)}, undef, "$class->_foo is writer" ); +is($obj->_foo(), 1, "$class->foo is reader"); + +isnt( exception { make_class('ro', 'accessor', "Test::Class::AccessorRO"); }, undef, "Cant define attr with ro + accessor" ); + +done_testing; diff --git a/t/attributes/misc_attribute_coerce_lazy.t b/t/attributes/misc_attribute_coerce_lazy.t new file mode 100644 index 0000000..341e55d --- /dev/null +++ b/t/attributes/misc_attribute_coerce_lazy.t @@ -0,0 +1,48 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + + +{ + package HTTPHeader; + use Moose; + + has 'array' => (is => 'ro'); + has 'hash' => (is => 'ro'); +} + +{ + package Request; + use Moose; + use Moose::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'); + +is( exception { + $r->headers; +}, undef, '... this coerces and passes the type constraint even with lazy' ); + +done_testing; diff --git a/t/attributes/misc_attribute_tests.t b/t/attributes/misc_attribute_tests.t new file mode 100644 index 0000000..7d392aa --- /dev/null +++ b/t/attributes/misc_attribute_tests.t @@ -0,0 +1,270 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + + +{ + { + package Test::Attribute::Inline::Documentation; + use Moose; + + 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 Moose; + use Moose::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'); + + isnt( exception { + $test->bad_lazy_attr; + }, undef, '... this does not work' ); + + is( exception { + $test->good_lazy_attr; + }, undef, '... this does not work' ); +} + +{ + { + package Test::Arrayref::Attributes; + use Moose; + + 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 Moose::Role; + + has [qw(foo bar baz)] => ( + is => 'rw', + ); + + } + { + package Test::Arrayref::RoleAttributes; + use Moose; + 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 Moose; + + has 'foo' => ( + is => 'ro', + isa => 'Str', + default => sub { return } + ); + + } + + isnt( exception { + Test::UndefDefault::Attributes->new; + }, undef, '... default must return a value which passes the type constraint' ); + +} + +{ + { + package OverloadedStr; + use Moose; + 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'); + + like( exception { + $moose_obj->a_str( $moose_obj ) + }, qr/Attribute \(a_str\) does not pass the type constraint because\: Validation failed for 'Str' with value .*OverloadedStr/, '... dies without overloading the string' ); + +} + +{ + { + package OverloadBreaker; + use Moose; + + has 'a_num' => ( isa => 'Int' , is => 'rw', default => 7.5 ); + } + + like( exception { + OverloadBreaker->new; + }, qr/Attribute \(a_num\) does not pass the type constraint because\: Validation failed for 'Int' with value 7\.5/, '... this doesnt trip overload to break anymore ' ); + + is( exception { + OverloadBreaker->new(a_num => 5); + }, undef, '... this works fine though' ); + +} + +{ + { + package Test::Builder::Attribute; + use Moose; + + 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 Moose; + + has 'foo' => ( required => 1, builder => 'build_foo', is => 'ro'); + } + + isnt( exception { + Test::Builder::Attribute::Broken->new; + }, undef, '... no builder, wtf' ); +} + + +{ + { + package Test::LazyBuild::Attribute; + use Moose; + + 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"); + like( exception { $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 Moose; +} + +is( exception { OutOfClassTest::has('foo', is => 'bare'); }, undef, 'create attr via direct sub call' ); +is( exception { OutOfClassTest->can('has')->('bar', is => 'bare'); }, undef, '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 Moose; + + ::like( ::exception { has 'foo' => ( 'ro', isa => 'Str' ) }, qr/\QYou must pass an even number of attribute options/, 'has throws error with odd number of attribute options' ); + } + +} + +done_testing; diff --git a/t/attributes/more_attr_delegation.t b/t/attributes/more_attr_delegation.t new file mode 100644 index 0000000..d40bb03 --- /dev/null +++ b/t/attributes/more_attr_delegation.t @@ -0,0 +1,263 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +=pod + +This tests the more complex +delegation cases and that they +do not fail at compile time. + +=cut + +{ + + package ChildASuper; + use Moose; + + sub child_a_super_method { "as" } + + package ChildA; + use Moose; + + extends "ChildASuper"; + + sub child_a_method_1 { "a1" } + sub child_a_method_2 { Scalar::Util::blessed($_[0]) . " a2" } + + package ChildASub; + use Moose; + + extends "ChildA"; + + sub child_a_method_3 { "a3" } + + package ChildB; + use Moose; + + sub child_b_method_1 { "b1" } + sub child_b_method_2 { "b2" } + sub child_b_method_3 { "b3" } + + package ChildC; + use Moose; + + 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 Moose; + + sub child_d_method_1 { "d1" } + sub child_d_method_2 { "d2" } + + package ChildE; + # no Moose + + sub new { bless {}, shift } + sub child_e_method_1 { "e1" } + sub child_e_method_2 { "e2" } + + package ChildF; + # no Moose + + sub new { bless {}, shift } + sub child_f_method_1 { "f1" } + sub child_f_method_2 { "f2" } + + $INC{'ChildF.pm'} = __FILE__; + + package ChildG; + use Moose; + + sub child_g_method_1 { "g1" } + + package ChildH; + use Moose; + + sub child_h_method_1 { "h1" } + sub parent_method_1 { "child_parent_1" } + + package ChildI; + use Moose; + + sub child_i_method_1 { "i1" } + sub parent_method_1 { "child_parent_1" } + + package Parent; + use Moose; + + sub parent_method_1 { "parent_1" } + ::can_ok('Parent', 'parent_method_1'); + + ::isnt( ::exception { + has child_a => ( + is => "ro", + default => sub { ChildA->new }, + handles => qr/.*/, + ); + }, undef, "all_methods requires explicit isa" ); + + ::is( ::exception { + has child_a => ( + isa => "ChildA", + is => "ro", + default => sub { ChildA->new }, + handles => qr/.*/, + ); + }, undef, "allow all_methods with explicit isa" ); + + ::is( ::exception { + has child_b => ( + is => 'ro', + default => sub { ChildB->new }, + handles => [qw/child_b_method_1/], + ); + }, undef, "don't need to declare isa if method list is predefined" ); + + ::is( ::exception { + has child_c => ( + isa => "ChildC", + is => "ro", + default => sub { ChildC->new }, + handles => qr/_la$/, + ); + }, undef, "can declare regex collector" ); + + ::isnt( ::exception { + has child_d => ( + is => "ro", + default => sub { ChildD->new }, + handles => sub { + my ( $class, $delegate_class ) = @_; + } + ); + }, undef, "can't create attr with generative handles parameter and no isa" ); + + ::is( ::exception { + has child_d => ( + isa => "ChildD", + is => "ro", + default => sub { ChildD->new }, + handles => sub { + my ( $class, $delegate_class ) = @_; + return; + } + ); + }, undef, "can't create attr with generative handles parameter and no isa" ); + + ::is( ::exception { + has child_e => ( + isa => "ChildE", + is => "ro", + default => sub { ChildE->new }, + handles => ["child_e_method_2"], + ); + }, undef, "can delegate to non moose class using explicit method list" ); + + my $delegate_class; + ::is( ::exception { + has child_f => ( + isa => "ChildF", + is => "ro", + default => sub { ChildF->new }, + handles => sub { + $delegate_class = $_[1]->name; + return; + }, + ); + }, undef, "subrefs on non moose class give no meta" ); + + ::is( $delegate_class, "ChildF", "plain classes are handed down to subs" ); + + ::is( ::exception { + has child_g => ( + isa => "ChildG", + default => sub { ChildG->new }, + handles => ["child_g_method_1"], + ); + }, undef, "can delegate to object even without explicit reader" ); + + ::can_ok('Parent', 'parent_method_1'); + ::isnt( ::exception { + has child_h => ( + isa => "ChildH", + is => "ro", + default => sub { ChildH->new }, + handles => sub { map { $_, $_ } $_[1]->get_all_method_names }, + ); + }, undef, "Can't override exisiting class method in delegate" ); + ::can_ok('Parent', 'parent_method_1'); + + ::is( ::exception { + has child_i => ( + isa => "ChildI", + is => "ro", + default => sub { ChildI->new }, + handles => sub { + map { $_, $_ } grep { !/^parent_method_1|meta$/ } + $_[1]->get_all_method_names; + }, + ); + }, undef, "Test handles code ref for skipping predefined methods" ); + + + 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" ); +isa_ok( $p->child_i, "ChildI" ); + +ok(!$p->can('child_g'), '... no child_g accessor defined'); +ok(!$p->can('child_h'), '... no child_h 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)" ); + +can_ok( $p, "child_i_method_1" ); +is( $p->parent_method_1, "parent_1", "delegate doesn't override existing method" ); + +done_testing; diff --git a/t/attributes/no_init_arg.t b/t/attributes/no_init_arg.t new file mode 100644 index 0000000..181e0c2 --- /dev/null +++ b/t/attributes/no_init_arg.t @@ -0,0 +1,32 @@ +use strict; +use warnings; + +use Test::More; + + + +{ + package Foo; + use Moose; + + 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" ); +} + +done_testing; diff --git a/t/attributes/no_slot_access.t b/t/attributes/no_slot_access.t new file mode 100644 index 0000000..22405ba --- /dev/null +++ b/t/attributes/no_slot_access.t @@ -0,0 +1,87 @@ +use strict; +use warnings; + +{ + package SomeAwesomeDB; + + sub new_row { } + sub read { } + sub write { } +} + +{ + package MooseX::SomeAwesomeDBFields; + + # implementation of methods not called in the example deliberately + # omitted + + use Moose::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 Moose; + use Moose::Util::MetaRole; + + use Test::More; + use Test::Fatal; + + Moose::Util::MetaRole::apply_metaroles( + for => __PACKAGE__, + class_metaroles => { instance => ['MooseX::SomeAwesomeDBFields'] }, + ); + + is( exception { + has lazy_attr => ( + is => 'ro', + isa => 'Bool', + lazy => 1, + default => sub {0}, + ); + }, undef, "Adding lazy accessor does not use inline_slot_access" ); + + is( exception { + has rw_attr => ( + is => 'rw', + ); + }, undef, "Adding read-write accessor does not use inline_slot_access" ); + + is( exception { __PACKAGE__->meta->make_immutable; }, undef, "Inling constructor does not use inline_slot_access" ); + + done_testing; +} diff --git a/t/attributes/non_alpha_attr_names.t b/t/attributes/non_alpha_attr_names.t new file mode 100644 index 0000000..f710c88 --- /dev/null +++ b/t/attributes/non_alpha_attr_names.t @@ -0,0 +1,66 @@ +use strict; +use warnings; + +use Test::More; +use Test::Moose; + +{ + package Foo; + use Moose; + has 'type' => ( + required => 0, + reader => 'get_type', + default => 1, + ); + + # Assigning types to these non-alpha attrs exposed a bug in Moose. + has '@type' => ( + isa => 'Str', + required => 0, + reader => 'get_at_type', + writer => 'set_at_type', + default => 'at type', + ); + + has 'has spaces' => ( + isa => 'Int', + required => 0, + reader => 'get_hs', + default => 42, + ); + + has '!req' => ( + required => 1, + reader => 'req' + ); + + no Moose; +} + +with_immutable { + ok( Foo->meta->has_attribute($_), "Foo has '$_' attribute" ) + for 'type', '@type', 'has spaces'; + + my $foo = Foo->new( '!req' => 42 ); + + is( $foo->get_type, 1, q{'type' attribute default is 1} ); + is( $foo->get_at_type, 'at type', q{'@type' attribute default is 1} ); + is( $foo->get_hs, 42, q{'has spaces' attribute default is 42} ); + + $foo = Foo->new( + type => 'foo', + '@type' => 'bar', + 'has spaces' => 200, + '!req' => 84, + ); + + isa_ok( $foo, 'Foo' ); + is( $foo->get_at_type, 'bar', q{reader for '@type'} ); + is( $foo->get_hs, 200, q{reader for 'has spaces'} ); + + $foo->set_at_type(99); + is( $foo->get_at_type, 99, q{writer for '@type' worked} ); +} +'Foo'; + +done_testing; diff --git a/t/attributes/numeric_defaults.t b/t/attributes/numeric_defaults.t new file mode 100644 index 0000000..0691cde --- /dev/null +++ b/t/attributes/numeric_defaults.t @@ -0,0 +1,130 @@ +use strict; +use warnings; +use Test::More; +use Test::Moose; +use B; + +{ + package Foo; + use Moose; + + has foo => (is => 'ro', default => 100); + + sub bar { 100 } +} + +with_immutable { + my $foo = Foo->new; + for my $meth (qw(foo bar)) { + my $val = $foo->$meth; + my $b = B::svref_2object(\$val); + my $flags = $b->FLAGS; + ok($flags & B::SVf_IOK || $flags & B::SVp_IOK, "it's an int"); + ok(!($flags & B::SVf_POK), "not a string"); + } +} 'Foo'; + +{ + package Bar; + use Moose; + + has foo => (is => 'ro', lazy => 1, default => 100); + + sub bar { 100 } +} + +with_immutable { + my $bar = Bar->new; + for my $meth (qw(foo bar)) { + my $val = $bar->$meth; + my $b = B::svref_2object(\$val); + my $flags = $b->FLAGS; + ok($flags & B::SVf_IOK || $flags & B::SVp_IOK, "it's an int"); + ok(!($flags & B::SVf_POK), "not a string"); + } +} 'Bar'; + +{ + package Baz; + use Moose; + + has foo => (is => 'ro', isa => 'Int', lazy => 1, default => 100); + + sub bar { 100 } +} + +with_immutable { + my $baz = Baz->new; + for my $meth (qw(foo bar)) { + my $val = $baz->$meth; + my $b = B::svref_2object(\$val); + my $flags = $b->FLAGS; + ok($flags & B::SVf_IOK || $flags & B::SVp_IOK, "it's an int"); + ok(!($flags & B::SVf_POK), "not a string"); + } +} 'Baz'; + +{ + package Foo2; + use Moose; + + has foo => (is => 'ro', default => 10.5); + + sub bar { 10.5 } +} + +with_immutable { + my $foo2 = Foo2->new; + for my $meth (qw(foo bar)) { + my $val = $foo2->$meth; + my $b = B::svref_2object(\$val); + my $flags = $b->FLAGS; + ok($flags & B::SVf_NOK || $flags & B::SVp_NOK, "it's a num"); + ok(!($flags & B::SVf_POK), "not a string"); + } +} 'Foo2'; + +{ + package Bar2; + use Moose; + + has foo => (is => 'ro', lazy => 1, default => 10.5); + + sub bar { 10.5 } +} + +with_immutable { + my $bar2 = Bar2->new; + for my $meth (qw(foo bar)) { + my $val = $bar2->$meth; + my $b = B::svref_2object(\$val); + my $flags = $b->FLAGS; + ok($flags & B::SVf_NOK || $flags & B::SVp_NOK, "it's a num"); + ok(!($flags & B::SVf_POK), "not a string"); + } +} 'Bar2'; + +{ + package Baz2; + use Moose; + + has foo => (is => 'ro', isa => 'Num', lazy => 1, default => 10.5); + + sub bar { 10.5 } +} + +with_immutable { + my $baz2 = Baz2->new; + for my $meth (qw(foo bar)) { + my $val = $baz2->$meth; + my $b = B::svref_2object(\$val); + my $flags = $b->FLAGS; + ok($flags & B::SVf_NOK || $flags & B::SVp_NOK, "it's a num"); + # it's making sure that the Num value doesn't get converted to a string for regex matching + # this is the reason for using a temporary variable, $val for regex matching, + # instead of $_[1] in Num implementation in lib/Moose/Util/TypeConstraints/Builtins.pm + ok(!($flags & B::SVf_POK), "not a string"); + } +} 'Baz2'; + +done_testing; diff --git a/t/attributes/trigger_and_coerce.t b/t/attributes/trigger_and_coerce.t new file mode 100644 index 0000000..d28b7ce --- /dev/null +++ b/t/attributes/trigger_and_coerce.t @@ -0,0 +1,53 @@ +use strict; +use warnings; + +use Test::More; + + +{ + + package Fake::DateTime; + use Moose; + + has 'string_repr' => ( is => 'ro' ); + + package Mortgage; + use Moose; + use Moose::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' ); +} + +done_testing; diff --git a/t/attributes/type_constraint.t b/t/attributes/type_constraint.t new file mode 100644 index 0000000..16bc981 --- /dev/null +++ b/t/attributes/type_constraint.t @@ -0,0 +1,41 @@ +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +{ + package AttrHasTC; + use Moose; + has foo => ( + is => 'ro', + isa => 'Int', + ); + + has bar => ( + is => 'ro', + ); +} + +ok( + AttrHasTC->meta->get_attribute('foo')->verify_against_type_constraint(42), + 'verify_against_type_constraint returns true with valid Int' +); + +my $e = exception { + AttrHasTC->meta->get_attribute('foo') + ->verify_against_type_constraint('foo'); +}; + +isa_ok( + $e, + 'Moose::Exception::ValidationFailedForTypeConstraint', + 'exception thrown when verify_against_type_constraint fails' +); + +ok( + AttrHasTC->meta->get_attribute('bar')->verify_against_type_constraint(42), + 'verify_against_type_constraint returns true when attr has no TC' +); + +done_testing; |