9 use Moose::Util::MetaRole;
10 use Moose::Util::TypeConstraints;
11 use NoInlineAttribute;
19 elements => 'elements',
20 is_empty => 'is_empty',
26 [ unshift => 42, 84 ],
30 get_curried => [ get => 1 ],
32 set_curried_1 => [ set => 1 ],
33 set_curried_2 => [ set => ( 1, 98 ) ],
34 accessor => 'accessor',
35 accessor_curried_1 => [ accessor => 1 ],
36 accessor_curried_2 => [ accessor => ( 1, 90 ) ],
39 delete_curried => [ delete => 1 ],
41 insert_curried => [ insert => ( 1, 101 ) ],
43 splice_curried_1 => [ splice => 1 ],
44 splice_curried_2 => [ splice => 1, 2 ],
45 splice_curried_all => [ splice => 1, 2, ( 3, 4, 5 ) ],
47 sort_curried => [ sort => ( sub { $_[1] <=> $_[0] } ) ],
48 sort_in_place => 'sort_in_place',
49 sort_in_place_curried =>
50 [ sort_in_place => ( sub { $_[1] <=> $_[0] } ) ],
52 map_curried => [ map => ( sub { $_ + 1 } ) ],
54 grep_curried => [ grep => ( sub { $_ < 5 } ) ],
56 first_curried => [ first => ( sub { $_ % 2 } ) ],
58 join_curried => [ join => '-' ],
62 reduce_curried => [ reduce => ( sub { $_[0] * $_[1] } ) ],
63 natatime => 'natatime',
64 natatime_curried => [ natatime => 2 ],
72 my $class = Moose::Meta::Class->create(
74 superclasses => ['Moose::Object'],
78 push @traits, 'NoInlineAttribute'
79 if delete $attr{no_inline};
81 $class->add_attribute(
85 isa => 'ArrayRef[Int]',
86 default => sub { [] },
88 clearer => '_clear_values',
93 return ( $class->name, \%handles );
98 run_tests(build_class);
99 run_tests( build_class( lazy => 1, default => sub { [ 42, 84 ] } ) );
100 run_tests( build_class( trigger => sub { } ) );
101 run_tests( build_class( no_inline => 1 ) );
103 # Will force the inlining code to check the entire arrayref when it is modified.
104 subtype 'MyArrayRef', as 'ArrayRef', where { 1 };
106 run_tests( build_class( isa => 'MyArrayRef' ) );
108 coerce 'MyArrayRef', from 'ArrayRef', via { $_ };
110 run_tests( build_class( isa => 'MyArrayRef', coerce => 1 ) );
114 my ( $class, $handles ) = @_;
116 can_ok( $class, $_ ) for sort keys %{$handles};
119 my $obj = $class->new( _values => [ 10, 12, 42 ] );
122 $obj->_values, [ 10, 12, 42 ],
123 'values can be set in constructor'
126 ok( !$obj->is_empty, 'values is not empty' );
127 is( $obj->count, 3, 'count returns 3' );
129 throws_ok { $obj->count(22) }
130 qr/Cannot call count with any arguments/,
131 'throws an error when passing an argument passed to count';
133 lives_ok { $obj->push( 1, 2, 3 ) }
134 'pushed three new values and lived';
136 lives_ok { $obj->push() } 'call to push without arguments lives';
138 lives_ok { $obj->unshift( 101, 22 ) }
139 'unshifted two values and lived';
142 $obj->_values, [ 101, 22, 10, 12, 42, 1, 2, 3 ],
143 'unshift changed the value of the array in the object'
146 lives_ok { $obj->unshift() }
147 'call to unshift without arguments lives';
149 is( $obj->pop, 3, 'pop returns the last value in the array' );
152 $obj->_values, [ 101, 22, 10, 12, 42, 1, 2 ],
153 'pop changed the value of the array in the object'
156 throws_ok { $obj->pop(42) }
157 qr/Cannot call pop with any arguments/,
158 'call to pop with arguments dies';
160 is( $obj->shift, 101, 'shift returns the first value' );
162 throws_ok { $obj->shift(42) }
163 qr/Cannot call shift with any arguments/,
164 'call to shift with arguments dies';
167 $obj->_values, [ 22, 10, 12, 42, 1, 2 ],
168 'shift changed the value of the array in the object'
172 [ $obj->elements ], [ 22, 10, 12, 42, 1, 2 ],
173 'call to elements returns values as a list'
176 throws_ok { $obj->elements(22) }
177 qr/Cannot call elements with any arguments/,
178 'throws an error when passing an argument passed to elements';
180 $obj->_values( [ 1, 2, 3 ] );
182 is( $obj->get(0), 1, 'get values at index 0' );
183 is( $obj->get(1), 2, 'get values at index 1' );
184 is( $obj->get(2), 3, 'get values at index 2' );
185 is( $obj->get_curried, 2, 'get_curried returns value at index 1' );
187 throws_ok { $obj->get() }
188 qr/Cannot call get without at least 1 argument/,
189 'throws an error when get is called without any arguments';
191 throws_ok { $obj->get( {} ) }
192 qr/The index passed to get must be an integer/,
193 'throws an error when get is called with an invalid argument';
195 throws_ok { $obj->get(2.2) }
196 qr/The index passed to get must be an integer/,
197 'throws an error when get is called with an invalid argument';
199 throws_ok { $obj->get('foo') }
200 qr/The index passed to get must be an integer/,
201 'throws an error when get is called with an invalid argument';
203 throws_ok { $obj->get_curried(2) }
204 qr/Cannot call get with more than 1 argument/,
205 'throws an error when get_curried is called with an argument';
207 lives_ok { $obj->set( 1, 100 ) } 'set value at index 1 lives';
209 is( $obj->get(1), 100, 'get value at index 1 returns new value' );
211 throws_ok { $obj->set( 1, 99, 42 ) }
212 qr/Cannot call set with more than 2 arguments/,
213 'throws an error when set is called with three arguments';
215 lives_ok { $obj->set_curried_1(99) } 'set_curried_1 lives';
217 is( $obj->get(1), 99, 'get value at index 1 returns new value' );
219 throws_ok { $obj->set_curried_1( 99, 42 ) }
220 qr/Cannot call set with more than 2 arguments/,
221 'throws an error when set_curried_1 is called with two arguments';
223 lives_ok { $obj->set_curried_2 } 'set_curried_2 lives';
225 is( $obj->get(1), 98, 'get value at index 1 returns new value' );
227 throws_ok { $obj->set_curried_2(42) }
228 qr/Cannot call set with more than 2 arguments/,
229 'throws an error when set_curried_2 is called with one argument';
232 $obj->accessor(1), 98,
233 'accessor with one argument returns value at index 1'
236 lives_ok { $obj->accessor( 1 => 97 ) } 'accessor as writer lives';
240 'accessor set value at index 1'
243 throws_ok { $obj->accessor( 1, 96, 42 ) }
244 qr/Cannot call accessor with more than 2 arguments/,
245 'throws an error when accessor is called with three arguments';
248 $obj->accessor_curried_1, 97,
249 'accessor_curried_1 returns expected value when called with no arguments'
252 lives_ok { $obj->accessor_curried_1(95) }
253 'accessor_curried_1 as writer lives';
257 'accessor_curried_1 set value at index 1'
260 throws_ok { $obj->accessor_curried_1( 96, 42 ) }
261 qr/Cannot call accessor with more than 2 arguments/,
262 'throws an error when accessor_curried_1 is called with two arguments';
264 lives_ok { $obj->accessor_curried_2 }
265 'accessor_curried_2 as writer lives';
269 'accessor_curried_2 set value at index 1'
272 throws_ok { $obj->accessor_curried_2(42) }
273 qr/Cannot call accessor with more than 2 arguments/,
274 'throws an error when accessor_curried_2 is called with one argument';
276 lives_ok { $obj->clear } 'clear lives';
278 ok( $obj->is_empty, 'values is empty after call to clear' );
280 $obj->set( 0 => 42 );
282 throws_ok { $obj->clear(50) }
283 qr/Cannot call clear with any arguments/,
284 'throws an error when clear is called with an argument';
288 'values is not empty after failed call to clear'
291 throws_ok { $obj->is_empty(50) }
292 qr/Cannot call is_empty with any arguments/,
293 'throws an error when is_empty is called with an argument';
296 $obj->push( 1, 5, 10, 42 );
298 lives_ok { $obj->delete(2) } 'delete lives';
301 $obj->_values, [ 1, 5, 42 ],
302 'delete removed the specified element'
305 throws_ok { $obj->delete( 2, 3 ) }
306 qr/Cannot call delete with more than 1 argument/,
307 'throws an error when delete is called with two arguments';
309 lives_ok { $obj->delete_curried } 'delete_curried lives';
312 $obj->_values, [ 1, 42 ],
313 'delete removed the specified element'
316 throws_ok { $obj->delete_curried(2) }
317 qr/Cannot call delete with more than 1 argument/,
318 'throws an error when delete_curried is called with one argument';
320 lives_ok { $obj->insert( 1, 21 ) } 'insert lives';
323 $obj->_values, [ 1, 21, 42 ],
324 'insert added the specified element'
327 throws_ok { $obj->insert( 1, 22, 44 ) }
328 qr/Cannot call insert with more than 2 arguments/,
329 'throws an error when insert is called with three arguments';
331 lives_ok { $obj->splice( 1, 0, 2, 3 ) } 'splice lives';
334 $obj->_values, [ 1, 2, 3, 21, 42 ],
335 'splice added the specified elements'
338 lives_ok { $obj->splice( 1, 1, 99 ) } 'splice lives';
341 $obj->_values, [ 1, 99, 3, 21, 42 ],
342 'splice added the specified elements'
345 throws_ok { $obj->splice() }
346 qr/Cannot call splice without at least 1 argument/,
347 'throws an error when splice is called with no arguments';
349 throws_ok { $obj->splice( 1, 'foo', ) }
350 qr/The length argument passed to splice must be an integer/,
351 'throws an error when splice is called with an invalid length';
353 lives_ok { $obj->splice_curried_1( 2, 101 ) }
354 'splice_curried_1 lives';
357 $obj->_values, [ 1, 101, 21, 42 ],
358 'splice added the specified elements'
361 lives_ok { $obj->splice_curried_2(102) } 'splice_curried_2 lives';
364 $obj->_values, [ 1, 102, 42 ],
365 'splice added the specified elements'
368 lives_ok { $obj->splice_curried_all } 'splice_curried_all lives';
371 $obj->_values, [ 1, 3, 4, 5 ],
372 'splice added the specified elements'
375 $obj->_values( [ 3, 9, 5, 22, 11 ] );
378 [ $obj->sort ], [ 11, 22, 3, 5, 9 ],
379 'sort returns sorted values'
383 [ $obj->sort( sub { $_[0] <=> $_[1] } ) ], [ 3, 5, 9, 11, 22 ],
384 'sort returns values sorted by provided function'
387 throws_ok { $obj->sort(1) }
388 qr/The argument passed to sort must be a code reference/,
389 'throws an error when passing a non coderef to sort';
392 $obj->sort( sub { }, 27 );
394 qr/Cannot call sort with more than 1 argument/,
395 'throws an error when passing two arguments to sort';
397 $obj->_values( [ 3, 9, 5, 22, 11 ] );
402 $obj->_values, [ 11, 22, 3, 5, 9 ],
403 'sort_in_place sorts values'
406 $obj->sort_in_place( sub { $_[0] <=> $_[1] } );
409 $obj->_values, [ 3, 5, 9, 11, 22 ],
410 'sort_in_place with function sorts values'
414 $obj->sort_in_place( 27 );
416 qr/The argument passed to sort_in_place must be a code reference/,
417 'throws an error when passing a non coderef to sort_in_place';
420 $obj->sort_in_place( sub { }, 27 );
422 qr/Cannot call sort_in_place with more than 1 argument/,
423 'throws an error when passing two arguments to sort_in_place';
425 $obj->_values( [ 3, 9, 5, 22, 11 ] );
427 $obj->sort_in_place_curried;
430 $obj->_values, [ 22, 11, 9, 5, 3 ],
431 'sort_in_place_curried sorts values'
434 throws_ok { $obj->sort_in_place_curried(27) }
435 qr/Cannot call sort_in_place with more than 1 argument/,
436 'throws an error when passing one argument passed to sort_in_place_curried';
438 $obj->_values( [ 1 .. 5 ] );
441 [ $obj->map( sub { $_ + 1 } ) ],
443 'map returns the expected values'
446 throws_ok { $obj->map }
447 qr/Cannot call map without at least 1 argument/,
448 'throws an error when passing no arguments to map';
451 $obj->map( sub { }, 2 );
453 qr/Cannot call map with more than 1 argument/,
454 'throws an error when passing two arguments to map';
456 throws_ok { $obj->map( {} ) }
457 qr/The argument passed to map must be a code reference/,
458 'throws an error when passing a non coderef to map';
460 $obj->_values( [ 1 .. 5 ] );
463 [ $obj->map_curried ],
465 'map_curried returns the expected values'
469 $obj->map_curried( sub { } );
471 qr/Cannot call map with more than 1 argument/,
472 'throws an error when passing one argument passed to map_curried';
474 $obj->_values( [ 2 .. 9 ] );
477 [ $obj->grep( sub { $_ < 5 } ) ],
479 'grep returns the expected values'
482 throws_ok { $obj->grep }
483 qr/Cannot call grep without at least 1 argument/,
484 'throws an error when passing no arguments to grep';
487 $obj->grep( sub { }, 2 );
489 qr/Cannot call grep with more than 1 argument/,
490 'throws an error when passing two arguments to grep';
492 throws_ok { $obj->grep( {} ) }
493 qr/The argument passed to grep must be a code reference/,
494 'throws an error when passing a non coderef to grep';
497 [ $obj->grep_curried ],
499 'grep_curried returns the expected values'
503 $obj->grep_curried( sub { } );
505 qr/Cannot call grep with more than 1 argument/,
506 'throws an error when passing one argument passed to grep_curried';
508 $obj->_values( [ 2, 4, 22, 99, 101, 6 ] );
511 $obj->first( sub { $_ % 2 } ),
513 'first returns expected value'
516 throws_ok { $obj->first }
517 qr/Cannot call first without at least 1 argument/,
518 'throws an error when passing no arguments to first';
521 $obj->first( sub { }, 2 );
523 qr/Cannot call first with more than 1 argument/,
524 'throws an error when passing two arguments to first';
526 throws_ok { $obj->first( {} ) }
527 qr/The argument passed to first must be a code reference/,
528 'throws an error when passing a non coderef to first';
533 'first_curried returns expected value'
537 $obj->first_curried( sub { } );
539 qr/Cannot call first with more than 1 argument/,
540 'throws an error when passing one argument passed to first_curried';
542 $obj->_values( [ 1 .. 4 ] );
545 $obj->join('-'), '1-2-3-4',
546 'join returns expected result'
549 throws_ok { $obj->join }
550 qr/Cannot call join without at least 1 argument/,
551 'throws an error when passing no arguments to join';
553 throws_ok { $obj->join( '-', 2 ) }
554 qr/Cannot call join with more than 1 argument/,
555 'throws an error when passing two arguments to join';
557 throws_ok { $obj->join( {} ) }
558 qr/The argument passed to join must be a string/,
559 'throws an error when passing a non string to join';
562 [ sort $obj->shuffle ],
564 'shuffle returns all values (cannot check for a random order)'
567 throws_ok { $obj->shuffle(2) }
568 qr/Cannot call shuffle with any arguments/,
569 'throws an error when passing an argument passed to shuffle';
571 $obj->_values( [ 1 .. 4, 2, 5, 3, 7, 3, 3, 1 ] );
576 'uniq returns expected values (in original order)'
579 throws_ok { $obj->uniq(2) }
580 qr/Cannot call uniq with any arguments/,
581 'throws an error when passing an argument passed to uniq';
583 $obj->_values( [ 1 .. 5 ] );
586 $obj->reduce( sub { $_[0] * $_[1] } ),
588 'reduce returns expected value'
591 throws_ok { $obj->reduce }
592 qr/Cannot call reduce without at least 1 argument/,
593 'throws an error when passing no arguments to reduce';
596 $obj->reduce( sub { }, 2 );
598 qr/Cannot call reduce with more than 1 argument/,
599 'throws an error when passing two arguments to reduce';
601 throws_ok { $obj->reduce( {} ) }
602 qr/The argument passed to reduce must be a code reference/,
603 'throws an error when passing a non coderef to reduce';
606 $obj->reduce_curried,
608 'reduce_curried returns expected value'
612 $obj->reduce_curried( sub { } );
614 qr/Cannot call reduce with more than 1 argument/,
615 'throws an error when passing one argument passed to reduce_curried';
617 $obj->_values( [ 1 .. 6 ] );
619 my $it = $obj->natatime(2);
621 while ( my @v = $it->() ) {
626 [ [ 1, 2 ], [ 3, 4 ], [ 5, 6 ] ],
628 'natatime returns expected iterator'
632 $obj->natatime( 2, sub { push @nat, [@_] } );
635 [ [ 1, 2 ], [ 3, 4 ], [ 5, 6 ] ],
637 'natatime with function returns expected value'
640 throws_ok { $obj->natatime( {} ) }
641 qr/The n value passed to natatime must be an integer/,
642 'throws an error when passing a non integer to natatime';
644 throws_ok { $obj->natatime( 2, {} ) }
645 qr/The second argument passed to natatime must be a code reference/,
646 'throws an error when passing a non code ref to natatime';
648 $it = $obj->natatime_curried();
650 while ( my @v = $it->() ) {
655 [ [ 1, 2 ], [ 3, 4 ], [ 5, 6 ] ],
657 'natatime_curried returns expected iterator'
661 $obj->natatime_curried( sub { push @nat, [@_] } );
664 [ [ 1, 2 ], [ 3, 4 ], [ 5, 6 ] ],
666 'natatime_curried with function returns expected value'
669 throws_ok { $obj->natatime_curried( {} ) }
670 qr/The second argument passed to natatime must be a code reference/,
671 'throws an error when passing a non code ref to natatime_curried';
673 if ( $class->meta->get_attribute('_values')->is_lazy ) {
674 my $obj = $class->new;
676 is( $obj->count, 2, 'count is 2 (lazy init)' );
681 [ $obj->elements ], [ 42, 84 ],
682 'elements contains default with lazy init'
690 $obj->_values, [ 42, 84, 2 ],
691 'push works with lazy init'
696 $obj->unshift( 3, 4 );
699 $obj->_values, [ 3, 4, 42, 84 ],
700 'unshift works with lazy init'