From 36ea288cc78dedaadd1d3b38331489646be26626 Mon Sep 17 00:00:00 2001 From: Jesse Luehrs Date: Tue, 14 Jun 2011 16:04:36 -0500 Subject: remove test numbers --- t/01-basic.t | 95 --------------- t/02-deps.t | 46 -------- t/03-lifecycle.t | 50 -------- t/04-block.t | 40 ------- t/10-inlining.t | 147 ----------------------- t/11-multiple-instantiation.t | 43 ------- t/12-circular-dependency.t | 59 --------- t/20-inheritance.t | 123 ------------------- t/21-roles.t | 174 --------------------------- t/22-more-inheritance.t | 105 ----------------- t/30-type-checks.t | 46 -------- t/31-auto-deref.t | 47 -------- t/32-defaults.t | 86 -------------- t/33-constructor-name.t | 30 ----- t/34-extends.t | 37 ------ t/35-no-service.t | 75 ------------ t/40-mop.t | 39 ------ t/50-infer.t | 269 ------------------------------------------ t/51-infer-loading.t | 31 ----- t/auto-deref.t | 47 ++++++++ t/basic.t | 95 +++++++++++++++ t/block.t | 40 +++++++ t/circular-dependency.t | 59 +++++++++ t/constructor-name.t | 30 +++++ t/defaults.t | 86 ++++++++++++++ t/deps.t | 46 ++++++++ t/extends.t | 37 ++++++ t/infer-loading.t | 31 +++++ t/infer.t | 269 ++++++++++++++++++++++++++++++++++++++++++ t/inheritance.t | 123 +++++++++++++++++++ t/inlining.t | 147 +++++++++++++++++++++++ t/lifecycle.t | 50 ++++++++ t/mop.t | 39 ++++++ t/more-inheritance.t | 105 +++++++++++++++++ t/multiple-instantiation.t | 43 +++++++ t/no-service.t | 75 ++++++++++++ t/roles.t | 174 +++++++++++++++++++++++++++ t/type-checks.t | 46 ++++++++ 38 files changed, 1542 insertions(+), 1542 deletions(-) delete mode 100644 t/01-basic.t delete mode 100644 t/02-deps.t delete mode 100644 t/03-lifecycle.t delete mode 100644 t/04-block.t delete mode 100644 t/10-inlining.t delete mode 100644 t/11-multiple-instantiation.t delete mode 100644 t/12-circular-dependency.t delete mode 100644 t/20-inheritance.t delete mode 100644 t/21-roles.t delete mode 100644 t/22-more-inheritance.t delete mode 100644 t/30-type-checks.t delete mode 100644 t/31-auto-deref.t delete mode 100644 t/32-defaults.t delete mode 100644 t/33-constructor-name.t delete mode 100644 t/34-extends.t delete mode 100644 t/35-no-service.t delete mode 100644 t/40-mop.t delete mode 100644 t/50-infer.t delete mode 100644 t/51-infer-loading.t create mode 100644 t/auto-deref.t create mode 100644 t/basic.t create mode 100644 t/block.t create mode 100644 t/circular-dependency.t create mode 100644 t/constructor-name.t create mode 100644 t/defaults.t create mode 100644 t/deps.t create mode 100644 t/extends.t create mode 100644 t/infer-loading.t create mode 100644 t/infer.t create mode 100644 t/inheritance.t create mode 100644 t/inlining.t create mode 100644 t/lifecycle.t create mode 100644 t/mop.t create mode 100644 t/more-inheritance.t create mode 100644 t/multiple-instantiation.t create mode 100644 t/no-service.t create mode 100644 t/roles.t create mode 100644 t/type-checks.t (limited to 't') diff --git a/t/01-basic.t b/t/01-basic.t deleted file mode 100644 index d481044..0000000 --- a/t/01-basic.t +++ /dev/null @@ -1,95 +0,0 @@ -#!/usr/bin/env perl -use strict; -use warnings; -use Test::More; -use Test::Moose; - -{ - package Baz; - use Moose; -} - -my $i; -{ - package Foo; - use Moose; - use Moose::Util::TypeConstraints; - use Bread::Board::Declare; - - has foo => ( - is => 'ro', - isa => 'Str', - default => 'FOO', - ); - - subtype 'ArrayRefOfStr', as 'ArrayRef[Str]'; - coerce 'ArrayRefOfStr', from 'Str', via { [$_] }; - - has bar => ( - is => 'ro', - isa => 'ArrayRefOfStr', - coerce => 1, - value => 'BAR', - ); - - has baz => ( - is => 'ro', - isa => 'Baz', - ); - - has baz2 => ( - is => 'ro', - isa => 'Baz', - service => 0, - ); - - has quux => ( - is => 'ro', - isa => 'Str', - block => sub { 'QUUX' . $i++ }, - ); -} - -with_immutable { -$i = 0; -{ - my $foo = Foo->new; - isa_ok($foo, 'Bread::Board::Container'); - ok($foo->has_service($_), "has service $_") - for qw(foo bar baz quux); - ok(!$foo->has_service($_), "doesn't have service $_") - for qw(baz2); - isa_ok($foo->fetch('bar'), 'Bread::Board::Declare::Literal'); - isa_ok($foo->fetch('baz'), 'Bread::Board::Declare::ConstructorInjection'); - isa_ok($foo->fetch('quux'), 'Bread::Board::Declare::BlockInjection'); -} - -{ - my $foo = Foo->new; - is($foo->foo, 'FOO', "normal attrs work"); - is_deeply($foo->bar, ['BAR'], "literals work"); - isa_ok($foo->baz, 'Baz'); - isnt($foo->baz, $foo->baz, "new instance each time"); - is($foo->quux, 'QUUX0', "block injections work"); - is($foo->quux, 'QUUX1', "and they are run on each access"); -} - -{ - my $baz = Baz->new; - my $foo = Foo->new( - foo => 'OOF', - bar => 'RAB', - baz => $baz, - quux => 'XUUQ', - ); - is($foo->foo, 'OOF', "normal attrs work from constructor"); - is_deeply($foo->bar, ['RAB'], "constructor overrides literals"); - isa_ok($foo->baz, 'Baz'); - is($foo->baz, $baz, "constructor overrides constructor injections"); - is($foo->baz, $foo->baz, "and returns the same thing each time"); - is($foo->quux, 'XUUQ', "constructor overrides block injections"); - is($foo->quux, 'XUUQ', "and returns the same thing each time"); -} -} 'Foo'; - -done_testing; diff --git a/t/02-deps.t b/t/02-deps.t deleted file mode 100644 index 21e0c7f..0000000 --- a/t/02-deps.t +++ /dev/null @@ -1,46 +0,0 @@ -#!/usr/bin/env perl -use strict; -use warnings; -use Test::More; -use Test::Moose; - -{ - package Baz; - use Moose; - - has bar => ( - is => 'ro', - isa => 'Str', - required => 1, - ); -} - -my $i; -{ - package Foo; - use Moose; - use Bread::Board::Declare; - - has bar => ( - is => 'ro', - isa => 'Str', - block => sub { $i++ }, - ); - - has baz => ( - is => 'ro', - isa => 'Baz', - dependencies => ['bar'], - ); -} - -with_immutable { - $i = 0; - my $foo = Foo->new; - my $baz = $foo->baz; - is($baz->bar, '0', "deps resolved correctly"); - is($baz->bar, '0', "doesn't re-resolve, since Baz is a normal class"); - is($foo->baz->bar, '1', "re-resolves since the baz attr isn't a singleton"); -} 'Foo'; - -done_testing; diff --git a/t/03-lifecycle.t b/t/03-lifecycle.t deleted file mode 100644 index c101929..0000000 --- a/t/03-lifecycle.t +++ /dev/null @@ -1,50 +0,0 @@ -#!/usr/bin/env perl -use strict; -use warnings; -use Test::More; -use Test::Moose; - -{ - package Baz; - use Moose; - - has bar => ( - is => 'ro', - isa => 'Str', - required => 1, - ); -} - -my $i; -{ - package Foo; - use Moose; - use Bread::Board::Declare; - - has bar => ( - is => 'ro', - isa => 'Str', - block => sub { $i++ }, - ); - - has baz => ( - is => 'ro', - isa => 'Baz', - dependencies => ['bar'], - lifecycle => 'Singleton', - ); -} - -with_immutable { - $i = 0; - my $foo = Foo->new; - my $baz = $foo->baz; - is($baz->bar, '0', "deps resolved correctly"); - is($baz->bar, '0', "doesn't re-resolve, since Baz is a normal class"); - is($foo->baz->bar, '0', - "doesn't re-resolve since the baz attr is a singleton"); - is($foo->baz, $foo->baz, - "doesn't re-resolve since the baz attr is a singleton"); -} 'Foo'; - -done_testing; diff --git a/t/04-block.t b/t/04-block.t deleted file mode 100644 index 3ce9f48..0000000 --- a/t/04-block.t +++ /dev/null @@ -1,40 +0,0 @@ -#!/usr/bin/env perl -use strict; -use warnings; -use Test::More; -use Test::Moose; - -{ - package Foo; - use Moose; - use Bread::Board::Declare; - - has foo => ( - is => 'ro', - isa => 'Str', - default => 'FOO', - ); - - has bar => ( - is => 'ro', - isa => 'Str', - value => 'BAR', - ); - - has baz => ( - is => 'ro', - isa => 'Str', - block => sub { - my ($s, $self) = @_; - return $s->param('bar') . $self->foo; - }, - dependencies => ['bar'], - ); -} - -with_immutable { - my $foo = Foo->new; - is($foo->baz, 'BARFOO', "self is passed properly"); -} 'Foo'; - -done_testing; diff --git a/t/10-inlining.t b/t/10-inlining.t deleted file mode 100644 index cb1b8d8..0000000 --- a/t/10-inlining.t +++ /dev/null @@ -1,147 +0,0 @@ -#!/usr/bin/env perl -use strict; -use warnings; -use Test::More; - -{ - package Foo; - use Moose; - use Bread::Board::Declare; - - has foo => ( - reader => 'get_foo', - writer => 'set_foo', - accessor => 'foo', - predicate => 'has_foo', - clearer => 'clear_foo', - value => 'foo', - ); - - has bool => ( - traits => ['Bool'], - isa => 'Bool', - value => 0, - handles => { - bool_unset => 'unset', - bool_set => 'set', - bool_not => 'not', - bool_toggle => 'toggle', - }, - ); - - has string => ( - traits => ['String'], - isa => 'Str', - value => '', - default => '', # XXX: ugh, needed because of the default_default stuff - handles => { - string_prepend => 'prepend', - string_chop => 'chop', - string_substr => 'substr', - string_match => 'match', - string_length => 'length', - string_inc => 'inc', - string_append => 'append', - string_clear => 'clear', - string_chomp => 'chomp', - string_replace => 'replace', - }, - ); - - has hash => ( - traits => ['Hash'], - isa => 'HashRef', - block => sub { {} }, - handles => { - hash_delete => 'delete', - hash_exists => 'exists', - hash_values => 'values', - hash_get => 'get', - hash_set => 'set', - hash_is_empty => 'is_empty', - hash_keys => 'keys', - hash_elements => 'elements', - hash_kv => 'kv', - hash_defined => 'defined', - hash_accessor => 'accessor', - hash_count => 'count', - hash_clear => 'clear', - }, - ); - - has counter => ( - traits => ['Counter'], - isa => 'Int', - value => 0, - default => 0, # XXX: ugh, needed because of the default_default stuff - handles => { - counter_set => 'set', - counter_reset => 'reset', - counter_inc => 'inc', - counter_dec => 'dec', - }, - ); - - has code => ( - traits => ['Code'], - isa => 'CodeRef', - block => sub { sub { } }, - handles => { - code_execute => 'execute', - code_execute_method => 'execute_method', - }, - ); - - has array => ( - traits => ['Array'], - isa => 'ArrayRef', - block => sub { [] }, - handles => { - array_unshift => 'unshift', - array_shuffle => 'shuffle', - array_delete => 'delete', - array_get => 'get', - array_set => 'set', - array_uniq => 'uniq', - array_is_empty => 'is_empty', - array_shift => 'shift', - array_grep => 'grep', - array_sort_in_place => 'sort_in_place', - array_sort => 'sort', - array_elements => 'elements', - array_pop => 'pop', - array_reduce => 'reduce', - array_insert => 'insert', - array_join => 'join', - array_first => 'first', - array_natatime => 'natatime', - array_accessor => 'accessor', - array_count => 'count', - array_map => 'map', - array_push => 'push', - array_clear => 'clear', - array_splice => 'splice', - }, - ); - - has number => ( - traits => ['Number'], - isa => 'Num', - value => 1, - handles => { - number_add => 'add', - number_set => 'set', - number_sub => 'sub', - number_mul => 'mul', - number_mod => 'mod', - number_abs => 'abs', - number_div => 'div', - }, - ); - - __PACKAGE__->meta->make_immutable; -} - -pass("everything compiled successfully"); - -done_testing; diff --git a/t/11-multiple-instantiation.t b/t/11-multiple-instantiation.t deleted file mode 100644 index c8372c1..0000000 --- a/t/11-multiple-instantiation.t +++ /dev/null @@ -1,43 +0,0 @@ -#!/usr/bin/env perl -use strict; -use warnings; -use Test::More; -use Test::Moose; - -{ - package Bar; - use Moose; - - has foo => ( - is => 'ro', - isa => 'Str', - required => 1, - ); -} - -{ - package Foo; - use Moose; - use Bread::Board::Declare; - - has foo => ( - is => 'ro', - isa => 'Str', - value => 'FOO', - ); - - has bar => ( - is => 'ro', - isa => 'Bar', - dependencies => ['foo'], - ); -} - -with_immutable { -my $foo1 = Foo->new; -is($foo1->bar->foo, 'FOO'); -my $foo2 = Foo->new(foo => 'BAR'); -is($foo2->bar->foo, 'BAR'); -} 'Foo'; - -done_testing; diff --git a/t/12-circular-dependency.t b/t/12-circular-dependency.t deleted file mode 100644 index 28431c9..0000000 --- a/t/12-circular-dependency.t +++ /dev/null @@ -1,59 +0,0 @@ -#!/usr/bin/env perl -use strict; -use warnings; -use Test::More; -use Test::Fatal; - -{ - package Foo; - use Moose; - - has bar => ( - is => 'rw', - isa => 'Bar', - ); -} - -{ - package Bar; - use Moose; - - has foo => ( - is => 'rw', - isa => 'Foo', - weak_ref => 1, - ); -} - -{ - package MyApp; - use Moose; - use Bread::Board::Declare; - - has foo => ( - is => 'ro', - isa => 'Foo', - block => sub { - my ($s, $self) = @_; - Foo->new(bar => $s->param('bar')); - }, - lifecycle => 'Singleton', - dependencies => ['bar'], - ); - has bar => ( - is => 'ro', - isa => 'Bar', - block => sub { - my ($s, $self) = @_; - Bar->new(foo => $s->param('foo')); - }, - lifecycle => 'Singleton', - dependencies => ['foo'], - ); -} - - -is exception { MyApp->new->foo->bar }, undef, - 'circular block-injection deps should survive'; - -done_testing(); diff --git a/t/20-inheritance.t b/t/20-inheritance.t deleted file mode 100644 index b1517e8..0000000 --- a/t/20-inheritance.t +++ /dev/null @@ -1,123 +0,0 @@ -#!/usr/bin/env perl -use strict; -use warnings; -use Test::More; -use Test::Moose; - -{ - package Parent; - use Moose; - use Bread::Board::Declare; - - has foo => ( - is => 'ro', - isa => 'Str', - value => 'FOO', - ); - - has bar => ( - is => 'ro', - isa => 'Str', - block => sub { - my $s = shift; - return $s->param('foo') . 'BAR'; - }, - dependencies => ['foo'], - ); -} - -{ - package Child; - use Moose; - use Bread::Board::Declare; - - extends 'Parent'; - - has baz => ( - is => 'ro', - isa => 'Str', - value => 'BAZ', - ); - - has quux => ( - is => 'ro', - isa => 'Str', - block => sub { - my $s = shift; - return $s->param('foo') - . $s->param('bar') - . $s->param('baz') - . 'QUUX'; - }, - dependencies => ['foo', 'bar', 'baz'], - ); -} - -with_immutable { -{ - my $parent = Parent->new; - ok($parent->has_service('foo'), "parent has foo"); - ok($parent->has_service('bar'), "parent has bar"); - - my $child = Child->new; - ok($child->has_service('foo'), "child has foo"); - ok($child->has_service('bar'), "child has bar"); - ok($child->has_service('baz'), "child has baz"); - ok($child->has_service('quux'), "child has quux"); -} - -{ - my $parent = Parent->new; - isa_ok($parent, 'Bread::Board::Container'); - is($parent->foo, 'FOO'); - is($parent->bar, 'FOOBAR'); -} - -{ - my $parent = Parent->new(foo => 'OOF', bar => 'RAB'); - isa_ok($parent, 'Bread::Board::Container'); - is($parent->foo, 'OOF'); - is($parent->bar, 'RAB'); -} - -{ - my $parent = Parent->new(foo => 'OOF'); - isa_ok($parent, 'Bread::Board::Container'); - is($parent->foo, 'OOF'); - is($parent->bar, 'OOFBAR'); -} - -{ - my $child = Child->new; - is($child->foo, 'FOO'); - is($child->bar, 'FOOBAR'); - is($child->baz, 'BAZ'); - is($child->quux, 'FOOFOOBARBAZQUUX'); -} - -{ - my $child = Child->new( - foo => 'OOF', - bar => 'RAB', - baz => 'ZAB', - quux => 'XUUQ', - ); - is($child->foo, 'OOF'); - is($child->bar, 'RAB'); - is($child->baz, 'ZAB'); - is($child->quux, 'XUUQ'); -} - -{ - my $child = Child->new( - foo => 'OOF', - baz => 'ZAB', - ); - is($child->foo, 'OOF'); - is($child->bar, 'OOFBAR'); - is($child->baz, 'ZAB'); - is($child->quux, 'OOFOOFBARZABQUUX'); -} -} 'Parent', 'Child'; - -done_testing; diff --git a/t/21-roles.t b/t/21-roles.t deleted file mode 100644 index 704b13c..0000000 --- a/t/21-roles.t +++ /dev/null @@ -1,174 +0,0 @@ -#!/usr/bin/env perl -use strict; -use warnings; -use Test::More; -use Test::Moose; - -{ - package Role1; - use Moose::Role; - use Bread::Board::Declare; - - has role1 => ( - (Moose->VERSION < 1.9900 - ? (traits => ['Service']) - : ()), - is => 'ro', - isa => 'Str', - value => 'ROLE1', - ); -} - -{ - package Parent; - use Moose; - use Bread::Board::Declare; - - with 'Role1'; - - has foo => ( - is => 'ro', - isa => 'Str', - value => 'FOO', - ); - - has bar => ( - is => 'ro', - isa => 'Str', - block => sub { - my $s = shift; - return $s->param('foo') . 'BAR' . $s->param('role1'); - }, - dependencies => ['foo', 'role1'], - ); -} - -{ - package Role2; - use Moose::Role; - use Bread::Board::Declare; - - has role2 => ( - (Moose->VERSION < 1.9900 - ? (traits => ['Service']) - : ()), - is => 'ro', - isa => 'Str', - value => 'ROLE2', - ); -} - -{ - package Child; - use Moose; - use Bread::Board::Declare; - - extends 'Parent'; - with 'Role2'; - - has baz => ( - is => 'ro', - isa => 'Str', - value => 'BAZ', - ); - - has quux => ( - is => 'ro', - isa => 'Str', - block => sub { - my $s = shift; - return $s->param('foo') - . $s->param('bar') - . $s->param('baz') - . $s->param('role1') - . $s->param('role2') - . 'QUUX'; - }, - dependencies => ['foo', 'bar', 'baz', 'role1', 'role2'], - ); -} - -with_immutable { -{ - my $parent = Parent->new; - ok($parent->has_service('role1'), "parent has role1"); - ok($parent->has_service('foo'), "parent has foo"); - ok($parent->has_service('bar'), "parent has bar"); - - my $child = Child->new; - ok($child->has_service('role1'), "child has role1"); - ok($child->has_service('foo'), "child has foo"); - ok($child->has_service('bar'), "child has bar"); - ok($child->has_service('role2'), "child has role2"); - ok($child->has_service('baz'), "child has baz"); - ok($child->has_service('quux'), "child has quux"); -} - -{ - my $parent = Parent->new; - isa_ok($parent, 'Bread::Board::Container'); - is($parent->role1, 'ROLE1'); - is($parent->foo, 'FOO'); - is($parent->bar, 'FOOBARROLE1'); -} - -{ - my $parent = Parent->new(role1 => '1ELOR', foo => 'OOF', bar => 'RAB'); - isa_ok($parent, 'Bread::Board::Container'); - is($parent->role1, '1ELOR'); - is($parent->foo, 'OOF'); - is($parent->bar, 'RAB'); -} - -{ - my $parent = Parent->new(role1 => '1ELOR', foo => 'OOF'); - isa_ok($parent, 'Bread::Board::Container'); - is($parent->role1, '1ELOR'); - is($parent->foo, 'OOF'); - is($parent->bar, 'OOFBAR1ELOR'); -} - -{ - my $child = Child->new; - is($child->role1, 'ROLE1'); - is($child->foo, 'FOO'); - is($child->bar, 'FOOBARROLE1'); - is($child->role2, 'ROLE2'); - is($child->baz, 'BAZ'); - is($child->quux, 'FOOFOOBARROLE1BAZROLE1ROLE2QUUX'); -} - -{ - my $child = Child->new( - role1 => '1ELOR', - foo => 'OOF', - bar => 'RAB', - role2 => '2ELOR', - baz => 'ZAB', - quux => 'XUUQ', - ); - is($child->role1, '1ELOR'); - is($child->foo, 'OOF'); - is($child->bar, 'RAB'); - is($child->role2, '2ELOR'); - is($child->baz, 'ZAB'); - is($child->quux, 'XUUQ'); -} - -{ - my $child = Child->new( - role1 => '1ELOR', - foo => 'OOF', - role2 => '2ELOR', - baz => 'ZAB', - ); - is($child->role1, '1ELOR'); - is($child->foo, 'OOF'); - is($child->bar, 'OOFBAR1ELOR'); - is($child->role2, '2ELOR'); - is($child->baz, 'ZAB'); - is($child->quux, 'OOFOOFBAR1ELORZAB1ELOR2ELORQUUX'); -} -} 'Parent', 'Child'; - -done_testing; diff --git a/t/22-more-inheritance.t b/t/22-more-inheritance.t deleted file mode 100644 index 94d726c..0000000 --- a/t/22-more-inheritance.t +++ /dev/null @@ -1,105 +0,0 @@ -#!/usr/bin/env perl -use strict; -use warnings; -use Test::More; -use Test::Moose; - -{ - package Parent; - use Moose; - use Bread::Board::Declare; - - has foo => ( - is => 'ro', - isa => 'Str', - value => 'parent', - ); - - has bar => ( - is => 'ro', - isa => 'Str', - block => sub { - my $s = shift; - return $s->param('foo') . ' ' . 'parent'; - }, - dependencies => ['foo'], - ); -} - -{ - package Child1; - use Moose; - use Bread::Board::Declare; - - extends 'Parent'; - - has foo => ( - is => 'ro', - isa => 'Str', - value => 'child', - ); -} - -{ - package Child2; - use Moose; - use Bread::Board::Declare; - - extends 'Parent'; - - has bar => ( - is => 'ro', - isa => 'Str', - block => sub { - my $s = shift; - return $s->param('foo') . ' ' . 'child'; - }, - dependencies => ['foo'], - ); -} - -{ - package Child3; - use Moose; - use Bread::Board::Declare; - - extends 'Child1'; - - has bar => ( - is => 'ro', - isa => 'Str', - block => sub { - my $s = shift; - return $s->param('foo') . ' ' . 'child'; - }, - dependencies => ['foo'], - ); -} - -with_immutable { -{ - my $obj = Parent->new; - is($obj->foo, 'parent'); - is($obj->bar, 'parent parent'); -} - -{ - my $obj = Child1->new; - is($obj->foo, 'child'); - is($obj->bar, 'child parent'); -} - -{ - my $obj = Child2->new; - is($obj->foo, 'parent'); - is($obj->bar, 'parent child'); -} - -{ - my $obj = Child3->new; - is($obj->foo, 'child'); - is($obj->bar, 'child child'); -} -} 'Parent', 'Child1', 'Child2', 'Child3'; - -done_testing; diff --git a/t/30-type-checks.t b/t/30-type-checks.t deleted file mode 100644 index 0641d98..0000000 --- a/t/30-type-checks.t +++ /dev/null @@ -1,46 +0,0 @@ -#!/usr/bin/env perl -use strict; -use warnings; -use Test::More; -use Test::Fatal; -use Test::Moose; - -{ - package Foo; - use Moose; - use Bread::Board::Declare; - - has foo => ( - is => 'ro', - isa => 'Ref', - value => 'FOO', - ); - - has bar => ( - is => 'ro', - isa => 'Str', - block => sub { { foo => 'bar' } }, - ); - - has baz => ( - is => 'ro', - isa => 'HashRef', - block => sub { shift->param('bar') }, - dependencies => ['bar'], - ); -} - -with_immutable { - my $foo = Foo->new; - like(exception { $foo->foo }, - qr/^Attribute \(foo\) does not pass the type constraint because: Validation failed for 'Ref' with value .*FOO/, - "error when service returns invalid value"); - like(exception { $foo->bar }, - qr/^Attribute \(bar\) does not pass the type constraint because: Validation failed for 'Str' with value .*(?:HASH|foo.*bar)/, - "error when service returns invalid value"); - like(exception { $foo->baz }, - qr/^Attribute \(bar\) does not pass the type constraint because: Validation failed for 'Str' with value .*(?:HASH|foo.*bar)/, - "error when service returns invalid value, even as a dependency"); -} 'Foo'; - -done_testing; diff --git a/t/31-auto-deref.t b/t/31-auto-deref.t deleted file mode 100644 index 06762f6..0000000 --- a/t/31-auto-deref.t +++ /dev/null @@ -1,47 +0,0 @@ -#!/usr/bin/env perl -use strict; -use warnings; -use Test::More; -use Test::Moose; - -{ - package Foo; - use Moose; - use Bread::Board::Declare; - - has foo => ( - is => 'ro', - isa => 'ArrayRef', - auto_deref => 1, - block => sub { ['foo', 'bar'] }, - ); - - has bar => ( - is => 'ro', - isa => 'HashRef', - auto_deref => 1, - block => sub { {'foo' => 'bar'} }, - ); -} - -with_immutable { -{ - my $foo = Foo->new; - - is_deeply(scalar($foo->foo), ['foo', 'bar'], "scalar array"); - is_deeply([$foo->foo], ['foo', 'bar'], "list array"); - is_deeply(scalar($foo->bar), {'foo', 'bar'}, "scalar hash"); - is_deeply({$foo->foo}, {'foo', 'bar'}, "list hash"); -} - -{ - my $foo = Foo->new(foo => ['foo', 'bar'], bar => {'foo' => 'bar'}); - - is_deeply(scalar($foo->foo), ['foo', 'bar'], "scalar array"); - is_deeply([$foo->foo], ['foo', 'bar'], "list array"); - is_deeply(scalar($foo->bar), {'foo', 'bar'}, "scalar hash"); - is_deeply({$foo->foo}, {'foo', 'bar'}, "list hash"); -} -} 'Foo'; - -done_testing; diff --git a/t/32-defaults.t b/t/32-defaults.t deleted file mode 100644 index 7350d52..0000000 --- a/t/32-defaults.t +++ /dev/null @@ -1,86 +0,0 @@ -#!/usr/bin/env perl -use strict; -use warnings; -use Test::More; -use Test::Fatal; - -{ - package Foo; - use Moose; - use Bread::Board::Declare; - - ::like(::exception { - has foo => ( - is => 'ro', - isa => 'Str', - default => 'OOF', - value => 'FOO', - ); - }, qr/default is not valid when Bread::Board service options are set/, - "can't set a default when creating a service"); - - ::like(::exception { - has bar => ( - is => 'ro', - isa => 'Str', - default => sub { 'OOF' }, - value => 'FOO', - ); - }, qr/default is not valid when Bread::Board service options are set/, - "can't set a default when creating a service"); - - ::like(::exception { - has bar2 => ( - is => 'ro', - isa => 'Str', - builder => '_build_bar2', - value => 'FOO', - ); - }, qr/builder is not valid when Bread::Board service options are set/, - "can't set a builder when creating a service"); - - ::like(::exception { - has baz => ( - is => 'ro', - isa => 'Str', - lazy => 1, - default => 'OOF', - value => 'FOO', - ); - }, qr/default is not valid when Bread::Board service options are set/, - "can't set a default when creating a service"); - - ::like(::exception { - has quux => ( - is => 'ro', - isa => 'Str', - lazy => 1, - default => sub { 'OOF' }, - value => 'FOO', - ); - }, qr/default is not valid when Bread::Board service options are set/, - "can't set a default when creating a service"); - - ::like(::exception { - has quux2 => ( - is => 'ro', - isa => 'Str', - lazy => 1, - builder => '_build_quux2', - value => 'FOO', - ); - }, qr/builder is not valid when Bread::Board service options are set/, - "can't set a builder when creating a service"); - - ::like(::exception { - has quux3 => ( - is => 'ro', - isa => 'Str', - lazy_build => 1, - value => 'FOO', - ); - }, qr/builder is not valid when Bread::Board service options are set/, - "can't set lazy_build when creating a service"); -} - -done_testing; diff --git a/t/33-constructor-name.t b/t/33-constructor-name.t deleted file mode 100644 index 5ae1258..0000000 --- a/t/33-constructor-name.t +++ /dev/null @@ -1,30 +0,0 @@ -#!/usr/bin/env perl -use strict; -use warnings; -use Test::More; -use Test::Moose; - -{ - package Bar; - - sub create { bless {}, shift } -} - -{ - package Foo; - use Moose; - use Bread::Board::Declare; - - has bar => ( - is => 'ro', - isa => 'Bar', - constructor_name => 'create', - ); -} - -with_immutable { - my $foo = Foo->new; - isa_ok($foo->bar, 'Bar'); -} 'Foo'; - -done_testing; diff --git a/t/34-extends.t b/t/34-extends.t deleted file mode 100644 index 8e45869..0000000 --- a/t/34-extends.t +++ /dev/null @@ -1,37 +0,0 @@ -#!/usr/bin/env perl -use strict; -use warnings; -use Test::More; -use Test::Fatal; - -{ - package Bar; - use Moose; -} - -{ - package Baz; - use Moose; - use Bread::Board::Declare; -} - -{ - package Quux; - use Moose; - use Bread::Board::Declare; -} - -{ - package Foo; - use Moose; - use Bread::Board::Declare; - - ::like(::exception { extends 'Bar' }, - qr/^Cannot inherit from Bar because Bread::Board::Declare classes must inherit from Bread::Board::Container/, - "error when inheriting from a non-container"); - ::like(::exception { extends 'Baz', 'Quux' }, - qr/^Multiple inheritance is not supported for Bread::Board::Declare classes/, - "error when inheriting from multiple containers"); -} - -done_testing; diff --git a/t/35-no-service.t b/t/35-no-service.t deleted file mode 100644 index aeb4c48..0000000 --- a/t/35-no-service.t +++ /dev/null @@ -1,75 +0,0 @@ -#!/usr/bin/env perl -use strict; -use warnings; -use Test::More; -use Test::Fatal; -use Test::Moose; - -{ - package Bar; - use Moose; -} - -{ - package Foo; - use Moose; - use Bread::Board::Declare; - - has foo => ( - is => 'ro', - isa => 'Str', - ); - - has bar => ( - is => 'ro', - isa => 'Bar', - service => 0, - ); - - has baz => ( - is => 'ro', - isa => 'Str', - block => sub { shift->param('foo') }, - dependencies => ['foo'], - ); - - has quux => ( - is => 'ro', - isa => 'Bar', - block => sub { shift->param('bar') }, - dependencies => ['bar'], - ); -} - -with_immutable { -{ - my $foo = Foo->new; - ok($foo->has_service($_), "has service $_") for qw(foo baz); - ok(!$foo->has_service($_), "doesn't have service $_") for qw(bar); -} - -{ - my $foo = Foo->new; - like( - exception { $foo->baz }, - qr/^Attribute foo did not specify a service\. It must be given a value through the constructor or writer method before it can be resolved\./, - "got the right error when foo isn't set" - ); -} - -{ - my $foo = Foo->new(foo => 'bar'); - is($foo->baz, 'bar', "didn't get an error when foo is set"); -} - -{ - my $foo = Foo->new; - like( - exception { $foo->quux }, - qr/^Could not find container or service for bar in Foo/, - "can't depend on attrs with no service" - ); -} -} 'Foo'; - -done_testing; diff --git a/t/40-mop.t b/t/40-mop.t deleted file mode 100644 index c3a943f..0000000 --- a/t/40-mop.t +++ /dev/null @@ -1,39 +0,0 @@ -#!/usr/bin/env perl -use strict; -use warnings; -use Test::More; -use Test::Moose; - -{ - package Foo; - use Moose; - use Bread::Board::Declare; - - has foo => ( - is => 'ro', - isa => 'Str', - value => 'FOO', - ); - - has bar => ( - is => 'ro', - isa => 'Str', - block => sub { - my $s = shift; - return $s->param('foo') . 'BAR'; - }, - dependencies => ['foo'], - ); -} - -with_immutable { - my $foo = Foo->new; - my $foo_attr = $foo->meta->get_attribute('foo'); - my $bar_attr = $foo->meta->get_attribute('bar'); - is($foo_attr->get_value($foo), 'FOO', "right value"); - is($bar_attr->get_value($foo), 'FOOBAR', "right value"); - ok(!$foo_attr->has_value($foo), "no value"); - ok(!$bar_attr->has_value($foo), "no value"); -} 'Foo'; - -done_testing; diff --git a/t/50-infer.t b/t/50-infer.t deleted file mode 100644 index 2b064a3..0000000 --- a/t/50-infer.t +++ /dev/null @@ -1,269 +0,0 @@ -#!/usr/bin/env perl -use strict; -use warnings; -use Test::More; -use Test::Fatal; - -{ - package Foo; - use Moose; - - has data => ( - is => 'ro', - isa => 'Str', - default => 'FOO', - ); -} - -{ - package Bar; - use Moose; -} - -{ - package Baz; - use Moose; - - has foo => ( - is => 'ro', - isa => 'Foo', - required => 1, - ); - - has bar => ( - is => 'ro', - isa => 'Bar', - required => 1, - ); - - has thing => ( - is => 'ro', - isa => 'Str', - ); -} - -{ - package My::Container; - use Moose; - use Bread::Board::Declare; - - has baz => ( - is => 'ro', - isa => 'Baz', - infer => 1, - ); - - has baz_no_infer => ( - is => 'ro', - isa => 'Baz', - ); -} - -{ - my $c = My::Container->new; - isa_ok($c->baz, 'Baz'); - isa_ok($c->baz->foo, 'Foo'); - isa_ok($c->baz->bar, 'Bar'); - - is($c->baz->thing, undef, "right thing"); - is($c->baz->foo->data, 'FOO', "right data"); - - isa_ok($c->resolve(type => 'Baz'), 'Baz'); -} - -{ - my $c = My::Container->new; - like( - exception { $c->baz_no_infer }, - qr/^Attribute \(bar\) is required/, - "not inferred when not requested" - ); -} - -{ - package Baz2; - use Moose; - - extends 'Baz'; - - has '+thing' => ( - required => 1, - ); -} - -{ - package My::Container2; - use Moose; - use Bread::Board::Declare; - - has baz => ( - is => 'ro', - isa => 'Baz2', - infer => 1, - ); -} - -{ - like( - exception { My::Container2->new }, - qr/^Only class types, role types, or subtypes of Object can be inferred\. I don't know what to do with type \(Str\)/, - "correct error when not everything can be inferred" - ); -} - -{ - package My::Container3; - use Moose; - use Bread::Board::Declare; - - has thing => ( - is => 'ro', - isa => 'Str', - value => 'THING', - ); - - has foo => ( - is => 'ro', - isa => 'Foo', - dependencies => { data => 'thing' }, - ); - - has baz => ( - is => 'ro', - isa => 'Baz2', - infer => 1, - dependencies => ['thing'], - ); -} - -{ - my $c = My::Container3->new; - isa_ok($c->baz, 'Baz2'); - isa_ok($c->baz->foo, 'Foo'); - isa_ok($c->baz->bar, 'Bar'); - - is( - $c->fetch('baz')->get_dependency('foo')->service, - $c->fetch('foo'), - "inferred the right dependency" - ); - - is($c->baz->foo->data, 'THING', - "inference finds services in the container"); - is($c->baz->thing, 'THING', "partial dependency specification works"); -} - -{ - package Quux; - use Moose; - - has baz => ( - is => 'ro', - isa => 'Baz', - required => 1, - ); - - has foo => ( - is => 'ro', - isa => 'Foo', - ); -} - -{ - package My::Container4; - use Moose; - use Bread::Board::Declare; - - has data => ( - is => 'ro', - isa => 'Str', - value => 'DATA', - ); - - has quux => ( - is => 'ro', - isa => 'Quux', - infer => 1, - ); - - has foo => ( - is => 'ro', - isa => 'Foo', - dependencies => ['data'], - ); - - has quux2 => ( - is => 'ro', - isa => 'Quux', - infer => 1, - dependencies => ['foo'], - ); -} - -{ - my $c = My::Container4->new; - isa_ok($c->quux, 'Quux'); - isa_ok($c->quux->baz, 'Baz'); - isa_ok($c->quux->baz->foo, 'Foo'); - isa_ok($c->quux->baz->bar, 'Bar'); - - is($c->quux->foo, undef, "non-required attrs are not inferred"); - is($c->quux2->foo->data, 'DATA', "but can be explicitly specified"); -} - -{ - package State; - use Moose; - - has counter => ( - traits => ['Counter'], - is => 'rw', - isa => 'Int', - handles => { inc => 'inc' }, - default => 0, - ); -} - -{ - package Controller; - use Moose; - - has counter => ( - is => 'ro', - isa => 'State', - required => 1, - handles => { inc => 'inc', counter_val => 'counter' }, - ); -} - -{ - package App; - use Moose; - use Bread::Board::Declare; - - has counter => ( - is => 'ro', - isa => 'State', - lifecycle => 'Singleton', - ); - - has controller => ( - is => 'ro', - isa => 'Controller', - infer => 1, - ); -} - -{ - my $c = App->new; - is( - $c->fetch('controller')->get_dependency('counter')->service, - $c->fetch('counter'), - "inferred the right dependency" - ); - $c->controller->inc; - $c->controller->inc; - is($c->controller->counter_val, 2, "state persisted as a singleton"); -} - -done_testing; diff --git a/t/51-infer-loading.t b/t/51-infer-loading.t deleted file mode 100644 index 97e98d3..0000000 --- a/t/51-infer-loading.t +++ /dev/null @@ -1,31 +0,0 @@ -#!/usr/bin/env perl -use strict; -use warnings; -use Test::More; -use lib 't/lib'; - -{ - package Foo; - use Moose; - use Bread::Board::Declare; - - has foo => ( - is => 'ro', - isa => 'Inferred::Foo', - infer => 1, - ); - - has bar => ( - is => 'ro', - isa => 'Inferred::Bar', - ); -} - -{ - my $c = Foo->new; - isa_ok($c->foo, 'Inferred::Foo'); - isa_ok($c->foo->bar, 'Inferred::Bar'); - isa_ok($c->bar, 'Inferred::Bar'); -} - -done_testing; diff --git a/t/auto-deref.t b/t/auto-deref.t new file mode 100644 index 0000000..06762f6 --- /dev/null +++ b/t/auto-deref.t @@ -0,0 +1,47 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; +use Test::Moose; + +{ + package Foo; + use Moose; + use Bread::Board::Declare; + + has foo => ( + is => 'ro', + isa => 'ArrayRef', + auto_deref => 1, + block => sub { ['foo', 'bar'] }, + ); + + has bar => ( + is => 'ro', + isa => 'HashRef', + auto_deref => 1, + block => sub { {'foo' => 'bar'} }, + ); +} + +with_immutable { +{ + my $foo = Foo->new; + + is_deeply(scalar($foo->foo), ['foo', 'bar'], "scalar array"); + is_deeply([$foo->foo], ['foo', 'bar'], "list array"); + is_deeply(scalar($foo->bar), {'foo', 'bar'}, "scalar hash"); + is_deeply({$foo->foo}, {'foo', 'bar'}, "list hash"); +} + +{ + my $foo = Foo->new(foo => ['foo', 'bar'], bar => {'foo' => 'bar'}); + + is_deeply(scalar($foo->foo), ['foo', 'bar'], "scalar array"); + is_deeply([$foo->foo], ['foo', 'bar'], "list array"); + is_deeply(scalar($foo->bar), {'foo', 'bar'}, "scalar hash"); + is_deeply({$foo->foo}, {'foo', 'bar'}, "list hash"); +} +} 'Foo'; + +done_testing; diff --git a/t/basic.t b/t/basic.t new file mode 100644 index 0000000..d481044 --- /dev/null +++ b/t/basic.t @@ -0,0 +1,95 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; +use Test::Moose; + +{ + package Baz; + use Moose; +} + +my $i; +{ + package Foo; + use Moose; + use Moose::Util::TypeConstraints; + use Bread::Board::Declare; + + has foo => ( + is => 'ro', + isa => 'Str', + default => 'FOO', + ); + + subtype 'ArrayRefOfStr', as 'ArrayRef[Str]'; + coerce 'ArrayRefOfStr', from 'Str', via { [$_] }; + + has bar => ( + is => 'ro', + isa => 'ArrayRefOfStr', + coerce => 1, + value => 'BAR', + ); + + has baz => ( + is => 'ro', + isa => 'Baz', + ); + + has baz2 => ( + is => 'ro', + isa => 'Baz', + service => 0, + ); + + has quux => ( + is => 'ro', + isa => 'Str', + block => sub { 'QUUX' . $i++ }, + ); +} + +with_immutable { +$i = 0; +{ + my $foo = Foo->new; + isa_ok($foo, 'Bread::Board::Container'); + ok($foo->has_service($_), "has service $_") + for qw(foo bar baz quux); + ok(!$foo->has_service($_), "doesn't have service $_") + for qw(baz2); + isa_ok($foo->fetch('bar'), 'Bread::Board::Declare::Literal'); + isa_ok($foo->fetch('baz'), 'Bread::Board::Declare::ConstructorInjection'); + isa_ok($foo->fetch('quux'), 'Bread::Board::Declare::BlockInjection'); +} + +{ + my $foo = Foo->new; + is($foo->foo, 'FOO', "normal attrs work"); + is_deeply($foo->bar, ['BAR'], "literals work"); + isa_ok($foo->baz, 'Baz'); + isnt($foo->baz, $foo->baz, "new instance each time"); + is($foo->quux, 'QUUX0', "block injections work"); + is($foo->quux, 'QUUX1', "and they are run on each access"); +} + +{ + my $baz = Baz->new; + my $foo = Foo->new( + foo => 'OOF', + bar => 'RAB', + baz => $baz, + quux => 'XUUQ', + ); + is($foo->foo, 'OOF', "normal attrs work from constructor"); + is_deeply($foo->bar, ['RAB'], "constructor overrides literals"); + isa_ok($foo->baz, 'Baz'); + is($foo->baz, $baz, "constructor overrides constructor injections"); + is($foo->baz, $foo->baz, "and returns the same thing each time"); + is($foo->quux, 'XUUQ', "constructor overrides block injections"); + is($foo->quux, 'XUUQ', "and returns the same thing each time"); +} +} 'Foo'; + +done_testing; diff --git a/t/block.t b/t/block.t new file mode 100644 index 0000000..3ce9f48 --- /dev/null +++ b/t/block.t @@ -0,0 +1,40 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; +use Test::Moose; + +{ + package Foo; + use Moose; + use Bread::Board::Declare; + + has foo => ( + is => 'ro', + isa => 'Str', + default => 'FOO', + ); + + has bar => ( + is => 'ro', + isa => 'Str', + value => 'BAR', + ); + + has baz => ( + is => 'ro', + isa => 'Str', + block => sub { + my ($s, $self) = @_; + return $s->param('bar') . $self->foo; + }, + dependencies => ['bar'], + ); +} + +with_immutable { + my $foo = Foo->new; + is($foo->baz, 'BARFOO', "self is passed properly"); +} 'Foo'; + +done_testing; diff --git a/t/circular-dependency.t b/t/circular-dependency.t new file mode 100644 index 0000000..28431c9 --- /dev/null +++ b/t/circular-dependency.t @@ -0,0 +1,59 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; +use Test::Fatal; + +{ + package Foo; + use Moose; + + has bar => ( + is => 'rw', + isa => 'Bar', + ); +} + +{ + package Bar; + use Moose; + + has foo => ( + is => 'rw', + isa => 'Foo', + weak_ref => 1, + ); +} + +{ + package MyApp; + use Moose; + use Bread::Board::Declare; + + has foo => ( + is => 'ro', + isa => 'Foo', + block => sub { + my ($s, $self) = @_; + Foo->new(bar => $s->param('bar')); + }, + lifecycle => 'Singleton', + dependencies => ['bar'], + ); + has bar => ( + is => 'ro', + isa => 'Bar', + block => sub { + my ($s, $self) = @_; + Bar->new(foo => $s->param('foo')); + }, + lifecycle => 'Singleton', + dependencies => ['foo'], + ); +} + + +is exception { MyApp->new->foo->bar }, undef, + 'circular block-injection deps should survive'; + +done_testing(); diff --git a/t/constructor-name.t b/t/constructor-name.t new file mode 100644 index 0000000..5ae1258 --- /dev/null +++ b/t/constructor-name.t @@ -0,0 +1,30 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; +use Test::Moose; + +{ + package Bar; + + sub create { bless {}, shift } +} + +{ + package Foo; + use Moose; + use Bread::Board::Declare; + + has bar => ( + is => 'ro', + isa => 'Bar', + constructor_name => 'create', + ); +} + +with_immutable { + my $foo = Foo->new; + isa_ok($foo->bar, 'Bar'); +} 'Foo'; + +done_testing; diff --git a/t/defaults.t b/t/defaults.t new file mode 100644 index 0000000..7350d52 --- /dev/null +++ b/t/defaults.t @@ -0,0 +1,86 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; +use Test::Fatal; + +{ + package Foo; + use Moose; + use Bread::Board::Declare; + + ::like(::exception { + has foo => ( + is => 'ro', + isa => 'Str', + default => 'OOF', + value => 'FOO', + ); + }, qr/default is not valid when Bread::Board service options are set/, + "can't set a default when creating a service"); + + ::like(::exception { + has bar => ( + is => 'ro', + isa => 'Str', + default => sub { 'OOF' }, + value => 'FOO', + ); + }, qr/default is not valid when Bread::Board service options are set/, + "can't set a default when creating a service"); + + ::like(::exception { + has bar2 => ( + is => 'ro', + isa => 'Str', + builder => '_build_bar2', + value => 'FOO', + ); + }, qr/builder is not valid when Bread::Board service options are set/, + "can't set a builder when creating a service"); + + ::like(::exception { + has baz => ( + is => 'ro', + isa => 'Str', + lazy => 1, + default => 'OOF', + value => 'FOO', + ); + }, qr/default is not valid when Bread::Board service options are set/, + "can't set a default when creating a service"); + + ::like(::exception { + has quux => ( + is => 'ro', + isa => 'Str', + lazy => 1, + default => sub { 'OOF' }, + value => 'FOO', + ); + }, qr/default is not valid when Bread::Board service options are set/, + "can't set a default when creating a service"); + + ::like(::exception { + has quux2 => ( + is => 'ro', + isa => 'Str', + lazy => 1, + builder => '_build_quux2', + value => 'FOO', + ); + }, qr/builder is not valid when Bread::Board service options are set/, + "can't set a builder when creating a service"); + + ::like(::exception { + has quux3 => ( + is => 'ro', + isa => 'Str', + lazy_build => 1, + value => 'FOO', + ); + }, qr/builder is not valid when Bread::Board service options are set/, + "can't set lazy_build when creating a service"); +} + +done_testing; diff --git a/t/deps.t b/t/deps.t new file mode 100644 index 0000000..21e0c7f --- /dev/null +++ b/t/deps.t @@ -0,0 +1,46 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; +use Test::Moose; + +{ + package Baz; + use Moose; + + has bar => ( + is => 'ro', + isa => 'Str', + required => 1, + ); +} + +my $i; +{ + package Foo; + use Moose; + use Bread::Board::Declare; + + has bar => ( + is => 'ro', + isa => 'Str', + block => sub { $i++ }, + ); + + has baz => ( + is => 'ro', + isa => 'Baz', + dependencies => ['bar'], + ); +} + +with_immutable { + $i = 0; + my $foo = Foo->new; + my $baz = $foo->baz; + is($baz->bar, '0', "deps resolved correctly"); + is($baz->bar, '0', "doesn't re-resolve, since Baz is a normal class"); + is($foo->baz->bar, '1', "re-resolves since the baz attr isn't a singleton"); +} 'Foo'; + +done_testing; diff --git a/t/extends.t b/t/extends.t new file mode 100644 index 0000000..8e45869 --- /dev/null +++ b/t/extends.t @@ -0,0 +1,37 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; +use Test::Fatal; + +{ + package Bar; + use Moose; +} + +{ + package Baz; + use Moose; + use Bread::Board::Declare; +} + +{ + package Quux; + use Moose; + use Bread::Board::Declare; +} + +{ + package Foo; + use Moose; + use Bread::Board::Declare; + + ::like(::exception { extends 'Bar' }, + qr/^Cannot inherit from Bar because Bread::Board::Declare classes must inherit from Bread::Board::Container/, + "error when inheriting from a non-container"); + ::like(::exception { extends 'Baz', 'Quux' }, + qr/^Multiple inheritance is not supported for Bread::Board::Declare classes/, + "error when inheriting from multiple containers"); +} + +done_testing; diff --git a/t/infer-loading.t b/t/infer-loading.t new file mode 100644 index 0000000..97e98d3 --- /dev/null +++ b/t/infer-loading.t @@ -0,0 +1,31 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; +use lib 't/lib'; + +{ + package Foo; + use Moose; + use Bread::Board::Declare; + + has foo => ( + is => 'ro', + isa => 'Inferred::Foo', + infer => 1, + ); + + has bar => ( + is => 'ro', + isa => 'Inferred::Bar', + ); +} + +{ + my $c = Foo->new; + isa_ok($c->foo, 'Inferred::Foo'); + isa_ok($c->foo->bar, 'Inferred::Bar'); + isa_ok($c->bar, 'Inferred::Bar'); +} + +done_testing; diff --git a/t/infer.t b/t/infer.t new file mode 100644 index 0000000..2b064a3 --- /dev/null +++ b/t/infer.t @@ -0,0 +1,269 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; +use Test::Fatal; + +{ + package Foo; + use Moose; + + has data => ( + is => 'ro', + isa => 'Str', + default => 'FOO', + ); +} + +{ + package Bar; + use Moose; +} + +{ + package Baz; + use Moose; + + has foo => ( + is => 'ro', + isa => 'Foo', + required => 1, + ); + + has bar => ( + is => 'ro', + isa => 'Bar', + required => 1, + ); + + has thing => ( + is => 'ro', + isa => 'Str', + ); +} + +{ + package My::Container; + use Moose; + use Bread::Board::Declare; + + has baz => ( + is => 'ro', + isa => 'Baz', + infer => 1, + ); + + has baz_no_infer => ( + is => 'ro', + isa => 'Baz', + ); +} + +{ + my $c = My::Container->new; + isa_ok($c->baz, 'Baz'); + isa_ok($c->baz->foo, 'Foo'); + isa_ok($c->baz->bar, 'Bar'); + + is($c->baz->thing, undef, "right thing"); + is($c->baz->foo->data, 'FOO', "right data"); + + isa_ok($c->resolve(type => 'Baz'), 'Baz'); +} + +{ + my $c = My::Container->new; + like( + exception { $c->baz_no_infer }, + qr/^Attribute \(bar\) is required/, + "not inferred when not requested" + ); +} + +{ + package Baz2; + use Moose; + + extends 'Baz'; + + has '+thing' => ( + required => 1, + ); +} + +{ + package My::Container2; + use Moose; + use Bread::Board::Declare; + + has baz => ( + is => 'ro', + isa => 'Baz2', + infer => 1, + ); +} + +{ + like( + exception { My::Container2->new }, + qr/^Only class types, role types, or subtypes of Object can be inferred\. I don't know what to do with type \(Str\)/, + "correct error when not everything can be inferred" + ); +} + +{ + package My::Container3; + use Moose; + use Bread::Board::Declare; + + has thing => ( + is => 'ro', + isa => 'Str', + value => 'THING', + ); + + has foo => ( + is => 'ro', + isa => 'Foo', + dependencies => { data => 'thing' }, + ); + + has baz => ( + is => 'ro', + isa => 'Baz2', + infer => 1, + dependencies => ['thing'], + ); +} + +{ + my $c = My::Container3->new; + isa_ok($c->baz, 'Baz2'); + isa_ok($c->baz->foo, 'Foo'); + isa_ok($c->baz->bar, 'Bar'); + + is( + $c->fetch('baz')->get_dependency('foo')->service, + $c->fetch('foo'), + "inferred the right dependency" + ); + + is($c->baz->foo->data, 'THING', + "inference finds services in the container"); + is($c->baz->thing, 'THING', "partial dependency specification works"); +} + +{ + package Quux; + use Moose; + + has baz => ( + is => 'ro', + isa => 'Baz', + required => 1, + ); + + has foo => ( + is => 'ro', + isa => 'Foo', + ); +} + +{ + package My::Container4; + use Moose; + use Bread::Board::Declare; + + has data => ( + is => 'ro', + isa => 'Str', + value => 'DATA', + ); + + has quux => ( + is => 'ro', + isa => 'Quux', + infer => 1, + ); + + has foo => ( + is => 'ro', + isa => 'Foo', + dependencies => ['data'], + ); + + has quux2 => ( + is => 'ro', + isa => 'Quux', + infer => 1, + dependencies => ['foo'], + ); +} + +{ + my $c = My::Container4->new; + isa_ok($c->quux, 'Quux'); + isa_ok($c->quux->baz, 'Baz'); + isa_ok($c->quux->baz->foo, 'Foo'); + isa_ok($c->quux->baz->bar, 'Bar'); + + is($c->quux->foo, undef, "non-required attrs are not inferred"); + is($c->quux2->foo->data, 'DATA', "but can be explicitly specified"); +} + +{ + package State; + use Moose; + + has counter => ( + traits => ['Counter'], + is => 'rw', + isa => 'Int', + handles => { inc => 'inc' }, + default => 0, + ); +} + +{ + package Controller; + use Moose; + + has counter => ( + is => 'ro', + isa => 'State', + required => 1, + handles => { inc => 'inc', counter_val => 'counter' }, + ); +} + +{ + package App; + use Moose; + use Bread::Board::Declare; + + has counter => ( + is => 'ro', + isa => 'State', + lifecycle => 'Singleton', + ); + + has controller => ( + is => 'ro', + isa => 'Controller', + infer => 1, + ); +} + +{ + my $c = App->new; + is( + $c->fetch('controller')->get_dependency('counter')->service, + $c->fetch('counter'), + "inferred the right dependency" + ); + $c->controller->inc; + $c->controller->inc; + is($c->controller->counter_val, 2, "state persisted as a singleton"); +} + +done_testing; diff --git a/t/inheritance.t b/t/inheritance.t new file mode 100644 index 0000000..b1517e8 --- /dev/null +++ b/t/inheritance.t @@ -0,0 +1,123 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; +use Test::Moose; + +{ + package Parent; + use Moose; + use Bread::Board::Declare; + + has foo => ( + is => 'ro', + isa => 'Str', + value => 'FOO', + ); + + has bar => ( + is => 'ro', + isa => 'Str', + block => sub { + my $s = shift; + return $s->param('foo') . 'BAR'; + }, + dependencies => ['foo'], + ); +} + +{ + package Child; + use Moose; + use Bread::Board::Declare; + + extends 'Parent'; + + has baz => ( + is => 'ro', + isa => 'Str', + value => 'BAZ', + ); + + has quux => ( + is => 'ro', + isa => 'Str', + block => sub { + my $s = shift; + return $s->param('foo') + . $s->param('bar') + . $s->param('baz') + . 'QUUX'; + }, + dependencies => ['foo', 'bar', 'baz'], + ); +} + +with_immutable { +{ + my $parent = Parent->new; + ok($parent->has_service('foo'), "parent has foo"); + ok($parent->has_service('bar'), "parent has bar"); + + my $child = Child->new; + ok($child->has_service('foo'), "child has foo"); + ok($child->has_service('bar'), "child has bar"); + ok($child->has_service('baz'), "child has baz"); + ok($child->has_service('quux'), "child has quux"); +} + +{ + my $parent = Parent->new; + isa_ok($parent, 'Bread::Board::Container'); + is($parent->foo, 'FOO'); + is($parent->bar, 'FOOBAR'); +} + +{ + my $parent = Parent->new(foo => 'OOF', bar => 'RAB'); + isa_ok($parent, 'Bread::Board::Container'); + is($parent->foo, 'OOF'); + is($parent->bar, 'RAB'); +} + +{ + my $parent = Parent->new(foo => 'OOF'); + isa_ok($parent, 'Bread::Board::Container'); + is($parent->foo, 'OOF'); + is($parent->bar, 'OOFBAR'); +} + +{ + my $child = Child->new; + is($child->foo, 'FOO'); + is($child->bar, 'FOOBAR'); + is($child->baz, 'BAZ'); + is($child->quux, 'FOOFOOBARBAZQUUX'); +} + +{ + my $child = Child->new( + foo => 'OOF', + bar => 'RAB', + baz => 'ZAB', + quux => 'XUUQ', + ); + is($child->foo, 'OOF'); + is($child->bar, 'RAB'); + is($child->baz, 'ZAB'); + is($child->quux, 'XUUQ'); +} + +{ + my $child = Child->new( + foo => 'OOF', + baz => 'ZAB', + ); + is($child->foo, 'OOF'); + is($child->bar, 'OOFBAR'); + is($child->baz, 'ZAB'); + is($child->quux, 'OOFOOFBARZABQUUX'); +} +} 'Parent', 'Child'; + +done_testing; diff --git a/t/inlining.t b/t/inlining.t new file mode 100644 index 0000000..cb1b8d8 --- /dev/null +++ b/t/inlining.t @@ -0,0 +1,147 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; + +{ + package Foo; + use Moose; + use Bread::Board::Declare; + + has foo => ( + reader => 'get_foo', + writer => 'set_foo', + accessor => 'foo', + predicate => 'has_foo', + clearer => 'clear_foo', + value => 'foo', + ); + + has bool => ( + traits => ['Bool'], + isa => 'Bool', + value => 0, + handles => { + bool_unset => 'unset', + bool_set => 'set', + bool_not => 'not', + bool_toggle => 'toggle', + }, + ); + + has string => ( + traits => ['String'], + isa => 'Str', + value => '', + default => '', # XXX: ugh, needed because of the default_default stuff + handles => { + string_prepend => 'prepend', + string_chop => 'chop', + string_substr => 'substr', + string_match => 'match', + string_length => 'length', + string_inc => 'inc', + string_append => 'append', + string_clear => 'clear', + string_chomp => 'chomp', + string_replace => 'replace', + }, + ); + + has hash => ( + traits => ['Hash'], + isa => 'HashRef', + block => sub { {} }, + handles => { + hash_delete => 'delete', + hash_exists => 'exists', + hash_values => 'values', + hash_get => 'get', + hash_set => 'set', + hash_is_empty => 'is_empty', + hash_keys => 'keys', + hash_elements => 'elements', + hash_kv => 'kv', + hash_defined => 'defined', + hash_accessor => 'accessor', + hash_count => 'count', + hash_clear => 'clear', + }, + ); + + has counter => ( + traits => ['Counter'], + isa => 'Int', + value => 0, + default => 0, # XXX: ugh, needed because of the default_default stuff + handles => { + counter_set => 'set', + counter_reset => 'reset', + counter_inc => 'inc', + counter_dec => 'dec', + }, + ); + + has code => ( + traits => ['Code'], + isa => 'CodeRef', + block => sub { sub { } }, + handles => { + code_execute => 'execute', + code_execute_method => 'execute_method', + }, + ); + + has array => ( + traits => ['Array'], + isa => 'ArrayRef', + block => sub { [] }, + handles => { + array_unshift => 'unshift', + array_shuffle => 'shuffle', + array_delete => 'delete', + array_get => 'get', + array_set => 'set', + array_uniq => 'uniq', + array_is_empty => 'is_empty', + array_shift => 'shift', + array_grep => 'grep', + array_sort_in_place => 'sort_in_place', + array_sort => 'sort', + array_elements => 'elements', + array_pop => 'pop', + array_reduce => 'reduce', + array_insert => 'insert', + array_join => 'join', + array_first => 'first', + array_natatime => 'natatime', + array_accessor => 'accessor', + array_count => 'count', + array_map => 'map', + array_push => 'push', + array_clear => 'clear', + array_splice => 'splice', + }, + ); + + has number => ( + traits => ['Number'], + isa => 'Num', + value => 1, + handles => { + number_add => 'add', + number_set => 'set', + number_sub => 'sub', + number_mul => 'mul', + number_mod => 'mod', + number_abs => 'abs', + number_div => 'div', + }, + ); + + __PACKAGE__->meta->make_immutable; +} + +pass("everything compiled successfully"); + +done_testing; diff --git a/t/lifecycle.t b/t/lifecycle.t new file mode 100644 index 0000000..c101929 --- /dev/null +++ b/t/lifecycle.t @@ -0,0 +1,50 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; +use Test::Moose; + +{ + package Baz; + use Moose; + + has bar => ( + is => 'ro', + isa => 'Str', + required => 1, + ); +} + +my $i; +{ + package Foo; + use Moose; + use Bread::Board::Declare; + + has bar => ( + is => 'ro', + isa => 'Str', + block => sub { $i++ }, + ); + + has baz => ( + is => 'ro', + isa => 'Baz', + dependencies => ['bar'], + lifecycle => 'Singleton', + ); +} + +with_immutable { + $i = 0; + my $foo = Foo->new; + my $baz = $foo->baz; + is($baz->bar, '0', "deps resolved correctly"); + is($baz->bar, '0', "doesn't re-resolve, since Baz is a normal class"); + is($foo->baz->bar, '0', + "doesn't re-resolve since the baz attr is a singleton"); + is($foo->baz, $foo->baz, + "doesn't re-resolve since the baz attr is a singleton"); +} 'Foo'; + +done_testing; diff --git a/t/mop.t b/t/mop.t new file mode 100644 index 0000000..c3a943f --- /dev/null +++ b/t/mop.t @@ -0,0 +1,39 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; +use Test::Moose; + +{ + package Foo; + use Moose; + use Bread::Board::Declare; + + has foo => ( + is => 'ro', + isa => 'Str', + value => 'FOO', + ); + + has bar => ( + is => 'ro', + isa => 'Str', + block => sub { + my $s = shift; + return $s->param('foo') . 'BAR'; + }, + dependencies => ['foo'], + ); +} + +with_immutable { + my $foo = Foo->new; + my $foo_attr = $foo->meta->get_attribute('foo'); + my $bar_attr = $foo->meta->get_attribute('bar'); + is($foo_attr->get_value($foo), 'FOO', "right value"); + is($bar_attr->get_value($foo), 'FOOBAR', "right value"); + ok(!$foo_attr->has_value($foo), "no value"); + ok(!$bar_attr->has_value($foo), "no value"); +} 'Foo'; + +done_testing; diff --git a/t/more-inheritance.t b/t/more-inheritance.t new file mode 100644 index 0000000..94d726c --- /dev/null +++ b/t/more-inheritance.t @@ -0,0 +1,105 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; +use Test::Moose; + +{ + package Parent; + use Moose; + use Bread::Board::Declare; + + has foo => ( + is => 'ro', + isa => 'Str', + value => 'parent', + ); + + has bar => ( + is => 'ro', + isa => 'Str', + block => sub { + my $s = shift; + return $s->param('foo') . ' ' . 'parent'; + }, + dependencies => ['foo'], + ); +} + +{ + package Child1; + use Moose; + use Bread::Board::Declare; + + extends 'Parent'; + + has foo => ( + is => 'ro', + isa => 'Str', + value => 'child', + ); +} + +{ + package Child2; + use Moose; + use Bread::Board::Declare; + + extends 'Parent'; + + has bar => ( + is => 'ro', + isa => 'Str', + block => sub { + my $s = shift; + return $s->param('foo') . ' ' . 'child'; + }, + dependencies => ['foo'], + ); +} + +{ + package Child3; + use Moose; + use Bread::Board::Declare; + + extends 'Child1'; + + has bar => ( + is => 'ro', + isa => 'Str', + block => sub { + my $s = shift; + return $s->param('foo') . ' ' . 'child'; + }, + dependencies => ['foo'], + ); +} + +with_immutable { +{ + my $obj = Parent->new; + is($obj->foo, 'parent'); + is($obj->bar, 'parent parent'); +} + +{ + my $obj = Child1->new; + is($obj->foo, 'child'); + is($obj->bar, 'child parent'); +} + +{ + my $obj = Child2->new; + is($obj->foo, 'parent'); + is($obj->bar, 'parent child'); +} + +{ + my $obj = Child3->new; + is($obj->foo, 'child'); + is($obj->bar, 'child child'); +} +} 'Parent', 'Child1', 'Child2', 'Child3'; + +done_testing; diff --git a/t/multiple-instantiation.t b/t/multiple-instantiation.t new file mode 100644 index 0000000..c8372c1 --- /dev/null +++ b/t/multiple-instantiation.t @@ -0,0 +1,43 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; +use Test::Moose; + +{ + package Bar; + use Moose; + + has foo => ( + is => 'ro', + isa => 'Str', + required => 1, + ); +} + +{ + package Foo; + use Moose; + use Bread::Board::Declare; + + has foo => ( + is => 'ro', + isa => 'Str', + value => 'FOO', + ); + + has bar => ( + is => 'ro', + isa => 'Bar', + dependencies => ['foo'], + ); +} + +with_immutable { +my $foo1 = Foo->new; +is($foo1->bar->foo, 'FOO'); +my $foo2 = Foo->new(foo => 'BAR'); +is($foo2->bar->foo, 'BAR'); +} 'Foo'; + +done_testing; diff --git a/t/no-service.t b/t/no-service.t new file mode 100644 index 0000000..aeb4c48 --- /dev/null +++ b/t/no-service.t @@ -0,0 +1,75 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; +use Test::Fatal; +use Test::Moose; + +{ + package Bar; + use Moose; +} + +{ + package Foo; + use Moose; + use Bread::Board::Declare; + + has foo => ( + is => 'ro', + isa => 'Str', + ); + + has bar => ( + is => 'ro', + isa => 'Bar', + service => 0, + ); + + has baz => ( + is => 'ro', + isa => 'Str', + block => sub { shift->param('foo') }, + dependencies => ['foo'], + ); + + has quux => ( + is => 'ro', + isa => 'Bar', + block => sub { shift->param('bar') }, + dependencies => ['bar'], + ); +} + +with_immutable { +{ + my $foo = Foo->new; + ok($foo->has_service($_), "has service $_") for qw(foo baz); + ok(!$foo->has_service($_), "doesn't have service $_") for qw(bar); +} + +{ + my $foo = Foo->new; + like( + exception { $foo->baz }, + qr/^Attribute foo did not specify a service\. It must be given a value through the constructor or writer method before it can be resolved\./, + "got the right error when foo isn't set" + ); +} + +{ + my $foo = Foo->new(foo => 'bar'); + is($foo->baz, 'bar', "didn't get an error when foo is set"); +} + +{ + my $foo = Foo->new; + like( + exception { $foo->quux }, + qr/^Could not find container or service for bar in Foo/, + "can't depend on attrs with no service" + ); +} +} 'Foo'; + +done_testing; diff --git a/t/roles.t b/t/roles.t new file mode 100644 index 0000000..704b13c --- /dev/null +++ b/t/roles.t @@ -0,0 +1,174 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; +use Test::Moose; + +{ + package Role1; + use Moose::Role; + use Bread::Board::Declare; + + has role1 => ( + (Moose->VERSION < 1.9900 + ? (traits => ['Service']) + : ()), + is => 'ro', + isa => 'Str', + value => 'ROLE1', + ); +} + +{ + package Parent; + use Moose; + use Bread::Board::Declare; + + with 'Role1'; + + has foo => ( + is => 'ro', + isa => 'Str', + value => 'FOO', + ); + + has bar => ( + is => 'ro', + isa => 'Str', + block => sub { + my $s = shift; + return $s->param('foo') . 'BAR' . $s->param('role1'); + }, + dependencies => ['foo', 'role1'], + ); +} + +{ + package Role2; + use Moose::Role; + use Bread::Board::Declare; + + has role2 => ( + (Moose->VERSION < 1.9900 + ? (traits => ['Service']) + : ()), + is => 'ro', + isa => 'Str', + value => 'ROLE2', + ); +} + +{ + package Child; + use Moose; + use Bread::Board::Declare; + + extends 'Parent'; + with 'Role2'; + + has baz => ( + is => 'ro', + isa => 'Str', + value => 'BAZ', + ); + + has quux => ( + is => 'ro', + isa => 'Str', + block => sub { + my $s = shift; + return $s->param('foo') + . $s->param('bar') + . $s->param('baz') + . $s->param('role1') + . $s->param('role2') + . 'QUUX'; + }, + dependencies => ['foo', 'bar', 'baz', 'role1', 'role2'], + ); +} + +with_immutable { +{ + my $parent = Parent->new; + ok($parent->has_service('role1'), "parent has role1"); + ok($parent->has_service('foo'), "parent has foo"); + ok($parent->has_service('bar'), "parent has bar"); + + my $child = Child->new; + ok($child->has_service('role1'), "child has role1"); + ok($child->has_service('foo'), "child has foo"); + ok($child->has_service('bar'), "child has bar"); + ok($child->has_service('role2'), "child has role2"); + ok($child->has_service('baz'), "child has baz"); + ok($child->has_service('quux'), "child has quux"); +} + +{ + my $parent = Parent->new; + isa_ok($parent, 'Bread::Board::Container'); + is($parent->role1, 'ROLE1'); + is($parent->foo, 'FOO'); + is($parent->bar, 'FOOBARROLE1'); +} + +{ + my $parent = Parent->new(role1 => '1ELOR', foo => 'OOF', bar => 'RAB'); + isa_ok($parent, 'Bread::Board::Container'); + is($parent->role1, '1ELOR'); + is($parent->foo, 'OOF'); + is($parent->bar, 'RAB'); +} + +{ + my $parent = Parent->new(role1 => '1ELOR', foo => 'OOF'); + isa_ok($parent, 'Bread::Board::Container'); + is($parent->role1, '1ELOR'); + is($parent->foo, 'OOF'); + is($parent->bar, 'OOFBAR1ELOR'); +} + +{ + my $child = Child->new; + is($child->role1, 'ROLE1'); + is($child->foo, 'FOO'); + is($child->bar, 'FOOBARROLE1'); + is($child->role2, 'ROLE2'); + is($child->baz, 'BAZ'); + is($child->quux, 'FOOFOOBARROLE1BAZROLE1ROLE2QUUX'); +} + +{ + my $child = Child->new( + role1 => '1ELOR', + foo => 'OOF', + bar => 'RAB', + role2 => '2ELOR', + baz => 'ZAB', + quux => 'XUUQ', + ); + is($child->role1, '1ELOR'); + is($child->foo, 'OOF'); + is($child->bar, 'RAB'); + is($child->role2, '2ELOR'); + is($child->baz, 'ZAB'); + is($child->quux, 'XUUQ'); +} + +{ + my $child = Child->new( + role1 => '1ELOR', + foo => 'OOF', + role2 => '2ELOR', + baz => 'ZAB', + ); + is($child->role1, '1ELOR'); + is($child->foo, 'OOF'); + is($child->bar, 'OOFBAR1ELOR'); + is($child->role2, '2ELOR'); + is($child->baz, 'ZAB'); + is($child->quux, 'OOFOOFBAR1ELORZAB1ELOR2ELORQUUX'); +} +} 'Parent', 'Child'; + +done_testing; diff --git a/t/type-checks.t b/t/type-checks.t new file mode 100644 index 0000000..0641d98 --- /dev/null +++ b/t/type-checks.t @@ -0,0 +1,46 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; +use Test::Fatal; +use Test::Moose; + +{ + package Foo; + use Moose; + use Bread::Board::Declare; + + has foo => ( + is => 'ro', + isa => 'Ref', + value => 'FOO', + ); + + has bar => ( + is => 'ro', + isa => 'Str', + block => sub { { foo => 'bar' } }, + ); + + has baz => ( + is => 'ro', + isa => 'HashRef', + block => sub { shift->param('bar') }, + dependencies => ['bar'], + ); +} + +with_immutable { + my $foo = Foo->new; + like(exception { $foo->foo }, + qr/^Attribute \(foo\) does not pass the type constraint because: Validation failed for 'Ref' with value .*FOO/, + "error when service returns invalid value"); + like(exception { $foo->bar }, + qr/^Attribute \(bar\) does not pass the type constraint because: Validation failed for 'Str' with value .*(?:HASH|foo.*bar)/, + "error when service returns invalid value"); + like(exception { $foo->baz }, + qr/^Attribute \(bar\) does not pass the type constraint because: Validation failed for 'Str' with value .*(?:HASH|foo.*bar)/, + "error when service returns invalid value, even as a dependency"); +} 'Foo'; + +done_testing; -- cgit v1.2.3-54-g00ecf