Commit | Line | Data |
e3c07b19 |
1 | #!/usr/bin/perl |
2 | |
3 | use strict; |
4 | use warnings; |
5 | |
8b9641b8 |
6 | use lib 't/lib'; |
7 | |
1c08fd75 |
8 | use Moose (); |
6197a68c |
9 | use Moose::Util::TypeConstraints; |
8b9641b8 |
10 | use NoInlineAttribute; |
b10dde3a |
11 | use Test::Fatal; |
1c08fd75 |
12 | use Test::More; |
13 | use Test::Moose; |
e3c07b19 |
14 | |
e3c07b19 |
15 | { |
1c08fd75 |
16 | my %handles = ( |
17 | option_accessor => 'accessor', |
18 | quantity => [ accessor => 'quantity' ], |
19 | clear_options => 'clear', |
20 | num_options => 'count', |
21 | delete_option => 'delete', |
22 | is_defined => 'defined', |
23 | options_elements => 'elements', |
24 | has_option => 'exists', |
25 | get_option => 'get', |
26 | has_no_options => 'is_empty', |
865faf6f |
27 | keys => 'keys', |
1399eab0 |
28 | values => 'values', |
1c08fd75 |
29 | key_value => 'kv', |
30 | set_option => 'set', |
e3c07b19 |
31 | ); |
85592815 |
32 | |
1c08fd75 |
33 | my $name = 'Foo1'; |
34 | |
35 | sub build_class { |
36 | my %attr = @_; |
37 | |
38 | my $class = Moose::Meta::Class->create( |
39 | $name++, |
40 | superclasses => ['Moose::Object'], |
41 | ); |
42 | |
8b9641b8 |
43 | my @traits = 'Hash'; |
44 | push @traits, 'NoInlineAttribute' |
45 | if delete $attr{no_inline}; |
46 | |
1c08fd75 |
47 | $class->add_attribute( |
48 | options => ( |
8b9641b8 |
49 | traits => \@traits, |
2d779ce6 |
50 | is => 'rw', |
1c08fd75 |
51 | isa => 'HashRef[Str]', |
52 | default => sub { {} }, |
53 | handles => \%handles, |
54 | clearer => '_clear_options', |
55 | %attr, |
56 | ), |
57 | ); |
58 | |
59 | return ( $class->name, \%handles ); |
60 | } |
d50fc84a |
61 | } |
e3c07b19 |
62 | |
1c08fd75 |
63 | { |
64 | run_tests(build_class); |
65 | run_tests( build_class( lazy => 1, default => sub { { x => 1 } } ) ); |
cf0da4e2 |
66 | run_tests( build_class( trigger => sub { } ) ); |
8b9641b8 |
67 | run_tests( build_class( no_inline => 1 ) ); |
6197a68c |
68 | |
69 | # Will force the inlining code to check the entire hashref when it is modified. |
70 | subtype 'MyHashRef', as 'HashRef[Str]', where { 1 }; |
71 | |
72 | run_tests( build_class( isa => 'MyHashRef' ) ); |
73 | |
74 | coerce 'MyHashRef', from 'HashRef', via { $_ }; |
75 | |
76 | run_tests( build_class( isa => 'MyHashRef', coerce => 1 ) ); |
d50fc84a |
77 | } |
59de9de4 |
78 | |
1c08fd75 |
79 | sub run_tests { |
80 | my ( $class, $handles ) = @_; |
59de9de4 |
81 | |
1c08fd75 |
82 | can_ok( $class, $_ ) for sort keys %{$handles}; |
e3c07b19 |
83 | |
1c08fd75 |
84 | with_immutable { |
85 | my $obj = $class->new( options => {} ); |
e3c07b19 |
86 | |
1c08fd75 |
87 | ok( $obj->has_no_options, '... we have no options' ); |
88 | is( $obj->num_options, 0, '... we have no options' ); |
89 | |
90 | is_deeply( $obj->options, {}, '... no options yet' ); |
91 | ok( !$obj->has_option('foo'), '... we have no foo option' ); |
92 | |
b10dde3a |
93 | is( exception { |
7f5ec80d |
94 | is( |
95 | $obj->set_option( foo => 'bar' ), |
96 | 'bar', |
97 | 'set return single new value in scalar context' |
98 | ); |
b10dde3a |
99 | }, undef, '... set the option okay' ); |
1c08fd75 |
100 | |
53f4ad9f |
101 | like( |
102 | exception { $obj->set_option( foo => 'bar', 'baz' ) }, |
103 | qr/You must pass an even number of arguments to set/, |
104 | 'exception with odd number of arguments' |
105 | ); |
106 | |
107 | like( |
108 | exception { $obj->set_option( undef, 'bar' ) }, |
109 | qr/Hash keys passed to set must be defined/, |
110 | 'exception when using undef as a key' |
111 | ); |
112 | |
1c08fd75 |
113 | ok( $obj->is_defined('foo'), '... foo is defined' ); |
114 | |
115 | ok( !$obj->has_no_options, '... we have options' ); |
116 | is( $obj->num_options, 1, '... we have 1 option(s)' ); |
117 | ok( $obj->has_option('foo'), '... we have a foo option' ); |
118 | is_deeply( $obj->options, { foo => 'bar' }, '... got options now' ); |
119 | |
b10dde3a |
120 | is( exception { |
1c08fd75 |
121 | $obj->set_option( bar => 'baz' ); |
b10dde3a |
122 | }, undef, '... set the option okay' ); |
1c08fd75 |
123 | |
124 | is( $obj->num_options, 2, '... we have 2 option(s)' ); |
125 | is_deeply( |
126 | $obj->options, { foo => 'bar', bar => 'baz' }, |
127 | '... got more options now' |
128 | ); |
129 | |
130 | is( $obj->get_option('foo'), 'bar', '... got the right option' ); |
131 | |
132 | is_deeply( |
133 | [ $obj->get_option(qw(foo bar)) ], [qw(bar baz)], |
134 | "get multiple options at once" |
135 | ); |
136 | |
137 | is( |
138 | scalar( $obj->get_option(qw( foo bar)) ), "baz", |
139 | '... got last option in scalar context' |
140 | ); |
141 | |
b10dde3a |
142 | is( exception { |
1c08fd75 |
143 | $obj->set_option( oink => "blah", xxy => "flop" ); |
b10dde3a |
144 | }, undef, '... set the option okay' ); |
1c08fd75 |
145 | |
146 | is( $obj->num_options, 4, "4 options" ); |
147 | is_deeply( |
148 | [ $obj->get_option(qw(foo bar oink xxy)) ], |
149 | [qw(bar baz blah flop)], "get multiple options at once" |
150 | ); |
151 | |
b10dde3a |
152 | is( exception { |
7f5ec80d |
153 | is( scalar $obj->delete_option('bar'), 'baz', |
154 | 'delete returns deleted value' ); |
b10dde3a |
155 | }, undef, '... deleted the option okay' ); |
1c08fd75 |
156 | |
b10dde3a |
157 | is( exception { |
7f5ec80d |
158 | is_deeply( |
159 | [ $obj->delete_option( 'oink', 'xxy' ) ], |
160 | [ 'blah', 'flop' ], |
161 | 'delete returns all deleted values in list context' |
162 | ); |
b10dde3a |
163 | }, undef, '... deleted multiple option okay' ); |
1c08fd75 |
164 | |
165 | is( $obj->num_options, 1, '... we have 1 option(s)' ); |
166 | is_deeply( |
167 | $obj->options, { foo => 'bar' }, |
168 | '... got more options now' |
169 | ); |
170 | |
171 | $obj->clear_options; |
172 | |
173 | is_deeply( $obj->options, {}, "... cleared options" ); |
174 | |
b10dde3a |
175 | is( exception { |
1c08fd75 |
176 | $obj->quantity(4); |
b10dde3a |
177 | }, undef, '... options added okay with defaults' ); |
1c08fd75 |
178 | |
179 | is( $obj->quantity, 4, 'reader part of curried accessor works' ); |
180 | |
2d779ce6 |
181 | is( |
182 | $obj->option_accessor('quantity'), 4, |
183 | 'accessor as reader' |
184 | ); |
185 | |
1c08fd75 |
186 | is_deeply( |
187 | $obj->options, { quantity => 4 }, |
188 | '... returns what we expect' |
189 | ); |
190 | |
5dcac913 |
191 | $obj->option_accessor( size => 42 ); |
2d779ce6 |
192 | |
65594cb4 |
193 | like( |
194 | exception { |
195 | $obj->option_accessor; |
196 | }, |
197 | qr/Cannot call accessor without at least 1 argument/, |
198 | 'error when calling accessor with no arguments' |
199 | ); |
43433317 |
200 | |
53f4ad9f |
201 | like( |
202 | exception { $obj->option_accessor( undef, 'bar' ) }, |
203 | qr/Hash keys passed to accessor must be defined/, |
204 | 'exception when using undef as a key' |
205 | ); |
206 | |
2d779ce6 |
207 | is_deeply( |
5dcac913 |
208 | $obj->options, { quantity => 4, size => 42 }, |
2d779ce6 |
209 | 'accessor as writer' |
210 | ); |
211 | |
b10dde3a |
212 | is( exception { |
1c08fd75 |
213 | $class->new( options => { foo => 'BAR' } ); |
b10dde3a |
214 | }, undef, '... good constructor params' ); |
1c08fd75 |
215 | |
b10dde3a |
216 | isnt( exception { |
1c08fd75 |
217 | $obj->set_option( bar => {} ); |
b10dde3a |
218 | }, undef, '... could not add a hash ref where an string is expected' ); |
1c08fd75 |
219 | |
b10dde3a |
220 | isnt( exception { |
1c08fd75 |
221 | $class->new( options => { foo => [] } ); |
b10dde3a |
222 | }, undef, '... bad constructor params' ); |
1c08fd75 |
223 | |
2d779ce6 |
224 | $obj->options( {} ); |
225 | |
7f5ec80d |
226 | is_deeply( |
227 | [ $obj->set_option( oink => "blah", xxy => "flop" ) ], |
228 | [ 'blah', 'flop' ], |
229 | 'set returns newly set values in order of keys provided' |
230 | ); |
231 | |
1399eab0 |
232 | is_deeply( |
233 | [ sort $obj->keys ], |
2d779ce6 |
234 | [ 'oink', 'xxy' ], |
1399eab0 |
235 | 'keys returns expected keys' |
236 | ); |
237 | |
238 | is_deeply( |
239 | [ sort $obj->values ], |
2d779ce6 |
240 | [ 'blah', 'flop' ], |
1399eab0 |
241 | 'values returns expected values' |
242 | ); |
243 | |
1c08fd75 |
244 | my @key_value = sort { $a->[0] cmp $b->[0] } $obj->key_value; |
245 | is_deeply( |
246 | \@key_value, |
247 | [ |
248 | sort { $a->[0] cmp $b->[0] }[ 'xxy', 'flop' ], |
1c08fd75 |
249 | [ 'oink', 'blah' ] |
250 | ], |
251 | '... got the right key value pairs' |
252 | ) |
253 | or do { |
254 | require Data::Dumper; |
255 | diag( Data::Dumper::Dumper( \@key_value ) ); |
256 | }; |
257 | |
258 | my %options_elements = $obj->options_elements; |
259 | is_deeply( |
260 | \%options_elements, { |
261 | 'oink' => 'blah', |
1c08fd75 |
262 | 'xxy' => 'flop' |
263 | }, |
264 | '... got the right hash elements' |
265 | ); |
266 | |
267 | if ( $class->meta->get_attribute('options')->is_lazy ) { |
268 | my $obj = $class->new; |
269 | |
270 | $obj->set_option( y => 2 ); |
271 | |
272 | is_deeply( |
273 | $obj->options, { x => 1, y => 2 }, |
274 | 'set_option with lazy default' |
275 | ); |
276 | |
277 | $obj->_clear_options; |
278 | |
279 | ok( |
280 | $obj->has_option('x'), |
281 | 'key for x exists - lazy default' |
282 | ); |
283 | |
284 | $obj->_clear_options; |
285 | |
286 | ok( |
287 | $obj->is_defined('x'), |
288 | 'key for x is defined - lazy default' |
289 | ); |
290 | |
291 | $obj->_clear_options; |
292 | |
293 | is_deeply( |
294 | [ $obj->key_value ], |
295 | [ [ x => 1 ] ], |
296 | 'kv returns lazy default' |
297 | ); |
865faf6f |
298 | |
865faf6f |
299 | $obj->_clear_options; |
300 | |
301 | $obj->option_accessor( y => 2 ); |
302 | |
303 | is_deeply( |
304 | [ sort $obj->keys ], |
305 | [ 'x', 'y' ], |
306 | 'accessor triggers lazy default generator' |
307 | ); |
1c08fd75 |
308 | } |
309 | } |
310 | $class; |
d50fc84a |
311 | } |
a28e50e4 |
312 | |
76ae56f1 |
313 | { |
9af9be92 |
314 | my ( $class, $handles ) = build_class( isa => 'HashRef' ); |
76ae56f1 |
315 | my $obj = $class->new; |
316 | with_immutable { |
9af9be92 |
317 | is( |
318 | exception { $obj->option_accessor( 'foo', undef ) }, |
319 | undef, |
320 | 'can use accessor to set value to undef' |
321 | ); |
322 | is( |
323 | exception { $obj->quantity(undef) }, |
324 | undef, |
325 | 'can use accessor to set value to undef' |
326 | ); |
327 | } |
328 | $class; |
76ae56f1 |
329 | } |
330 | |
a28e50e4 |
331 | done_testing; |