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