Commit | Line | Data |
29dcbf33 |
1 | #!/usr/bin/env perl |
2 | |
3 | use strict; |
4 | use warnings; |
5 | |
6 | use Test::More; |
b10dde3a |
7 | use Test::Fatal; |
29dcbf33 |
8 | |
9 | { |
10 | use Moose::Util::TypeConstraints; |
11 | use List::Util qw( sum ); |
12 | |
13 | subtype 'H1', as 'HashRef[Int]'; |
14 | subtype 'H2', as 'HashRef', where { scalar keys %{$_} < 2 }; |
15 | subtype 'H3', as 'HashRef[Int]', |
16 | where { ( sum( values %{$_} ) || 0 ) < 5 }; |
17 | |
1694864a |
18 | subtype 'H5', as 'HashRef'; |
19 | coerce 'H5', from 'Str', via { { key => $_ } }; |
20 | |
29dcbf33 |
21 | no Moose::Util::TypeConstraints; |
22 | } |
23 | |
24 | { |
25 | |
26 | package Foo; |
27 | use Moose; |
28 | |
29 | has hash_int => ( |
30 | traits => ['Hash'], |
31 | is => 'rw', |
32 | isa => 'HashRef[Int]', |
33 | handles => { |
34 | set_hash_int => 'set', |
35 | }, |
36 | ); |
37 | |
38 | has h1 => ( |
39 | traits => ['Hash'], |
40 | is => 'rw', |
41 | isa => 'H1', |
42 | handles => { |
43 | set_h1 => 'set', |
44 | }, |
45 | ); |
46 | |
47 | has h2 => ( |
48 | traits => ['Hash'], |
49 | is => 'rw', |
50 | isa => 'H2', |
51 | handles => { |
52 | set_h2 => 'set', |
53 | }, |
54 | ); |
55 | |
56 | has h3 => ( |
57 | traits => ['Hash'], |
58 | is => 'rw', |
59 | isa => 'H3', |
60 | handles => { |
61 | set_h3 => 'set', |
62 | }, |
63 | ); |
1694864a |
64 | |
65 | has h4 => ( |
66 | traits => ['Hash'], |
67 | is => 'rw', |
68 | isa => 'HashRef', |
69 | lazy => 1, |
70 | default => 'invalid', |
71 | clearer => '_clear_h4', |
72 | handles => { |
73 | get_h4 => 'get', |
74 | accessor_h4 => 'accessor', |
75 | }, |
76 | ); |
77 | |
78 | has h5 => ( |
79 | traits => ['Hash'], |
80 | is => 'rw', |
81 | isa => 'H5', |
82 | coerce => 1, |
83 | lazy => 1, |
84 | default => 'invalid', |
85 | clearer => '_clear_h5', |
86 | handles => { |
87 | get_h5 => 'get', |
88 | accessor_h5 => 'accessor', |
89 | }, |
90 | ); |
29dcbf33 |
91 | } |
92 | |
93 | my $foo = Foo->new; |
94 | |
95 | { |
96 | $foo->hash_int( {} ); |
97 | is_deeply( $foo->hash_int, {}, "hash_int - correct contents" ); |
98 | |
b10dde3a |
99 | isnt( exception { $foo->set_hash_int( x => 'foo' ) }, undef, "hash_int - can't set wrong type" ); |
29dcbf33 |
100 | is_deeply( $foo->hash_int, {}, "hash_int - correct contents" ); |
101 | |
102 | $foo->set_hash_int( x => 1 ); |
103 | is_deeply( $foo->hash_int, { x => 1 }, "hash_int - correct contents" ); |
104 | } |
105 | |
106 | { |
b10dde3a |
107 | isnt( exception { $foo->set_h1('foo') }, undef, "h1 - can't set onto undef" ); |
29dcbf33 |
108 | |
109 | $foo->h1( {} ); |
110 | is_deeply( $foo->h1, {}, "h1 - correct contents" ); |
111 | |
b10dde3a |
112 | isnt( exception { $foo->set_h1( x => 'foo' ) }, undef, "h1 - can't set wrong type" ); |
29dcbf33 |
113 | |
114 | is_deeply( $foo->h1, {}, "h1 - correct contents" ); |
115 | |
116 | $foo->set_h1( x => 1 ); |
117 | is_deeply( $foo->h1, { x => 1 }, "h1 - correct contents" ); |
118 | } |
119 | |
120 | { |
b10dde3a |
121 | isnt( exception { $foo->set_h2('foo') }, undef, "h2 - can't set onto undef" ); |
29dcbf33 |
122 | |
123 | $foo->h2( {} ); |
124 | is_deeply( $foo->h2, {}, "h2 - correct contents" ); |
125 | |
126 | $foo->set_h2( x => 'foo' ); |
127 | is_deeply( $foo->h2, { x => 'foo' }, "h2 - correct contents" ); |
128 | |
b10dde3a |
129 | isnt( exception { $foo->set_h2( y => 'bar' ) }, undef, "h2 - can't set more than one element" ); |
29dcbf33 |
130 | |
131 | is_deeply( $foo->h2, { x => 'foo' }, "h2 - correct contents" ); |
132 | } |
133 | |
134 | { |
b10dde3a |
135 | isnt( exception { $foo->set_h3(1) }, undef, "h3 - can't set onto undef" ); |
29dcbf33 |
136 | |
137 | $foo->h3( {} ); |
138 | is_deeply( $foo->h3, {}, "h3 - correct contents" ); |
139 | |
b10dde3a |
140 | isnt( exception { $foo->set_h3( x => 'foo' ) }, undef, "h3 - can't set non-int" ); |
29dcbf33 |
141 | |
b10dde3a |
142 | isnt( exception { $foo->set_h3( x => 100 ) }, undef, "h3 - can't violate overall type constraint" ); |
29dcbf33 |
143 | |
144 | is_deeply( $foo->h3, {}, "h3 - correct contents" ); |
145 | |
146 | $foo->set_h3( x => 1 ); |
147 | is_deeply( $foo->h3, { x => 1 }, "h3 - correct contents" ); |
148 | |
b10dde3a |
149 | isnt( exception { $foo->set_h3( x => 100 ) }, undef, "h3 - can't violate overall type constraint" ); |
29dcbf33 |
150 | |
151 | is_deeply( $foo->h3, { x => 1 }, "h3 - correct contents" ); |
152 | |
153 | $foo->set_h3( y => 3 ); |
154 | is_deeply( $foo->h3, { x => 1, y => 3 }, "h3 - correct contents" ); |
155 | } |
156 | |
1694864a |
157 | { |
158 | my $expect |
5a18346b |
159 | = qr/\QAttribute (h4) does not pass the type constraint because: Validation failed for 'HashRef' with value \E.*invalid.*/; |
1694864a |
160 | |
161 | like( |
162 | exception { $foo->accessor_h4('key'); }, |
163 | $expect, |
164 | 'invalid default is caught when trying to read via accessor' |
165 | ); |
166 | |
167 | like( |
168 | exception { $foo->accessor_h4( size => 42 ); }, |
169 | $expect, |
170 | 'invalid default is caught when trying to write via accessor' |
171 | ); |
172 | |
173 | like( |
174 | exception { $foo->get_h4(42); }, |
175 | $expect, |
176 | 'invalid default is caught when trying to get' |
177 | ); |
178 | } |
179 | |
180 | { |
181 | my $foo = Foo->new; |
182 | |
183 | is( |
184 | $foo->accessor_h5('key'), 'invalid', |
185 | 'lazy default is coerced when trying to read via accessor' |
186 | ); |
187 | |
188 | $foo->_clear_h5; |
189 | |
190 | $foo->accessor_h5( size => 42 ); |
191 | |
192 | is_deeply( |
193 | $foo->h5, |
194 | { key => 'invalid', size => 42 }, |
195 | 'lazy default is coerced when trying to write via accessor' |
196 | ); |
197 | |
198 | $foo->_clear_h5; |
199 | |
200 | is( |
201 | $foo->get_h5('key'), 'invalid', |
202 | 'lazy default is coerced when trying to get' |
203 | ); |
204 | } |
205 | |
29dcbf33 |
206 | done_testing; |