DEATH TO ALL zionist ELLIPSES
[gitmo/Moose.git] / t / 020_attributes / 004_attribute_triggers.t
CommitLineData
8c9d74e7 1#!/usr/bin/perl
2
3use strict;
4use warnings;
5
6use Scalar::Util 'isweak';
7
312e0f0c 8use Test::More tests => 43;
8c9d74e7 9use 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);
1808c2da 56 } 'did not die setting bar';
8c9d74e7 57
1808c2da 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');
8c9d74e7 60
1808c2da 61 ok(isweak($bar->{foo}), 'bar.foo is a weak reference');
d03bd989 62
8c9d74e7 63 lives_ok {
64 $foo->bar(undef);
1808c2da 65 } 'did not die un-setting bar';
8c9d74e7 66
1808c2da 67 is($foo->bar, undef, 'set the value foo.bar correctly');
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);
1808c2da 74 } 'did not die setting baz';
8c9d74e7 75
1808c2da 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');
8c9d74e7 78
1808c2da 79 ok(isweak($baz->{foo}), 'baz.foo is a weak reference');
8c9d74e7 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
1808c2da 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');
8c9d74e7 94
1808c2da 95 ok(isweak($bar->{foo}), 'bar.foo is a weak reference');
8c9d74e7 96
1808c2da 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');
8c9d74e7 99
1808c2da 100 ok(isweak($baz->{foo}), 'baz.foo is a weak reference');
8c9d74e7 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'));
1808c2da 111 } 'a trigger must be a CODE ref';
d03bd989 112
113 ::dies_ok {
7eaef7ad 114 has('bling' => (is => 'rw', trigger => []));
1808c2da 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