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