Commit | Line | Data |
d022f632 |
1 | #!/usr/bin/perl |
2 | |
3 | use strict; |
4 | use warnings; |
5 | |
a28e50e4 |
6 | use Test::More; |
d022f632 |
7 | use Test::Exception; |
8 | |
9 | { |
10 | package Foo; |
11 | |
d03bd989 |
12 | sub new { |
13 | bless({}, 'Foo') |
d022f632 |
14 | } |
d03bd989 |
15 | |
d022f632 |
16 | sub a { 'Foo::a' } |
17 | } |
18 | |
19 | { |
20 | package Bar; |
21 | use Moose; |
22 | |
23 | ::lives_ok { |
24 | has 'baz' => ( |
25 | is => 'ro', |
26 | isa => 'Foo', |
27 | lazy => 1, |
28 | default => sub { Foo->new() }, |
29 | handles => qr/^a$/, |
30 | ); |
31 | } '... can create the attribute with delegations'; |
d03bd989 |
32 | |
d022f632 |
33 | } |
34 | |
35 | my $bar; |
36 | lives_ok { |
37 | $bar = Bar->new; |
38 | } '... created the object ok'; |
39 | isa_ok($bar, 'Bar'); |
40 | |
41 | is($bar->a, 'Foo::a', '... got the right delgated value'); |
42 | |
4fe78472 |
43 | my @w; |
44 | $SIG{__WARN__} = sub { push @w, "@_" }; |
d022f632 |
45 | { |
46 | package Baz; |
47 | use Moose; |
48 | |
49 | ::lives_ok { |
50 | has 'bar' => ( |
51 | is => 'ro', |
52 | isa => 'Foo', |
53 | lazy => 1, |
54 | default => sub { Foo->new() }, |
55 | handles => qr/.*/, |
56 | ); |
57 | } '... can create the attribute with delegations'; |
d03bd989 |
58 | |
d022f632 |
59 | } |
60 | |
4fe78472 |
61 | is(@w, 0, "no warnings"); |
62 | |
63 | |
d022f632 |
64 | my $baz; |
65 | lives_ok { |
66 | $baz = Baz->new; |
67 | } '... created the object ok'; |
68 | isa_ok($baz, 'Baz'); |
69 | |
70 | is($baz->a, 'Foo::a', '... got the right delgated value'); |
71 | |
72 | |
73 | |
74 | |
75 | |
4fe78472 |
76 | @w = (); |
77 | |
78 | { |
79 | package Blart; |
80 | use Moose; |
81 | |
82 | ::lives_ok { |
83 | has 'bar' => ( |
84 | is => 'ro', |
85 | isa => 'Foo', |
86 | lazy => 1, |
87 | default => sub { Foo->new() }, |
88 | handles => [qw(a new)], |
89 | ); |
90 | } '... can create the attribute with delegations'; |
d03bd989 |
91 | |
4fe78472 |
92 | } |
93 | |
94 | { |
95 | local $TODO = "warning not yet implemented"; |
96 | |
97 | is(@w, 1, "one warning"); |
98 | like($w[0], qr/not delegating.*new/i, "warned"); |
99 | } |
100 | |
101 | |
102 | |
103 | my $blart; |
104 | lives_ok { |
105 | $blart = Blart->new; |
106 | } '... created the object ok'; |
107 | isa_ok($blart, 'Blart'); |
d022f632 |
108 | |
4fe78472 |
109 | is($blart->a, 'Foo::a', '... got the right delgated value'); |
d022f632 |
110 | |
a28e50e4 |
111 | done_testing; |