Commit | Line | Data |
4060c871 |
1 | #!/usr/bin/perl |
2 | |
3 | use strict; |
4 | use warnings; |
5 | |
6 | use Scalar::Util 'isweak'; |
7 | |
8609b28c |
8 | use Test::More; |
4060c871 |
9 | use Test::Exception; |
10 | |
11 | |
4060c871 |
12 | { |
13 | package Foo; |
14 | use Mouse; |
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 Mouse; |
34 | |
35 | has 'foo' => (is => 'rw', isa => 'Foo', weak_ref => 1); |
36 | |
37 | package Baz; |
38 | use Mouse; |
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 Mouse; |
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 Mouse; |
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 Mouse; |
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 | |
8609b28c |
185 | note 'skip Moose specific features'; |
186 | last; |
187 | |
4060c871 |
188 | is_deeply( |
189 | \@Foo::calls, |
190 | [ [ $foo, 3, 2 ] ], |
191 | 'trigger called correctly on second set via meta-API', |
192 | ); |
193 | @Foo::calls = (); |
194 | |
195 | $attr->set_raw_value( $foo, 4 ); |
196 | |
197 | is_deeply( |
198 | \@Foo::calls, |
199 | [ ], |
200 | 'trigger not called using set_raw_value method', |
201 | ); |
202 | @Foo::calls = (); |
203 | } |
204 | |
205 | { |
8609b28c |
206 | note 'skip Moose specific features'; |
207 | last; |
208 | |
4060c871 |
209 | my $foo = Foo->new(foo => 2); |
210 | is_deeply( |
211 | \@Foo::calls, |
212 | [ [ $foo, 2 ] ], |
213 | 'trigger called correctly on construction', |
214 | ); |
215 | @Foo::calls = (); |
216 | |
217 | $foo->foo(3); |
218 | is_deeply( |
219 | \@Foo::calls, |
220 | [ [ $foo, 3, 2 ] ], |
221 | 'trigger called correctly on set (with old value)', |
222 | ); |
223 | @Foo::calls = (); |
224 | Foo->meta->make_immutable, redo if Foo->meta->is_mutable; |
225 | } |
226 | |
8609b28c |
227 | done_testing; |