9 use Moose::Util::TypeConstraints;
10 use NoInlineAttribute;
18 elements => 'elements',
19 is_empty => 'is_empty',
25 [ unshift => 42, 84 ],
29 get_curried => [ get => 1 ],
31 set_curried_1 => [ set => 1 ],
32 set_curried_2 => [ set => ( 1, 98 ) ],
33 accessor => 'accessor',
34 accessor_curried_1 => [ accessor => 1 ],
35 accessor_curried_2 => [ accessor => ( 1, 90 ) ],
38 delete_curried => [ delete => 1 ],
40 insert_curried => [ insert => ( 1, 101 ) ],
42 splice_curried_1 => [ splice => 1 ],
43 splice_curried_2 => [ splice => 1, 2 ],
44 splice_curried_all => [ splice => 1, 2, ( 3, 4, 5 ) ],
46 sort_curried => [ sort => ( sub { $_[1] <=> $_[0] } ) ],
47 sort_in_place => 'sort_in_place',
48 sort_in_place_curried =>
49 [ sort_in_place => ( sub { $_[1] <=> $_[0] } ) ],
51 map_curried => [ map => ( sub { $_ + 1 } ) ],
53 grep_curried => [ grep => ( sub { $_ < 5 } ) ],
55 first_curried => [ first => ( sub { $_ % 2 } ) ],
57 join_curried => [ join => '-' ],
61 reduce_curried => [ reduce => ( sub { $_[0] * $_[1] } ) ],
62 natatime => 'natatime',
63 natatime_curried => [ natatime => 2 ],
71 my $class = Moose::Meta::Class->create(
73 superclasses => ['Moose::Object'],
77 push @traits, 'NoInlineAttribute'
78 if delete $attr{no_inline};
80 $class->add_attribute(
84 isa => 'ArrayRef[Int]',
85 default => sub { [] },
87 clearer => '_clear_values',
92 return ( $class->name, \%handles );
100 '&{}' => sub { ${ $_[0] } },
109 run_tests(build_class);
110 run_tests( build_class( lazy => 1, default => sub { [ 42, 84 ] } ) );
111 run_tests( build_class( trigger => sub { } ) );
112 run_tests( build_class( no_inline => 1 ) );
114 # Will force the inlining code to check the entire arrayref when it is modified.
115 subtype 'MyArrayRef', as 'ArrayRef', where { 1 };
117 run_tests( build_class( isa => 'MyArrayRef' ) );
119 coerce 'MyArrayRef', from 'ArrayRef', via { $_ };
121 run_tests( build_class( isa => 'MyArrayRef', coerce => 1 ) );
125 my ( $class, $handles ) = @_;
127 can_ok( $class, $_ ) for sort keys %{$handles};
130 my $obj = $class->new( _values => [ 10, 12, 42 ] );
133 $obj->_values, [ 10, 12, 42 ],
134 'values can be set in constructor'
137 ok( !$obj->is_empty, 'values is not empty' );
138 is( $obj->count, 3, 'count returns 3' );
140 throws_ok { $obj->count(22) }
141 qr/Cannot call count with any arguments/,
142 'throws an error when passing an argument passed to count';
144 lives_ok { $obj->push( 1, 2, 3 ) }
145 'pushed three new values and lived';
147 lives_ok { $obj->push() } 'call to push without arguments lives';
150 is( $obj->unshift( 101, 22 ), 8,
151 'unshift returns size of the new array' );
153 'unshifted two values and lived';
156 $obj->_values, [ 101, 22, 10, 12, 42, 1, 2, 3 ],
157 'unshift changed the value of the array in the object'
160 lives_ok { $obj->unshift() }
161 'call to unshift without arguments lives';
163 is( $obj->pop, 3, 'pop returns the last value in the array' );
166 $obj->_values, [ 101, 22, 10, 12, 42, 1, 2 ],
167 'pop changed the value of the array in the object'
170 throws_ok { $obj->pop(42) }
171 qr/Cannot call pop with any arguments/,
172 'call to pop with arguments dies';
174 is( $obj->shift, 101, 'shift returns the first value' );
176 throws_ok { $obj->shift(42) }
177 qr/Cannot call shift with any arguments/,
178 'call to shift with arguments dies';
181 $obj->_values, [ 22, 10, 12, 42, 1, 2 ],
182 'shift changed the value of the array in the object'
186 [ $obj->elements ], [ 22, 10, 12, 42, 1, 2 ],
187 'call to elements returns values as a list'
190 throws_ok { $obj->elements(22) }
191 qr/Cannot call elements with any arguments/,
192 'throws an error when passing an argument passed to elements';
194 $obj->_values( [ 1, 2, 3 ] );
196 is( $obj->get(0), 1, 'get values at index 0' );
197 is( $obj->get(1), 2, 'get values at index 1' );
198 is( $obj->get(2), 3, 'get values at index 2' );
199 is( $obj->get_curried, 2, 'get_curried returns value at index 1' );
201 throws_ok { $obj->get() }
202 qr/Cannot call get without at least 1 argument/,
203 'throws an error when get is called without any arguments';
205 throws_ok { $obj->get( {} ) }
206 qr/The index passed to get must be an integer/,
207 'throws an error when get is called with an invalid argument';
209 throws_ok { $obj->get(2.2) }
210 qr/The index passed to get must be an integer/,
211 'throws an error when get is called with an invalid argument';
213 throws_ok { $obj->get('foo') }
214 qr/The index passed to get must be an integer/,
215 'throws an error when get is called with an invalid argument';
217 throws_ok { $obj->get_curried(2) }
218 qr/Cannot call get with more than 1 argument/,
219 'throws an error when get_curried is called with an argument';
222 is( $obj->set( 1, 100 ), 100, 'set returns new value' );
224 'set value at index 1 lives';
226 is( $obj->get(1), 100, 'get value at index 1 returns new value' );
229 throws_ok { $obj->set( 1, 99, 42 ) }
230 qr/Cannot call set with more than 2 arguments/,
231 'throws an error when set is called with three arguments';
233 lives_ok { $obj->set_curried_1(99) } 'set_curried_1 lives';
235 is( $obj->get(1), 99, 'get value at index 1 returns new value' );
237 throws_ok { $obj->set_curried_1( 99, 42 ) }
238 qr/Cannot call set with more than 2 arguments/,
239 'throws an error when set_curried_1 is called with two arguments';
241 lives_ok { $obj->set_curried_2 } 'set_curried_2 lives';
243 is( $obj->get(1), 98, 'get value at index 1 returns new value' );
245 throws_ok { $obj->set_curried_2(42) }
246 qr/Cannot call set with more than 2 arguments/,
247 'throws an error when set_curried_2 is called with one argument';
250 $obj->accessor(1), 98,
251 'accessor with one argument returns value at index 1'
255 is( $obj->accessor( 1 => 97 ), 97, 'accessor returns new value' );
257 'accessor as writer lives';
261 'accessor set value at index 1'
264 throws_ok { $obj->accessor( 1, 96, 42 ) }
265 qr/Cannot call accessor with more than 2 arguments/,
266 'throws an error when accessor is called with three arguments';
269 $obj->accessor_curried_1, 97,
270 'accessor_curried_1 returns expected value when called with no arguments'
273 lives_ok { $obj->accessor_curried_1(95) }
274 'accessor_curried_1 as writer lives';
278 'accessor_curried_1 set value at index 1'
281 throws_ok { $obj->accessor_curried_1( 96, 42 ) }
282 qr/Cannot call accessor with more than 2 arguments/,
283 'throws an error when accessor_curried_1 is called with two arguments';
285 lives_ok { $obj->accessor_curried_2 }
286 'accessor_curried_2 as writer lives';
290 'accessor_curried_2 set value at index 1'
293 throws_ok { $obj->accessor_curried_2(42) }
294 qr/Cannot call accessor with more than 2 arguments/,
295 'throws an error when accessor_curried_2 is called with one argument';
297 lives_ok { $obj->clear } 'clear lives';
299 ok( $obj->is_empty, 'values is empty after call to clear' );
301 $obj->set( 0 => 42 );
303 throws_ok { $obj->clear(50) }
304 qr/Cannot call clear with any arguments/,
305 'throws an error when clear is called with an argument';
309 'values is not empty after failed call to clear'
312 throws_ok { $obj->is_empty(50) }
313 qr/Cannot call is_empty with any arguments/,
314 'throws an error when is_empty is called with an argument';
318 $obj->push( 1, 5, 10, 42 ), 4,
319 'pushed 4 elements, got number of elements in the array back'
323 is( $obj->delete(2), 10, 'delete returns deleted value' );
328 $obj->_values, [ 1, 5, 42 ],
329 'delete removed the specified element'
332 throws_ok { $obj->delete( 2, 3 ) }
333 qr/Cannot call delete with more than 1 argument/,
334 'throws an error when delete is called with two arguments';
336 lives_ok { $obj->delete_curried } 'delete_curried lives';
339 $obj->_values, [ 1, 42 ],
340 'delete removed the specified element'
343 throws_ok { $obj->delete_curried(2) }
344 qr/Cannot call delete with more than 1 argument/,
345 'throws an error when delete_curried is called with one argument';
347 lives_ok { $obj->insert( 1, 21 ) } 'insert lives';
350 $obj->_values, [ 1, 21, 42 ],
351 'insert added the specified element'
354 throws_ok { $obj->insert( 1, 22, 44 ) }
355 qr/Cannot call insert with more than 2 arguments/,
356 'throws an error when insert is called with three arguments';
360 [ $obj->splice( 1, 0, 2, 3 ) ],
362 'return value of splice is empty list when not removing elements'
368 $obj->_values, [ 1, 2, 3, 21, 42 ],
369 'splice added the specified elements'
374 [ $obj->splice( 1, 2, 99 ) ],
376 'splice returns list of removed values'
382 $obj->_values, [ 1, 99, 21, 42 ],
383 'splice added the specified elements'
386 throws_ok { $obj->splice() }
387 qr/Cannot call splice without at least 1 argument/,
388 'throws an error when splice is called with no arguments';
390 throws_ok { $obj->splice( 1, 'foo', ) }
391 qr/The length argument passed to splice must be an integer/,
392 'throws an error when splice is called with an invalid length';
394 lives_ok { $obj->splice_curried_1( 2, 101 ) }
395 'splice_curried_1 lives';
398 $obj->_values, [ 1, 101, 42 ],
399 'splice added the specified elements'
402 lives_ok { $obj->splice_curried_2(102) } 'splice_curried_2 lives';
405 $obj->_values, [ 1, 102 ],
406 'splice added the specified elements'
409 lives_ok { $obj->splice_curried_all } 'splice_curried_all lives';
412 $obj->_values, [ 1, 3, 4, 5 ],
413 'splice added the specified elements'
417 scalar $obj->splice( 1, 2 ),
419 'splice in scalar context returns last element removed'
423 scalar $obj->splice( 1, 0, 42 ),
425 'splice in scalar context returns undef when no elements are removed'
428 $obj->_values( [ 3, 9, 5, 22, 11 ] );
431 [ $obj->sort ], [ 11, 22, 3, 5, 9 ],
432 'sort returns sorted values'
436 [ $obj->sort( sub { $_[0] <=> $_[1] } ) ], [ 3, 5, 9, 11, 22 ],
437 'sort returns values sorted by provided function'
440 throws_ok { $obj->sort(1) }
441 qr/The argument passed to sort must be a code reference/,
442 'throws an error when passing a non coderef to sort';
445 $obj->sort( sub { }, 27 );
447 qr/Cannot call sort with more than 1 argument/,
448 'throws an error when passing two arguments to sort';
450 $obj->_values( [ 3, 9, 5, 22, 11 ] );
455 $obj->_values, [ 11, 22, 3, 5, 9 ],
456 'sort_in_place sorts values'
459 $obj->sort_in_place( sub { $_[0] <=> $_[1] } );
462 $obj->_values, [ 3, 5, 9, 11, 22 ],
463 'sort_in_place with function sorts values'
467 $obj->sort_in_place( 27 );
469 qr/The argument passed to sort_in_place must be a code reference/,
470 'throws an error when passing a non coderef to sort_in_place';
473 $obj->sort_in_place( sub { }, 27 );
475 qr/Cannot call sort_in_place with more than 1 argument/,
476 'throws an error when passing two arguments to sort_in_place';
478 $obj->_values( [ 3, 9, 5, 22, 11 ] );
480 $obj->sort_in_place_curried;
483 $obj->_values, [ 22, 11, 9, 5, 3 ],
484 'sort_in_place_curried sorts values'
487 throws_ok { $obj->sort_in_place_curried(27) }
488 qr/Cannot call sort_in_place with more than 1 argument/,
489 'throws an error when passing one argument passed to sort_in_place_curried';
491 $obj->_values( [ 1 .. 5 ] );
494 [ $obj->map( sub { $_ + 1 } ) ],
496 'map returns the expected values'
499 throws_ok { $obj->map }
500 qr/Cannot call map without at least 1 argument/,
501 'throws an error when passing no arguments to map';
504 $obj->map( sub { }, 2 );
506 qr/Cannot call map with more than 1 argument/,
507 'throws an error when passing two arguments to map';
509 throws_ok { $obj->map( {} ) }
510 qr/The argument passed to map must be a code reference/,
511 'throws an error when passing a non coderef to map';
513 $obj->_values( [ 1 .. 5 ] );
516 [ $obj->map_curried ],
518 'map_curried returns the expected values'
522 $obj->map_curried( sub { } );
524 qr/Cannot call map with more than 1 argument/,
525 'throws an error when passing one argument passed to map_curried';
527 $obj->_values( [ 2 .. 9 ] );
530 [ $obj->grep( sub { $_ < 5 } ) ],
532 'grep returns the expected values'
535 throws_ok { $obj->grep }
536 qr/Cannot call grep without at least 1 argument/,
537 'throws an error when passing no arguments to grep';
540 $obj->grep( sub { }, 2 );
542 qr/Cannot call grep with more than 1 argument/,
543 'throws an error when passing two arguments to grep';
545 throws_ok { $obj->grep( {} ) }
546 qr/The argument passed to grep must be a code reference/,
547 'throws an error when passing a non coderef to grep';
549 my $overloader = Overloader->new( sub { $_ < 5 } );
551 [ $obj->grep($overloader) ],
553 'grep works with obj that overload code dereferencing'
557 [ $obj->grep_curried ],
559 'grep_curried returns the expected values'
563 $obj->grep_curried( sub { } );
565 qr/Cannot call grep with more than 1 argument/,
566 'throws an error when passing one argument passed to grep_curried';
568 $obj->_values( [ 2, 4, 22, 99, 101, 6 ] );
571 $obj->first( sub { $_ % 2 } ),
573 'first returns expected value'
576 throws_ok { $obj->first }
577 qr/Cannot call first without at least 1 argument/,
578 'throws an error when passing no arguments to first';
581 $obj->first( sub { }, 2 );
583 qr/Cannot call first with more than 1 argument/,
584 'throws an error when passing two arguments to first';
586 throws_ok { $obj->first( {} ) }
587 qr/The argument passed to first must be a code reference/,
588 'throws an error when passing a non coderef to first';
593 'first_curried returns expected value'
597 $obj->first_curried( sub { } );
599 qr/Cannot call first with more than 1 argument/,
600 'throws an error when passing one argument passed to first_curried';
602 $obj->_values( [ 1 .. 4 ] );
605 $obj->join('-'), '1-2-3-4',
606 'join returns expected result'
610 $obj->join(q{}), '1234',
611 'join returns expected result when joining with empty string'
614 throws_ok { $obj->join }
615 qr/Cannot call join without at least 1 argument/,
616 'throws an error when passing no arguments to join';
618 throws_ok { $obj->join( '-', 2 ) }
619 qr/Cannot call join with more than 1 argument/,
620 'throws an error when passing two arguments to join';
622 throws_ok { $obj->join( {} ) }
623 qr/The argument passed to join must be a string/,
624 'throws an error when passing a non string to join';
627 [ sort $obj->shuffle ],
629 'shuffle returns all values (cannot check for a random order)'
632 throws_ok { $obj->shuffle(2) }
633 qr/Cannot call shuffle with any arguments/,
634 'throws an error when passing an argument passed to shuffle';
636 $obj->_values( [ 1 .. 4, 2, 5, 3, 7, 3, 3, 1 ] );
641 'uniq returns expected values (in original order)'
644 throws_ok { $obj->uniq(2) }
645 qr/Cannot call uniq with any arguments/,
646 'throws an error when passing an argument passed to uniq';
648 $obj->_values( [ 1 .. 5 ] );
651 $obj->reduce( sub { $_[0] * $_[1] } ),
653 'reduce returns expected value'
656 throws_ok { $obj->reduce }
657 qr/Cannot call reduce without at least 1 argument/,
658 'throws an error when passing no arguments to reduce';
661 $obj->reduce( sub { }, 2 );
663 qr/Cannot call reduce with more than 1 argument/,
664 'throws an error when passing two arguments to reduce';
666 throws_ok { $obj->reduce( {} ) }
667 qr/The argument passed to reduce must be a code reference/,
668 'throws an error when passing a non coderef to reduce';
671 $obj->reduce_curried,
673 'reduce_curried returns expected value'
677 $obj->reduce_curried( sub { } );
679 qr/Cannot call reduce with more than 1 argument/,
680 'throws an error when passing one argument passed to reduce_curried';
682 $obj->_values( [ 1 .. 6 ] );
684 my $it = $obj->natatime(2);
686 while ( my @v = $it->() ) {
691 [ [ 1, 2 ], [ 3, 4 ], [ 5, 6 ] ],
693 'natatime returns expected iterator'
697 $obj->natatime( 2, sub { push @nat, [@_] } );
700 [ [ 1, 2 ], [ 3, 4 ], [ 5, 6 ] ],
702 'natatime with function returns expected value'
705 throws_ok { $obj->natatime( {} ) }
706 qr/The n value passed to natatime must be an integer/,
707 'throws an error when passing a non integer to natatime';
709 throws_ok { $obj->natatime( 2, {} ) }
710 qr/The second argument passed to natatime must be a code reference/,
711 'throws an error when passing a non code ref to natatime';
713 $it = $obj->natatime_curried();
715 while ( my @v = $it->() ) {
720 [ [ 1, 2 ], [ 3, 4 ], [ 5, 6 ] ],
722 'natatime_curried returns expected iterator'
726 $obj->natatime_curried( sub { push @nat, [@_] } );
729 [ [ 1, 2 ], [ 3, 4 ], [ 5, 6 ] ],
731 'natatime_curried with function returns expected value'
734 throws_ok { $obj->natatime_curried( {} ) }
735 qr/The second argument passed to natatime must be a code reference/,
736 'throws an error when passing a non code ref to natatime_curried';
738 if ( $class->meta->get_attribute('_values')->is_lazy ) {
739 my $obj = $class->new;
741 is( $obj->count, 2, 'count is 2 (lazy init)' );
746 [ $obj->elements ], [ 42, 84 ],
747 'elements contains default with lazy init'
755 $obj->_values, [ 42, 84, 2 ],
756 'push works with lazy init'
761 $obj->unshift( 3, 4 );
764 $obj->_values, [ 3, 4, 42, 84 ],
765 'unshift works with lazy init'