t/070_native_traits/010_trait_array.t

   1 #!/usr/bin/perl
   2
   3 use strict;
   4 use warnings;
   5
   6 use Moose ();
   7 use Moose::Util::TypeConstraints;
   8 use Test::More;
   9 use Test::Exception;
  10 use Test::Moose;
  11
  12 {
  13     my %handles = (
  14         count    => 'count',
  15         elements => 'elements',
  16         is_empty => 'is_empty',
  17         push     => 'push',
  18         push_curried =>
  19             [ push => 42, 84 ],
  20         unshift => 'unshift',
  21         unshift_curried =>
  22             [ unshift => 42, 84 ],
  23         pop           => 'pop',
  24         shift         => 'shift',
  25         get           => 'get',
  26         get_curried   => [ get => 1 ],
  27         set           => 'set',
  28         set_curried_1 => [ set => 1 ],
  29         set_curried_2 => [ set => ( 1, 98 ) ],
  30         accessor      => 'accessor',
  31         accessor_curried_1 => [ accessor => 1 ],
  32         accessor_curried_2 => [ accessor => ( 1, 90 ) ],
  33         clear          => 'clear',
  34         delete         => 'delete',
  35         delete_curried => [ delete => 1 ],
  36         insert         => 'insert',
  37         insert_curried => [ insert => ( 1, 101 ) ],
  38         splice         => 'splice',
  39         splice_curried_1   => [ splice => 1 ],
  40         splice_curried_2   => [ splice => 1, 2 ],
  41         splice_curried_all => [ splice => 1, 2, ( 3, 4, 5 ) ],
  42         sort          => 'sort',
  43         sort_curried  => [ sort => ( sub { $_[1] <=> $_[0] } ) ],
  44         sort_in_place => 'sort_in_place',
  45         sort_in_place_curried =>
  46             [ sort_in_place => ( sub { $_[1] <=> $_[0] } ) ],
  47         map           => 'map',
  48         map_curried   => [ map => ( sub { $_ + 1 } ) ],
  49         grep          => 'grep',
  50         grep_curried  => [ grep => ( sub { $_ < 5 } ) ],
  51         first         => 'first',
  52         first_curried => [ first => ( sub { $_ % 2 } ) ],
  53         join          => 'join',
  54         join_curried => [ join => '-' ],
  55         shuffle      => 'shuffle',
  56         uniq         => 'uniq',
  57         reduce       => 'reduce',
  58         reduce_curried => [ reduce => ( sub { $_[0] * $_[1] } ) ],
  59         natatime       => 'natatime',
  60         natatime_curried => [ natatime => 2 ],
  61     );
  62
  63     my $name = 'Foo1';
  64
  65     sub build_class {
  66         my %attr = @_;
  67
  68         my $class = Moose::Meta::Class->create(
  69             $name++,
  70             superclasses => ['Moose::Object'],
  71         );
  72
  73         $class->add_attribute(
  74             _values => (
  75                 traits  => ['Array'],
  76                 is      => 'rw',
  77                 isa     => 'ArrayRef[Int]',
  78                 default => sub { [] },
  79                 handles => \%handles,
  80                 clearer => '_clear_values',
  81                 %attr,
  82             ),
  83         );
  84
  85         return ( $class->name, \%handles );
  86     }
  87 }
  88
  89 {
  90     run_tests(build_class);
  91     run_tests( build_class( lazy => 1, default => sub { [ 42, 84 ] } ) );
  92
  93     # Will force the inlining code to check the entire arrayref when it is modified.
  94     subtype 'MyArrayRef', as 'ArrayRef', where { 1 };
  95
  96     run_tests( build_class( isa => 'MyArrayRef' ) );
  97
  98     coerce 'MyArrayRef', from 'ArrayRef', via { $_ };
  99
 100     run_tests( build_class( isa => 'MyArrayRef', coerce => 1 ) );
 101 }
 102
 103 sub run_tests {
 104     my ( $class, $handles ) = @_;
 105
 106     can_ok( $class, $_ ) for sort keys %{$handles};
 107
 108     with_immutable {
 109         my $obj = $class->new( _values => [ 10, 12, 42 ] );
 110
 111         is_deeply(
 112             $obj->_values, [ 10, 12, 42 ],
 113             'values can be set in constructor'
 114         );
 115
 116         ok( !$obj->is_empty, 'values is not empty' );
 117         is( $obj->count, 3, 'count returns 3' );
 118
 119         throws_ok { $obj->count(22) }
 120         qr/Cannot call count with any arguments/,
 121             'throws an error when passing an argument passed to count';
 122
 123         lives_ok { $obj->push( 1, 2, 3 ) }
 124         'pushed three new values and lived';
 125
 126         lives_ok { $obj->push() } 'call to push without arguments lives';
 127
 128         lives_ok { $obj->unshift( 101, 22 ) }
 129         'unshifted two values and lived';
 130
 131         is_deeply(
 132             $obj->_values, [ 101, 22, 10, 12, 42, 1, 2, 3 ],
 133             'unshift changed the value of the array in the object'
 134         );
 135
 136         lives_ok { $obj->unshift() }
 137         'call to unshift without arguments lives';
 138
 139         is( $obj->pop, 3, 'pop returns the last value in the array' );
 140
 141         is_deeply(
 142             $obj->_values, [ 101, 22, 10, 12, 42, 1, 2 ],
 143             'pop changed the value of the array in the object'
 144         );
 145
 146         throws_ok { $obj->pop(42) }
 147         qr/Cannot call pop with any arguments/,
 148             'call to pop with arguments dies';
 149
 150         is( $obj->shift, 101, 'shift returns the first value' );
 151
 152         throws_ok { $obj->shift(42) }
 153         qr/Cannot call shift with any arguments/,
 154             'call to shift with arguments dies';
 155
 156         is_deeply(
 157             $obj->_values, [ 22, 10, 12, 42, 1, 2 ],
 158             'shift changed the value of the array in the object'
 159         );
 160
 161         is_deeply(
 162             [ $obj->elements ], [ 22, 10, 12, 42, 1, 2 ],
 163             'call to elements returns values as a list'
 164         );
 165
 166         throws_ok { $obj->elements(22) }
 167         qr/Cannot call elements with any arguments/,
 168             'throws an error when passing an argument passed to elements';
 169
 170         $obj->_values( [ 1, 2, 3 ] );
 171
 172         is( $obj->get(0),      1, 'get values at index 0' );
 173         is( $obj->get(1),      2, 'get values at index 1' );
 174         is( $obj->get(2),      3, 'get values at index 2' );
 175         is( $obj->get_curried, 2, 'get_curried returns value at index 1' );
 176
 177         throws_ok { $obj->get() }
 178         qr/Cannot call get without at least 1 argument/,
 179             'throws an error when get is called without any arguments';
 180
 181         throws_ok { $obj->get( {} ) }
 182         qr/The index passed to get must be an integer/,
 183             'throws an error when get is called with an invalid argument';
 184
 185         throws_ok { $obj->get(2.2) }
 186         qr/The index passed to get must be an integer/,
 187             'throws an error when get is called with an invalid argument';
 188
 189         throws_ok { $obj->get('foo') }
 190         qr/The index passed to get must be an integer/,
 191             'throws an error when get is called with an invalid argument';
 192
 193         throws_ok { $obj->get_curried(2) }
 194         qr/Cannot call get with more than 1 argument/,
 195             'throws an error when get_curried is called with an argument';
 196
 197         lives_ok { $obj->set( 1, 100 ) } 'set value at index 1 lives';
 198
 199         is( $obj->get(1), 100, 'get value at index 1 returns new value' );
 200
 201         throws_ok { $obj->set( 1, 99, 42 ) }
 202         qr/Cannot call set with more than 2 arguments/,
 203             'throws an error when set is called with three arguments';
 204
 205         lives_ok { $obj->set_curried_1(99) } 'set_curried_1 lives';
 206
 207         is( $obj->get(1), 99, 'get value at index 1 returns new value' );
 208
 209         throws_ok { $obj->set_curried_1( 99, 42 ) }
 210         qr/Cannot call set with more than 2 arguments/,
 211             'throws an error when set_curried_1 is called with two arguments';
 212
 213         lives_ok { $obj->set_curried_2 } 'set_curried_2 lives';
 214
 215         is( $obj->get(1), 98, 'get value at index 1 returns new value' );
 216
 217         throws_ok { $obj->set_curried_2(42) }
 218         qr/Cannot call set with more than 2 arguments/,
 219             'throws an error when set_curried_2 is called with one argument';
 220
 221         is(
 222             $obj->accessor(1), 98,
 223             'accessor with one argument returns value at index 1'
 224         );
 225
 226         lives_ok { $obj->accessor( 1 => 97 ) } 'accessor as writer lives';
 227
 228         is(
 229             $obj->get(1), 97,
 230             'accessor set value at index 1'
 231         );
 232
 233         throws_ok { $obj->accessor( 1, 96, 42 ) }
 234         qr/Cannot call accessor with more than 2 arguments/,
 235             'throws an error when accessor is called with three arguments';
 236
 237         is(
 238             $obj->accessor_curried_1, 97,
 239             'accessor_curried_1 returns expected value when called with no arguments'
 240         );
 241
 242         lives_ok { $obj->accessor_curried_1(95) }
 243         'accessor_curried_1 as writer lives';
 244
 245         is(
 246             $obj->get(1), 95,
 247             'accessor_curried_1 set value at index 1'
 248         );
 249
 250         throws_ok { $obj->accessor_curried_1( 96, 42 ) }
 251         qr/Cannot call accessor with more than 2 arguments/,
 252             'throws an error when accessor_curried_1 is called with two arguments';
 253
 254         lives_ok { $obj->accessor_curried_2 }
 255         'accessor_curried_2 as writer lives';
 256
 257         is(
 258             $obj->get(1), 90,
 259             'accessor_curried_2 set value at index 1'
 260         );
 261
 262         throws_ok { $obj->accessor_curried_2(42) }
 263         qr/Cannot call accessor with more than 2 arguments/,
 264             'throws an error when accessor_curried_2 is called with one argument';
 265
 266         lives_ok { $obj->clear } 'clear lives';
 267
 268         ok( $obj->is_empty, 'values is empty after call to clear' );
 269
 270         $obj->set( 0 => 42 );
 271
 272         throws_ok { $obj->clear(50) }
 273         qr/Cannot call clear with any arguments/,
 274             'throws an error when clear is called with an argument';
 275
 276         ok(
 277             !$obj->is_empty,
 278             'values is not empty after failed call to clear'
 279         );
 280
 281         $obj->clear;
 282         $obj->push( 1, 5, 10, 42 );
 283
 284         lives_ok { $obj->delete(2) } 'delete lives';
 285
 286         is_deeply(
 287             $obj->_values, [ 1, 5, 42 ],
 288             'delete removed the specified element'
 289         );
 290
 291         throws_ok { $obj->delete( 2, 3 ) }
 292         qr/Cannot call delete with more than 1 argument/,
 293             'throws an error when delete is called with two arguments';
 294
 295         lives_ok { $obj->delete_curried } 'delete_curried lives';
 296
 297         is_deeply(
 298             $obj->_values, [ 1, 42 ],
 299             'delete removed the specified element'
 300         );
 301
 302         throws_ok { $obj->delete_curried(2) }
 303         qr/Cannot call delete with more than 1 argument/,
 304             'throws an error when delete_curried is called with one argument';
 305
 306         lives_ok { $obj->insert( 1, 21 ) } 'insert lives';
 307
 308         is_deeply(
 309             $obj->_values, [ 1, 21, 42 ],
 310             'insert added the specified element'
 311         );
 312
 313         throws_ok { $obj->insert( 1, 22, 44 ) }
 314         qr/Cannot call insert with more than 2 arguments/,
 315             'throws an error when insert is called with three arguments';
 316
 317         lives_ok { $obj->splice( 1, 0, 2, 3 ) } 'splice lives';
 318
 319         is_deeply(
 320             $obj->_values, [ 1, 2, 3, 21, 42 ],
 321             'splice added the specified elements'
 322         );
 323
 324         lives_ok { $obj->splice( 1, 1, 99 ) } 'splice lives';
 325
 326         is_deeply(
 327             $obj->_values, [ 1, 99, 3, 21, 42 ],
 328             'splice added the specified elements'
 329         );
 330
 331         throws_ok { $obj->splice() }
 332         qr/Cannot call splice without at least 1 argument/,
 333             'throws an error when splice is called with no arguments';
 334
 335         throws_ok { $obj->splice( 1, 'foo', ) }
 336         qr/The length argument passed to splice must be an integer/,
 337             'throws an error when splice is called with an invalid length';
 338
 339         lives_ok { $obj->splice_curried_1( 2, 101 ) }
 340         'splice_curried_1 lives';
 341
 342         is_deeply(
 343             $obj->_values, [ 1, 101, 21, 42 ],
 344             'splice added the specified elements'
 345         );
 346
 347         lives_ok { $obj->splice_curried_2(102) } 'splice_curried_2 lives';
 348
 349         is_deeply(
 350             $obj->_values, [ 1, 102, 42 ],
 351             'splice added the specified elements'
 352         );
 353
 354         lives_ok { $obj->splice_curried_all } 'splice_curried_all lives';
 355
 356         is_deeply(
 357             $obj->_values, [ 1, 3, 4, 5 ],
 358             'splice added the specified elements'
 359         );
 360
 361         $obj->_values( [ 3, 9, 5, 22, 11 ] );
 362
 363         is_deeply(
 364             [ $obj->sort ], [ 11, 22, 3, 5, 9 ],
 365             'sort returns sorted values'
 366         );
 367
 368         is_deeply(
 369             [ $obj->sort( sub { $_[0] <=> $_[1] } ) ], [ 3, 5, 9, 11, 22 ],
 370             'sort returns values sorted by provided function'
 371         );
 372
 373         throws_ok { $obj->sort(1) }
 374         qr/The argument passed to sort must be a code reference/,
 375             'throws an error when passing a non coderef to sort';
 376
 377         throws_ok {
 378             $obj->sort( sub { }, 27 );
 379         }
 380         qr/Cannot call sort with more than 1 argument/,
 381             'throws an error when passing two arguments to sort';
 382
 383         $obj->_values( [ 3, 9, 5, 22, 11 ] );
 384
 385         $obj->sort_in_place;
 386
 387         is_deeply(
 388             $obj->_values, [ 11, 22, 3, 5, 9 ],
 389             'sort_in_place sorts values'
 390         );
 391
 392         $obj->sort_in_place( sub { $_[0] <=> $_[1] } );
 393
 394         is_deeply(
 395             $obj->_values, [ 3, 5, 9, 11, 22 ],
 396             'sort_in_place with function sorts values'
 397         );
 398
 399         throws_ok {
 400             $obj->sort_in_place( 27 );
 401         }
 402         qr/The argument passed to sort_in_place must be a code reference/,
 403             'throws an error when passing a non coderef to sort_in_place';
 404
 405         throws_ok {
 406             $obj->sort_in_place( sub { }, 27 );
 407         }
 408         qr/Cannot call sort_in_place with more than 1 argument/,
 409             'throws an error when passing two arguments to sort_in_place';
 410
 411         $obj->_values( [ 3, 9, 5, 22, 11 ] );
 412
 413         $obj->sort_in_place_curried;
 414
 415         is_deeply(
 416             $obj->_values, [ 22, 11, 9, 5, 3 ],
 417             'sort_in_place_curried sorts values'
 418         );
 419
 420         throws_ok { $obj->sort_in_place_curried(27) }
 421         qr/Cannot call sort_in_place with more than 1 argument/,
 422             'throws an error when passing one argument passed to sort_in_place_curried';
 423
 424         $obj->_values( [ 1 .. 5 ] );
 425
 426         is_deeply(
 427             [ $obj->map( sub { $_ + 1 } ) ],
 428             [ 2 .. 6 ],
 429             'map returns the expected values'
 430         );
 431
 432         throws_ok { $obj->map }
 433         qr/Cannot call map without at least 1 argument/,
 434             'throws an error when passing no arguments to map';
 435
 436         throws_ok {
 437             $obj->map( sub { }, 2 );
 438         }
 439         qr/Cannot call map with more than 1 argument/,
 440             'throws an error when passing two arguments to map';
 441
 442         throws_ok { $obj->map( {} ) }
 443         qr/The argument passed to map must be a code reference/,
 444             'throws an error when passing a non coderef to map';
 445
 446         $obj->_values( [ 1 .. 5 ] );
 447
 448         is_deeply(
 449             [ $obj->map_curried ],
 450             [ 2 .. 6 ],
 451             'map_curried returns the expected values'
 452         );
 453
 454         throws_ok {
 455             $obj->map_curried( sub { } );
 456         }
 457         qr/Cannot call map with more than 1 argument/,
 458             'throws an error when passing one argument passed to map_curried';
 459
 460         $obj->_values( [ 2 .. 9 ] );
 461
 462         is_deeply(
 463             [ $obj->grep( sub { $_ < 5 } ) ],
 464             [ 2 .. 4 ],
 465             'grep returns the expected values'
 466         );
 467
 468         throws_ok { $obj->grep }
 469         qr/Cannot call grep without at least 1 argument/,
 470             'throws an error when passing no arguments to grep';
 471
 472         throws_ok {
 473             $obj->grep( sub { }, 2 );
 474         }
 475         qr/Cannot call grep with more than 1 argument/,
 476             'throws an error when passing two arguments to grep';
 477
 478         throws_ok { $obj->grep( {} ) }
 479         qr/The argument passed to grep must be a code reference/,
 480             'throws an error when passing a non coderef to grep';
 481
 482         is_deeply(
 483             [ $obj->grep_curried ],
 484             [ 2 .. 4 ],
 485             'grep_curried returns the expected values'
 486         );
 487
 488         throws_ok {
 489             $obj->grep_curried( sub { } );
 490         }
 491         qr/Cannot call grep with more than 1 argument/,
 492             'throws an error when passing one argument passed to grep_curried';
 493
 494         $obj->_values( [ 2, 4, 22, 99, 101, 6 ] );
 495
 496         is(
 497             $obj->first( sub { $_ % 2 } ),
 498             99,
 499             'first returns expected value'
 500         );
 501
 502         throws_ok { $obj->first }
 503         qr/Cannot call first without at least 1 argument/,
 504             'throws an error when passing no arguments to first';
 505
 506         throws_ok {
 507             $obj->first( sub { }, 2 );
 508         }
 509         qr/Cannot call first with more than 1 argument/,
 510             'throws an error when passing two arguments to first';
 511
 512         throws_ok { $obj->first( {} ) }
 513         qr/The argument passed to first must be a code reference/,
 514             'throws an error when passing a non coderef to first';
 515
 516         is(
 517             $obj->first_curried,
 518             99,
 519             'first_curried returns expected value'
 520         );
 521
 522         throws_ok {
 523             $obj->first_curried( sub { } );
 524         }
 525         qr/Cannot call first with more than 1 argument/,
 526             'throws an error when passing one argument passed to first_curried';
 527
 528         $obj->_values( [ 1 .. 4 ] );
 529
 530         is(
 531             $obj->join('-'), '1-2-3-4',
 532             'join returns expected result'
 533         );
 534
 535         throws_ok { $obj->join }
 536         qr/Cannot call join without at least 1 argument/,
 537             'throws an error when passing no arguments to join';
 538
 539         throws_ok { $obj->join( '-', 2 ) }
 540         qr/Cannot call join with more than 1 argument/,
 541             'throws an error when passing two arguments to join';
 542
 543         throws_ok { $obj->join( {} ) }
 544         qr/The argument passed to join must be a string/,
 545             'throws an error when passing a non string to join';
 546
 547         is_deeply(
 548             [ sort $obj->shuffle ],
 549             [ 1 .. 4 ],
 550             'shuffle returns all values (cannot check for a random order)'
 551         );
 552
 553         throws_ok { $obj->shuffle(2) }
 554         qr/Cannot call shuffle with any arguments/,
 555             'throws an error when passing an argument passed to shuffle';
 556
 557         $obj->_values( [ 1 .. 4, 2, 5, 3, 7, 3, 3, 1 ] );
 558
 559         is_deeply(
 560             [ $obj->uniq ],
 561             [ 1 .. 4, 5, 7 ],
 562             'uniq returns expected values (in original order)'
 563         );
 564
 565         throws_ok { $obj->uniq(2) }
 566         qr/Cannot call uniq with any arguments/,
 567             'throws an error when passing an argument passed to uniq';
 568
 569         $obj->_values( [ 1 .. 5 ] );
 570
 571         is(
 572             $obj->reduce( sub { $_[0] * $_[1] } ),
 573             120,
 574             'reduce returns expected value'
 575         );
 576
 577         throws_ok { $obj->reduce }
 578         qr/Cannot call reduce without at least 1 argument/,
 579             'throws an error when passing no arguments to reduce';
 580
 581         throws_ok {
 582             $obj->reduce( sub { }, 2 );
 583         }
 584         qr/Cannot call reduce with more than 1 argument/,
 585             'throws an error when passing two arguments to reduce';
 586
 587         throws_ok { $obj->reduce( {} ) }
 588         qr/The argument passed to reduce must be a code reference/,
 589             'throws an error when passing a non coderef to reduce';
 590
 591         is(
 592             $obj->reduce_curried,
 593             120,
 594             'reduce_curried returns expected value'
 595         );
 596
 597         throws_ok {
 598             $obj->reduce_curried( sub { } );
 599         }
 600         qr/Cannot call reduce with more than 1 argument/,
 601             'throws an error when passing one argument passed to reduce_curried';
 602
 603         $obj->_values( [ 1 .. 6 ] );
 604
 605         my $it = $obj->natatime(2);
 606         my @nat;
 607         while ( my @v = $it->() ) {
 608             push @nat, \@v;
 609         }
 610
 611         is_deeply(
 612             [ [ 1, 2 ], [ 3, 4 ], [ 5, 6 ] ],
 613             \@nat,
 614             'natatime returns expected iterator'
 615         );
 616
 617         @nat = ();
 618         $obj->natatime( 2, sub { push @nat, [@_] } );
 619
 620         is_deeply(
 621             [ [ 1, 2 ], [ 3, 4 ], [ 5, 6 ] ],
 622             \@nat,
 623             'natatime with function returns expected value'
 624         );
 625
 626         throws_ok { $obj->natatime( {} ) }
 627         qr/The n value passed to natatime must be an integer/,
 628             'throws an error when passing a non integer to natatime';
 629
 630         throws_ok { $obj->natatime( 2, {} ) }
 631         qr/The second argument passed to natatime must be a code reference/,
 632             'throws an error when passing a non code ref to natatime';
 633
 634         $it = $obj->natatime_curried();
 635         @nat = ();
 636         while ( my @v = $it->() ) {
 637             push @nat, \@v;
 638         }
 639
 640         is_deeply(
 641             [ [ 1, 2 ], [ 3, 4 ], [ 5, 6 ] ],
 642             \@nat,
 643             'natatime_curried returns expected iterator'
 644         );
 645
 646         @nat = ();
 647         $obj->natatime_curried( sub { push @nat, [@_] } );
 648
 649         is_deeply(
 650             [ [ 1, 2 ], [ 3, 4 ], [ 5, 6 ] ],
 651             \@nat,
 652             'natatime_curried with function returns expected value'
 653         );
 654
 655         throws_ok { $obj->natatime_curried( {} ) }
 656         qr/The second argument passed to natatime must be a code reference/,
 657             'throws an error when passing a non code ref to natatime_curried';
 658
 659         if ( $class->meta->get_attribute('_values')->is_lazy ) {
 660             my $obj = $class->new;
 661
 662             is( $obj->count, 2, 'count is 2 (lazy init)' );
 663
 664             $obj->_clear_values;
 665
 666             is_deeply(
 667                 [ $obj->elements ], [ 42, 84 ],
 668                 'elements contains default with lazy init'
 669             );
 670
 671             $obj->_clear_values;
 672
 673             $obj->push(2);
 674
 675             is_deeply(
 676                 $obj->_values, [ 42, 84, 2 ],
 677                 'push works with lazy init'
 678             );
 679
 680             $obj->_clear_values;
 681
 682             $obj->unshift( 3, 4 );
 683
 684             is_deeply(
 685                 $obj->_values, [ 3, 4, 42, 84 ],
 686                 'unshift works with lazy init'
 687             );
 688         }
 689     }
 690     $class;
 691 }
 692
 693 done_testing;