Commit | Line | Data |
8c9d74e7 |
1 | #!/usr/bin/perl |
2 | |
3 | use strict; |
4 | use warnings; |
5 | |
6 | use Scalar::Util 'isweak'; |
7 | |
a28e50e4 |
8 | use Test::More; |
b10dde3a |
9 | use Test::Fatal; |
8c9d74e7 |
10 | |
7ff56534 |
11 | |
8c9d74e7 |
12 | { |
13 | package Foo; |
8c9d74e7 |
14 | use Moose; |
d03bd989 |
15 | |
16 | has 'bar' => (is => 'rw', |
ab76842e |
17 | isa => 'Maybe[Bar]', |
d03bd989 |
18 | trigger => sub { |
8c9d74e7 |
19 | my ($self, $bar) = @_; |
20 | $bar->foo($self) if defined $bar; |
21 | }); |
d03bd989 |
22 | |
8c9d74e7 |
23 | has 'baz' => (writer => 'set_baz', |
24 | reader => 'get_baz', |
25 | isa => 'Baz', |
d03bd989 |
26 | trigger => sub { |
8c9d74e7 |
27 | my ($self, $baz) = @_; |
28 | $baz->foo($self); |
d03bd989 |
29 | }); |
30 | |
31 | |
8c9d74e7 |
32 | package Bar; |
8c9d74e7 |
33 | use Moose; |
d03bd989 |
34 | |
35 | has 'foo' => (is => 'rw', isa => 'Foo', weak_ref => 1); |
36 | |
8c9d74e7 |
37 | package Baz; |
8c9d74e7 |
38 | use Moose; |
d03bd989 |
39 | |
40 | has 'foo' => (is => 'rw', isa => 'Foo', weak_ref => 1); |
8c9d74e7 |
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 | |
b10dde3a |
53 | is( exception { |
8c9d74e7 |
54 | $foo->bar($bar); |
b10dde3a |
55 | }, undef, '... did not die setting bar' ); |
8c9d74e7 |
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'); |
d03bd989 |
61 | |
b10dde3a |
62 | is( exception { |
8c9d74e7 |
63 | $foo->bar(undef); |
b10dde3a |
64 | }, undef, '... did not die un-setting bar' ); |
8c9d74e7 |
65 | |
66 | is($foo->bar, undef, '... set the value foo.bar correctly'); |
d03bd989 |
67 | is($bar->foo, $foo, '... which in turn set the value bar.foo correctly'); |
8c9d74e7 |
68 | |
69 | # test the writer |
70 | |
b10dde3a |
71 | is( exception { |
8c9d74e7 |
72 | $foo->set_baz($baz); |
b10dde3a |
73 | }, undef, '... did not die setting baz' ); |
8c9d74e7 |
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'); |
d03bd989 |
87 | |
8c9d74e7 |
88 | my $foo = Foo->new(bar => $bar, baz => $baz); |
d03bd989 |
89 | isa_ok($foo, 'Foo'); |
8c9d74e7 |
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 | |
7eaef7ad |
102 | # some errors |
103 | |
104 | { |
105 | package Bling; |
7eaef7ad |
106 | use Moose; |
d03bd989 |
107 | |
b10dde3a |
108 | ::isnt( ::exception { |
7eaef7ad |
109 | has('bling' => (is => 'rw', trigger => 'Fail')); |
b10dde3a |
110 | }, undef, '... a trigger must be a CODE ref' ); |
d03bd989 |
111 | |
b10dde3a |
112 | ::isnt( ::exception { |
7eaef7ad |
113 | has('bling' => (is => 'rw', trigger => [])); |
b10dde3a |
114 | }, undef, '... a trigger must be a CODE ref' ); |
7eaef7ad |
115 | } |
116 | |
010997ca |
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; |
b10dde3a |
143 | is( exception { $blarg = Blarg->new; }, undef, 'Blarg->new() lives' ); |
010997ca |
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 | |
b10dde3a |
155 | is( exception { $blarg => Blarg->new( map { $_ => "Yet another $_ value" } qw/foo bar baz/ ) }, undef, '->new() with parameters' ); |
010997ca |
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 | } |
7eaef7ad |
159 | |
3dda07f5 |
160 | # Triggers do not receive the meta-attribute as an argument, but do |
161 | # receive the old value |
c2685d20 |
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'); |
3dda07f5 |
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 = (); |
312e0f0c |
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 = (); |
3dda07f5 |
200 | } |
201 | |
202 | { |
c2685d20 |
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, |
3dda07f5 |
214 | [ [ $foo, 3, 2 ] ], |
215 | 'trigger called correctly on set (with old value)', |
c2685d20 |
216 | ); |
217 | @Foo::calls = (); |
218 | Foo->meta->make_immutable, redo if Foo->meta->is_mutable; |
219 | } |
220 | |
a28e50e4 |
221 | done_testing; |