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