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 } ) ],
56 first_index => 'first_index',
57 first_index_curried => [ first_index => ( sub { $_ % 2 } ) ],
59 join_curried => [ join => '-' ],
63 reduce_curried => [ reduce => ( sub { $_[0] * $_[1] } ) ],
64 natatime => 'natatime',
65 natatime_curried => [ natatime => 2 ],
73 my $class = Moose::Meta::Class->create(
75 superclasses => ['Moose::Object'],
79 push @traits, 'NoInlineAttribute'
80 if delete $attr{no_inline};
82 $class->add_attribute(
86 isa => 'ArrayRef[Int]',
87 default => sub { [] },
89 clearer => '_clear_values',
94 return ( $class->name, \%handles );
102 '&{}' => sub { ${ $_[0] } },
113 q{""} => sub { ${ $_[0] } },
119 return bless \$str, $class;
124 run_tests(build_class);
125 run_tests( build_class( lazy => 1, default => sub { [ 42, 84 ] } ) );
126 run_tests( build_class( trigger => sub { } ) );
127 run_tests( build_class( no_inline => 1 ) );
129 # Will force the inlining code to check the entire arrayref when it is modified.
130 subtype 'MyArrayRef', as 'ArrayRef', where { 1 };
132 run_tests( build_class( isa => 'MyArrayRef' ) );
134 coerce 'MyArrayRef', from 'ArrayRef', via { $_ };
136 run_tests( build_class( isa => 'MyArrayRef', coerce => 1 ) );
140 my ( $class, $handles ) = @_;
142 can_ok( $class, $_ ) for sort keys %{$handles};
145 my $obj = $class->new( _values => [ 10, 12, 42 ] );
148 $obj->_values, [ 10, 12, 42 ],
149 'values can be set in constructor'
152 ok( !$obj->is_empty, 'values is not empty' );
153 is( $obj->count, 3, 'count returns 3' );
155 like( exception { $obj->count(22) }, qr/Cannot call count with any arguments/, 'throws an error when passing an argument passed to count' );
157 is( exception { $obj->push( 1, 2, 3 ) }, undef, 'pushed three new values and lived' );
159 is( exception { $obj->push() }, undef, 'call to push without arguments lives' );
162 is( $obj->unshift( 101, 22 ), 8,
163 'unshift returns size of the new array' );
164 }, undef, 'unshifted two values and lived' );
167 $obj->_values, [ 101, 22, 10, 12, 42, 1, 2, 3 ],
168 'unshift changed the value of the array in the object'
171 is( exception { $obj->unshift() }, undef, 'call to unshift without arguments lives' );
173 is( $obj->pop, 3, 'pop returns the last value in the array' );
176 $obj->_values, [ 101, 22, 10, 12, 42, 1, 2 ],
177 'pop changed the value of the array in the object'
180 like( exception { $obj->pop(42) }, qr/Cannot call pop with any arguments/, 'call to pop with arguments dies' );
182 is( $obj->shift, 101, 'shift returns the first value' );
184 like( exception { $obj->shift(42) }, qr/Cannot call shift with any arguments/, 'call to shift with arguments dies' );
187 $obj->_values, [ 22, 10, 12, 42, 1, 2 ],
188 'shift changed the value of the array in the object'
192 [ $obj->elements ], [ 22, 10, 12, 42, 1, 2 ],
193 'call to elements returns values as a list'
196 like( exception { $obj->elements(22) }, qr/Cannot call elements with any arguments/, 'throws an error when passing an argument passed to elements' );
198 $obj->_values( [ 1, 2, 3 ] );
200 is( $obj->get(0), 1, 'get values at index 0' );
201 is( $obj->get(1), 2, 'get values at index 1' );
202 is( $obj->get(2), 3, 'get values at index 2' );
203 is( $obj->get_curried, 2, 'get_curried returns value at index 1' );
205 like( exception { $obj->get() }, qr/Cannot call get without at least 1 argument/, 'throws an error when get is called without any arguments' );
207 like( exception { $obj->get( {} ) }, qr/The index passed to get must be an integer/, 'throws an error when get is called with an invalid argument' );
209 like( exception { $obj->get(2.2) }, qr/The index passed to get must be an integer/, 'throws an error when get is called with an invalid argument' );
211 like( exception { $obj->get('foo') }, qr/The index passed to get must be an integer/, 'throws an error when get is called with an invalid argument' );
213 like( exception { $obj->get_curried(2) }, qr/Cannot call get with more than 1 argument/, 'throws an error when get_curried is called with an argument' );
216 is( $obj->set( 1, 100 ), 100, 'set returns new value' );
217 }, undef, 'set value at index 1 lives' );
219 is( $obj->get(1), 100, 'get value at index 1 returns new value' );
222 like( exception { $obj->set( 1, 99, 42 ) }, qr/Cannot call set with more than 2 arguments/, 'throws an error when set is called with three arguments' );
224 is( exception { $obj->set_curried_1(99) }, undef, 'set_curried_1 lives' );
226 is( $obj->get(1), 99, 'get value at index 1 returns new value' );
228 like( exception { $obj->set_curried_1( 99, 42 ) }, qr/Cannot call set with more than 2 arguments/, 'throws an error when set_curried_1 is called with two arguments' );
230 is( exception { $obj->set_curried_2 }, undef, 'set_curried_2 lives' );
232 is( $obj->get(1), 98, 'get value at index 1 returns new value' );
234 like( exception { $obj->set_curried_2(42) }, qr/Cannot call set with more than 2 arguments/, 'throws an error when set_curried_2 is called with one argument' );
237 $obj->accessor(1), 98,
238 'accessor with one argument returns value at index 1'
242 is( $obj->accessor( 1 => 97 ), 97, 'accessor returns new value' );
243 }, undef, 'accessor as writer lives' );
249 qr/Cannot call accessor without at least 1 argument/,
250 'throws an error when accessor is called without arguments'
255 'accessor set value at index 1'
258 like( exception { $obj->accessor( 1, 96, 42 ) }, qr/Cannot call accessor with more than 2 arguments/, 'throws an error when accessor is called with three arguments' );
261 $obj->accessor_curried_1, 97,
262 'accessor_curried_1 returns expected value when called with no arguments'
265 is( exception { $obj->accessor_curried_1(95) }, undef, 'accessor_curried_1 as writer lives' );
269 'accessor_curried_1 set value at index 1'
272 like( exception { $obj->accessor_curried_1( 96, 42 ) }, qr/Cannot call accessor with more than 2 arguments/, 'throws an error when accessor_curried_1 is called with two arguments' );
274 is( exception { $obj->accessor_curried_2 }, undef, 'accessor_curried_2 as writer lives' );
278 'accessor_curried_2 set value at index 1'
281 like( exception { $obj->accessor_curried_2(42) }, qr/Cannot call accessor with more than 2 arguments/, 'throws an error when accessor_curried_2 is called with one argument' );
283 is( exception { $obj->clear }, undef, 'clear lives' );
285 ok( $obj->is_empty, 'values is empty after call to clear' );
288 is( $obj->shift, undef,
289 'shift returns undef on an empty array' );
290 }, undef, 'shifted from an empty array and lived' );
292 $obj->set( 0 => 42 );
294 like( exception { $obj->clear(50) }, qr/Cannot call clear with any arguments/, 'throws an error when clear is called with an argument' );
298 'values is not empty after failed call to clear'
301 like( exception { $obj->is_empty(50) }, qr/Cannot call is_empty with any arguments/, 'throws an error when is_empty is called with an argument' );
305 $obj->push( 1, 5, 10, 42 ), 4,
306 'pushed 4 elements, got number of elements in the array back'
310 is( $obj->delete(2), 10, 'delete returns deleted value' );
311 }, undef, 'delete lives' );
314 $obj->_values, [ 1, 5, 42 ],
315 'delete removed the specified element'
318 like( exception { $obj->delete( 2, 3 ) }, qr/Cannot call delete with more than 1 argument/, 'throws an error when delete is called with two arguments' );
320 is( exception { $obj->delete_curried }, undef, 'delete_curried lives' );
323 $obj->_values, [ 1, 42 ],
324 'delete removed the specified element'
327 like( exception { $obj->delete_curried(2) }, qr/Cannot call delete with more than 1 argument/, 'throws an error when delete_curried is called with one argument' );
329 is( exception { $obj->insert( 1, 21 ) }, undef, 'insert lives' );
332 $obj->_values, [ 1, 21, 42 ],
333 'insert added the specified element'
336 like( exception { $obj->insert( 1, 22, 44 ) }, qr/Cannot call insert with more than 2 arguments/, 'throws an error when insert is called with three arguments' );
340 [ $obj->splice( 1, 0, 2, 3 ) ],
342 'return value of splice is empty list when not removing elements'
344 }, undef, 'splice lives' );
347 $obj->_values, [ 1, 2, 3, 21, 42 ],
348 'splice added the specified elements'
353 [ $obj->splice( 1, 2, 99 ) ],
355 'splice returns list of removed values'
357 }, undef, 'splice lives' );
360 $obj->_values, [ 1, 99, 21, 42 ],
361 'splice added the specified elements'
364 like( exception { $obj->splice() }, qr/Cannot call splice without at least 1 argument/, 'throws an error when splice is called with no arguments' );
366 like( exception { $obj->splice( 1, 'foo', ) }, qr/The length argument passed to splice must be an integer/, 'throws an error when splice is called with an invalid length' );
368 is( exception { $obj->splice_curried_1( 2, 101 ) }, undef, 'splice_curried_1 lives' );
371 $obj->_values, [ 1, 101, 42 ],
372 'splice added the specified elements'
375 is( exception { $obj->splice_curried_2(102) }, undef, 'splice_curried_2 lives' );
378 $obj->_values, [ 1, 102 ],
379 'splice added the specified elements'
382 is( exception { $obj->splice_curried_all }, undef, 'splice_curried_all lives' );
385 $obj->_values, [ 1, 3, 4, 5 ],
386 'splice added the specified elements'
390 scalar $obj->splice( 1, 2 ),
392 'splice in scalar context returns last element removed'
396 scalar $obj->splice( 1, 0, 42 ),
398 'splice in scalar context returns undef when no elements are removed'
401 $obj->_values( [ 3, 9, 5, 22, 11 ] );
404 [ $obj->sort ], [ 11, 22, 3, 5, 9 ],
405 'sort returns sorted values'
409 [ $obj->sort( sub { $_[0] <=> $_[1] } ) ], [ 3, 5, 9, 11, 22 ],
410 'sort returns values sorted by provided function'
413 like( exception { $obj->sort(1) }, qr/The argument passed to sort must be a code reference/, 'throws an error when passing a non coderef to sort' );
416 $obj->sort( sub { }, 27 );
417 }, qr/Cannot call sort with more than 1 argument/, 'throws an error when passing two arguments to sort' );
419 $obj->_values( [ 3, 9, 5, 22, 11 ] );
424 $obj->_values, [ 11, 22, 3, 5, 9 ],
425 'sort_in_place sorts values'
428 $obj->sort_in_place( sub { $_[0] <=> $_[1] } );
431 $obj->_values, [ 3, 5, 9, 11, 22 ],
432 'sort_in_place with function sorts values'
436 $obj->sort_in_place( 27 );
437 }, qr/The argument passed to sort_in_place must be a code reference/, 'throws an error when passing a non coderef to sort_in_place' );
440 $obj->sort_in_place( sub { }, 27 );
441 }, qr/Cannot call sort_in_place with more than 1 argument/, 'throws an error when passing two arguments to sort_in_place' );
443 $obj->_values( [ 3, 9, 5, 22, 11 ] );
445 $obj->sort_in_place_curried;
448 $obj->_values, [ 22, 11, 9, 5, 3 ],
449 'sort_in_place_curried sorts values'
452 like( exception { $obj->sort_in_place_curried(27) }, qr/Cannot call sort_in_place with more than 1 argument/, 'throws an error when passing one argument passed to sort_in_place_curried' );
454 $obj->_values( [ 1 .. 5 ] );
457 [ $obj->map( sub { $_ + 1 } ) ],
459 'map returns the expected values'
462 like( exception { $obj->map }, qr/Cannot call map without at least 1 argument/, 'throws an error when passing no arguments to map' );
465 $obj->map( sub { }, 2 );
466 }, qr/Cannot call map with more than 1 argument/, 'throws an error when passing two arguments to map' );
468 like( exception { $obj->map( {} ) }, qr/The argument passed to map must be a code reference/, 'throws an error when passing a non coderef to map' );
470 $obj->_values( [ 1 .. 5 ] );
473 [ $obj->map_curried ],
475 'map_curried returns the expected values'
479 $obj->map_curried( sub { } );
480 }, qr/Cannot call map with more than 1 argument/, 'throws an error when passing one argument passed to map_curried' );
482 $obj->_values( [ 2 .. 9 ] );
485 [ $obj->grep( sub { $_ < 5 } ) ],
487 'grep returns the expected values'
490 like( exception { $obj->grep }, qr/Cannot call grep without at least 1 argument/, 'throws an error when passing no arguments to grep' );
493 $obj->grep( sub { }, 2 );
494 }, qr/Cannot call grep with more than 1 argument/, 'throws an error when passing two arguments to grep' );
496 like( exception { $obj->grep( {} ) }, qr/The argument passed to grep must be a code reference/, 'throws an error when passing a non coderef to grep' );
498 my $overloader = Overloader->new( sub { $_ < 5 } );
500 [ $obj->grep($overloader) ],
502 'grep works with obj that overload code dereferencing'
506 [ $obj->grep_curried ],
508 'grep_curried returns the expected values'
512 $obj->grep_curried( sub { } );
513 }, qr/Cannot call grep with more than 1 argument/, 'throws an error when passing one argument passed to grep_curried' );
515 $obj->_values( [ 2, 4, 22, 99, 101, 6 ] );
518 $obj->first( sub { $_ % 2 } ),
520 'first returns expected value'
523 like( exception { $obj->first }, qr/Cannot call first without at least 1 argument/, 'throws an error when passing no arguments to first' );
526 $obj->first( sub { }, 2 );
527 }, qr/Cannot call first with more than 1 argument/, 'throws an error when passing two arguments to first' );
529 like( exception { $obj->first( {} ) }, qr/The argument passed to first must be a code reference/, 'throws an error when passing a non coderef to first' );
534 'first_curried returns expected value'
538 $obj->first_curried( sub { } );
539 }, qr/Cannot call first with more than 1 argument/, 'throws an error when passing one argument passed to first_curried' );
543 $obj->first_index( sub { $_ % 2 } ),
545 'first_index returns expected value'
548 like( exception { $obj->first_index }, qr/Cannot call first_index without at least 1 argument/, 'throws an error when passing no arguments to first_index' );
551 $obj->first_index( sub { }, 2 );
552 }, qr/Cannot call first_index with more than 1 argument/, 'throws an error when passing two arguments to first_index' );
554 like( exception { $obj->first_index( {} ) }, qr/The argument passed to first_index must be a code reference/, 'throws an error when passing a non coderef to first_index' );
557 $obj->first_index_curried,
559 'first_index_curried returns expected value'
563 $obj->first_index_curried( sub { } );
564 }, qr/Cannot call first_index with more than 1 argument/, 'throws an error when passing one argument passed to first_index_curried' );
567 $obj->_values( [ 1 .. 4 ] );
570 $obj->join('-'), '1-2-3-4',
571 'join returns expected result'
575 $obj->join(q{}), '1234',
576 'join returns expected result when joining with empty string'
580 $obj->join( OverloadStr->new(q{}) ), '1234',
581 'join returns expected result when joining with empty string'
584 like( exception { $obj->join }, qr/Cannot call join without at least 1 argument/, 'throws an error when passing no arguments to join' );
586 like( exception { $obj->join( '-', 2 ) }, qr/Cannot call join with more than 1 argument/, 'throws an error when passing two arguments to join' );
588 like( exception { $obj->join( {} ) }, qr/The argument passed to join must be a string/, 'throws an error when passing a non string to join' );
591 [ sort $obj->shuffle ],
593 'shuffle returns all values (cannot check for a random order)'
596 like( exception { $obj->shuffle(2) }, qr/Cannot call shuffle with any arguments/, 'throws an error when passing an argument passed to shuffle' );
598 $obj->_values( [ 1 .. 4, 2, 5, 3, 7, 3, 3, 1 ] );
603 'uniq returns expected values (in original order)'
606 like( exception { $obj->uniq(2) }, qr/Cannot call uniq with any arguments/, 'throws an error when passing an argument passed to uniq' );
608 $obj->_values( [ 1 .. 5 ] );
611 $obj->reduce( sub { $_[0] * $_[1] } ),
613 'reduce returns expected value'
616 like( exception { $obj->reduce }, qr/Cannot call reduce without at least 1 argument/, 'throws an error when passing no arguments to reduce' );
619 $obj->reduce( sub { }, 2 );
620 }, qr/Cannot call reduce with more than 1 argument/, 'throws an error when passing two arguments to reduce' );
622 like( exception { $obj->reduce( {} ) }, qr/The argument passed to reduce must be a code reference/, 'throws an error when passing a non coderef to reduce' );
625 $obj->reduce_curried,
627 'reduce_curried returns expected value'
631 $obj->reduce_curried( sub { } );
632 }, qr/Cannot call reduce with more than 1 argument/, 'throws an error when passing one argument passed to reduce_curried' );
634 $obj->_values( [ 1 .. 6 ] );
636 my $it = $obj->natatime(2);
638 while ( my @v = $it->() ) {
643 [ [ 1, 2 ], [ 3, 4 ], [ 5, 6 ] ],
645 'natatime returns expected iterator'
649 $obj->natatime( 2, sub { push @nat, [@_] } );
652 [ [ 1, 2 ], [ 3, 4 ], [ 5, 6 ] ],
654 'natatime with function returns expected value'
657 like( exception { $obj->natatime( {} ) }, qr/The n value passed to natatime must be an integer/, 'throws an error when passing a non integer to natatime' );
659 like( exception { $obj->natatime( 2, {} ) }, qr/The second argument passed to natatime must be a code reference/, 'throws an error when passing a non code ref to natatime' );
661 $it = $obj->natatime_curried();
663 while ( my @v = $it->() ) {
668 [ [ 1, 2 ], [ 3, 4 ], [ 5, 6 ] ],
670 'natatime_curried returns expected iterator'
674 $obj->natatime_curried( sub { push @nat, [@_] } );
677 [ [ 1, 2 ], [ 3, 4 ], [ 5, 6 ] ],
679 'natatime_curried with function returns expected value'
682 like( exception { $obj->natatime_curried( {} ) }, qr/The second argument passed to natatime must be a code reference/, 'throws an error when passing a non code ref to natatime_curried' );
684 if ( $class->meta->get_attribute('_values')->is_lazy ) {
685 my $obj = $class->new;
687 is( $obj->count, 2, 'count is 2 (lazy init)' );
692 [ $obj->elements ], [ 42, 84 ],
693 'elements contains default with lazy init'
701 $obj->_values, [ 42, 84, 2 ],
702 'push works with lazy init'
707 $obj->unshift( 3, 4 );
710 $obj->_values, [ 3, 4, 42, 84 ],
711 'unshift works with lazy init'
719 my ( $class, $handles ) = build_class( isa => 'ArrayRef' );
720 my $obj = $class->new;
723 exception { $obj->accessor( 0, undef ) },
725 'can use accessor to set value to undef'
728 exception { $obj->accessor_curried_1(undef) },
730 'can use curried accessor to set value to undef'