Convert all tests to done_testing.
[gitmo/Moose.git] / t / 020_attributes / 004_attribute_triggers.t
1 #!/usr/bin/perl
2
3 use strict;
4 use warnings;
5
6 use Scalar::Util 'isweak';
7
8 use Test::More;
9 use Test::Exception;
10
11
12 {
13     package Foo;
14     use Moose;
15
16     has 'bar' => (is      => 'rw',
17                   isa     => 'Maybe[Bar]',
18                   trigger => sub {
19                       my ($self, $bar) = @_;
20                       $bar->foo($self) if defined $bar;
21                   });
22
23     has 'baz' => (writer => 'set_baz',
24                   reader => 'get_baz',
25                   isa    => 'Baz',
26                   trigger => sub {
27                       my ($self, $baz) = @_;
28                       $baz->foo($self);
29                   });
30
31
32     package Bar;
33     use Moose;
34
35     has 'foo' => (is => 'rw', isa => 'Foo', weak_ref => 1);
36
37     package Baz;
38     use Moose;
39
40     has 'foo' => (is => 'rw', isa => 'Foo', weak_ref => 1);
41 }
42
43 {
44     my $foo = Foo->new;
45     isa_ok($foo, 'Foo');
46
47     my $bar = Bar->new;
48     isa_ok($bar, 'Bar');
49
50     my $baz = Baz->new;
51     isa_ok($baz, 'Baz');
52
53     lives_ok {
54         $foo->bar($bar);
55     } '... did not die setting bar';
56
57     is($foo->bar, $bar, '... set the value foo.bar correctly');
58     is($bar->foo, $foo, '... which in turn set the value bar.foo correctly');
59
60     ok(isweak($bar->{foo}), '... bar.foo is a weak reference');
61
62     lives_ok {
63         $foo->bar(undef);
64     } '... did not die un-setting bar';
65
66     is($foo->bar, undef, '... set the value foo.bar correctly');
67     is($bar->foo, $foo, '... which in turn set the value bar.foo correctly');
68
69     # test the writer
70
71     lives_ok {
72         $foo->set_baz($baz);
73     } '... did not die setting baz';
74
75     is($foo->get_baz, $baz, '... set the value foo.baz correctly');
76     is($baz->foo, $foo, '... which in turn set the value baz.foo correctly');
77
78     ok(isweak($baz->{foo}), '... baz.foo is a weak reference');
79 }
80
81 {
82     my $bar = Bar->new;
83     isa_ok($bar, 'Bar');
84
85     my $baz = Baz->new;
86     isa_ok($baz, 'Baz');
87
88     my $foo = Foo->new(bar => $bar, baz => $baz);
89     isa_ok($foo, 'Foo');
90
91     is($foo->bar, $bar, '... set the value foo.bar correctly');
92     is($bar->foo, $foo, '... which in turn set the value bar.foo correctly');
93
94     ok(isweak($bar->{foo}), '... bar.foo is a weak reference');
95
96     is($foo->get_baz, $baz, '... set the value foo.baz correctly');
97     is($baz->foo, $foo, '... which in turn set the value baz.foo correctly');
98
99     ok(isweak($baz->{foo}), '... baz.foo is a weak reference');
100 }
101
102 # some errors
103
104 {
105     package Bling;
106     use Moose;
107
108     ::dies_ok {
109         has('bling' => (is => 'rw', trigger => 'Fail'));
110     } '... a trigger must be a CODE ref';
111
112     ::dies_ok {
113         has('bling' => (is => 'rw', trigger => []));
114     } '... a trigger must be a CODE ref';
115 }
116
117 # Triggers do not fire on built values
118
119 {
120     package Blarg;
121     use Moose;
122
123     our %trigger_calls;
124     our %trigger_vals;
125     has foo => (is => 'rw', default => sub { 'default foo value' },
126                 trigger => sub { my ($self, $val, $attr) = @_;
127                                  $trigger_calls{foo}++;
128                                  $trigger_vals{foo} = $val });
129     has bar => (is => 'rw', lazy_build => 1,
130                 trigger => sub { my ($self, $val, $attr) = @_;
131                                  $trigger_calls{bar}++;
132                                  $trigger_vals{bar} = $val });
133     sub _build_bar { return 'default bar value' }
134     has baz => (is => 'rw', builder => '_build_baz',
135                 trigger => sub { my ($self, $val, $attr) = @_;
136                                  $trigger_calls{baz}++;
137                                  $trigger_vals{baz} = $val });
138     sub _build_baz { return 'default baz value' }
139 }
140
141 {
142     my $blarg;
143     lives_ok { $blarg = Blarg->new; } 'Blarg->new() lives';
144     ok($blarg, 'Have a $blarg');
145     foreach my $attr (qw/foo bar baz/) {
146         is($blarg->$attr(), "default $attr value", "$attr has default value");
147     }
148     is_deeply(\%Blarg::trigger_calls, {}, 'No triggers fired');
149     foreach my $attr (qw/foo bar baz/) {
150         $blarg->$attr("Different $attr value");
151     }
152     is_deeply(\%Blarg::trigger_calls, { map { $_ => 1 } qw/foo bar baz/ }, 'All triggers fired once on assign');
153     is_deeply(\%Blarg::trigger_vals, { map { $_ => "Different $_ value" } qw/foo bar baz/ }, 'All triggers given assigned values');
154
155     lives_ok { $blarg => Blarg->new( map { $_ => "Yet another $_ value" } qw/foo bar baz/ ) } '->new() with parameters';
156     is_deeply(\%Blarg::trigger_calls, { map { $_ => 2 } qw/foo bar baz/ }, 'All triggers fired once on construct');
157     is_deeply(\%Blarg::trigger_vals, { map { $_ => "Yet another $_ value" } qw/foo bar baz/ }, 'All triggers given assigned values');
158 }
159
160 # Triggers do not receive the meta-attribute as an argument, but do
161 # receive the old value
162
163 {
164     package Foo;
165     use Moose;
166     our @calls;
167     has foo => (is => 'rw', trigger => sub { push @calls, [@_] });
168 }
169
170 {
171     my $attr = Foo->meta->get_attribute('foo');
172
173     my $foo = Foo->new;
174     $attr->set_value( $foo, 2 );
175
176     is_deeply(
177         \@Foo::calls,
178         [ [ $foo, 2 ] ],
179         'trigger called correctly on initial set via meta-API',
180     );
181     @Foo::calls = ();
182
183     $attr->set_value( $foo, 3 );
184
185     is_deeply(
186         \@Foo::calls,
187         [ [ $foo, 3, 2 ] ],
188         'trigger called correctly on second set via meta-API',
189     );
190     @Foo::calls = ();
191
192     $attr->set_raw_value( $foo, 4 );
193
194     is_deeply(
195         \@Foo::calls,
196         [ ],
197         'trigger not called using set_raw_value method',
198     );
199     @Foo::calls = ();
200 }
201
202 {
203     my $foo = Foo->new(foo => 2);
204     is_deeply(
205         \@Foo::calls,
206         [ [ $foo, 2 ] ],
207         'trigger called correctly on construction',
208     );
209     @Foo::calls = ();
210
211     $foo->foo(3);
212     is_deeply(
213         \@Foo::calls,
214         [ [ $foo, 3, 2 ] ],
215         'trigger called correctly on set (with old value)',
216     );
217     @Foo::calls = ();
218     Foo->meta->make_immutable, redo if Foo->meta->is_mutable;
219 }
220
221 done_testing;