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