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 with when passing an argument 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 with when passing an argument 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/Must provide a valid index number as an argument/,
 168             'throws an error when get is called with an invalid argument';
 169
 170         throws_ok { $obj->get(2.2) }
 171         qr/Must provide a valid index number as an argument/,
 172             'throws an error when get is called with an invalid argument';
 173
 174         throws_ok { $obj->get('foo') }
 175         qr/Must provide a valid index number as an argument/,
 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         lives_ok { $obj->splice_curried_1( 2, 101 ) }
 321         'splice_curried_1 lives';
 322
 323         is_deeply(
 324             $obj->_values, [ 1, 101, 21, 42 ],
 325             'splice added the specified elements'
 326         );
 327
 328         lives_ok { $obj->splice_curried_2(102) } 'splice_curried_2 lives';
 329
 330         is_deeply(
 331             $obj->_values, [ 1, 102, 42 ],
 332             'splice added the specified elements'
 333         );
 334
 335         lives_ok { $obj->splice_curried_all } 'splice_curried_all lives';
 336
 337         is_deeply(
 338             $obj->_values, [ 1, 3, 4, 5 ],
 339             'splice added the specified elements'
 340         );
 341
 342         $obj->_values( [ 3, 9, 5, 22, 11 ] );
 343
 344         is_deeply(
 345             [ $obj->sort ], [ 11, 22, 3, 5, 9 ],
 346             'sort returns sorted values'
 347         );
 348
 349         is_deeply(
 350             [ $obj->sort( sub { $_[0] <=> $_[1] } ) ], [ 3, 5, 9, 11, 22 ],
 351             'sort returns values sorted by provided function'
 352         );
 353
 354         throws_ok { $obj->sort(1) }
 355         qr/Argument must be a code reference/,
 356             'throws an error with when passing a non-function to sort';
 357
 358         throws_ok {
 359             $obj->sort( sub { }, 27 );
 360         }
 361         qr/Cannot call sort with more than 1 argument/,
 362             'throws an error with when passing two arguments to sort';
 363
 364         $obj->_values( [ 3, 9, 5, 22, 11 ] );
 365
 366         $obj->sort_in_place;
 367
 368         is_deeply(
 369             $obj->_values, [ 11, 22, 3, 5, 9 ],
 370             'sort_in_place sorts values'
 371         );
 372
 373         $obj->sort_in_place( sub { $_[0] <=> $_[1] } );
 374
 375         is_deeply(
 376             $obj->_values, [ 3, 5, 9, 11, 22 ],
 377             'sort_in_place with function sorts values'
 378         );
 379
 380         throws_ok {
 381             $obj->sort_in_place( sub { }, 27 );
 382         }
 383         qr/Cannot call sort_in_place with more than 1 argument/,
 384             'throws an error with when passing two arguments to sort_in_place';
 385
 386         $obj->_values( [ 3, 9, 5, 22, 11 ] );
 387
 388         $obj->sort_in_place_curried;
 389
 390         is_deeply(
 391             $obj->_values, [ 22, 11, 9, 5, 3 ],
 392             'sort_in_place_curried sorts values'
 393         );
 394
 395         throws_ok { $obj->sort_in_place_curried(27) }
 396         qr/Cannot call sort_in_place with more than 1 argument/,
 397             'throws an error with when passing one argument to sort_in_place_curried';
 398
 399         $obj->_values( [ 1 .. 5 ] );
 400
 401         is_deeply(
 402             [ $obj->map( sub { $_ + 1 } ) ],
 403             [ 2 .. 6 ],
 404             'map returns the expected values'
 405         );
 406
 407         throws_ok { $obj->map }
 408         qr/Cannot call map without at least 1 argument/,
 409             'throws an error with when passing no arguments to map';
 410
 411         throws_ok {
 412             $obj->map( sub { }, 2 );
 413         }
 414         qr/Cannot call map with more than 1 argument/,
 415             'throws an error with when passing two arguments to map';
 416
 417         throws_ok { $obj->map( {} ) }
 418         qr/Must provide a code reference as an argument/,
 419             'throws an error with when passing a non coderef to map';
 420
 421         $obj->_values( [ 1 .. 5 ] );
 422
 423         is_deeply(
 424             [ $obj->map_curried ],
 425             [ 2 .. 6 ],
 426             'map_curried returns the expected values'
 427         );
 428
 429         throws_ok {
 430             $obj->map_curried( sub { } );
 431         }
 432         qr/Cannot call map with more than 1 argument/,
 433             'throws an error with when passing one argument to map_curried';
 434
 435         $obj->_values( [ 2 .. 9 ] );
 436
 437         is_deeply(
 438             [ $obj->grep( sub { $_ < 5 } ) ],
 439             [ 2 .. 4 ],
 440             'grep returns the expected values'
 441         );
 442
 443         throws_ok { $obj->grep }
 444         qr/Cannot call grep without at least 1 argument/,
 445             'throws an error with when passing no arguments to grep';
 446
 447         throws_ok {
 448             $obj->grep( sub { }, 2 );
 449         }
 450         qr/Cannot call grep with more than 1 argument/,
 451             'throws an error with when passing two arguments to grep';
 452
 453         throws_ok { $obj->grep( {} ) }
 454         qr/Must provide a code reference as an argument/,
 455             'throws an error with when passing a non coderef to grep';
 456
 457         is_deeply(
 458             [ $obj->grep_curried ],
 459             [ 2 .. 4 ],
 460             'grep_curried returns the expected values'
 461         );
 462
 463         throws_ok {
 464             $obj->grep_curried( sub { } );
 465         }
 466         qr/Cannot call grep with more than 1 argument/,
 467             'throws an error with when passing one argument to grep_curried';
 468
 469         $obj->_values( [ 2, 4, 22, 99, 101, 6 ] );
 470
 471         is(
 472             $obj->first( sub { $_ % 2 } ),
 473             99,
 474             'first returns expected value'
 475         );
 476
 477         throws_ok { $obj->first }
 478         qr/Cannot call first without at least 1 argument/,
 479             'throws an error with when passing no arguments to first';
 480
 481         throws_ok {
 482             $obj->first( sub { }, 2 );
 483         }
 484         qr/Cannot call first with more than 1 argument/,
 485             'throws an error with when passing two arguments to first';
 486
 487         throws_ok { $obj->first( {} ) }
 488         qr/Must provide a code reference as an argument/,
 489             'throws an error with when passing a non coderef to first';
 490
 491         is(
 492             $obj->first_curried,
 493             99,
 494             'first_curried returns expected value'
 495         );
 496
 497         throws_ok {
 498             $obj->first_curried( sub { } );
 499         }
 500         qr/Cannot call first with more than 1 argument/,
 501             'throws an error with when passing one argument to first_curried';
 502
 503         $obj->_values( [ 1 .. 4 ] );
 504
 505         is(
 506             $obj->join('-'), '1-2-3-4',
 507             'join returns expected result'
 508         );
 509
 510         throws_ok { $obj->join }
 511         qr/Cannot call join without at least 1 argument/,
 512             'throws an error with when passing no arguments to join';
 513
 514         throws_ok { $obj->join( '-', 2 ) }
 515         qr/Cannot call join with more than 1 argument/,
 516             'throws an error with when passing two arguments to join';
 517
 518         throws_ok { $obj->join( {} ) }
 519         qr/Must provide a string as an argument/,
 520             'throws an error with when passing a non string to join';
 521
 522         is_deeply(
 523             [ sort $obj->shuffle ],
 524             [ 1 .. 4 ],
 525             'shuffle returns all values (cannot check for a random order)'
 526         );
 527
 528         throws_ok { $obj->shuffle(2) }
 529         qr/Cannot call shuffle with any arguments/,
 530             'throws an error with when passing an argument to shuffle';
 531
 532         $obj->_values( [ 1 .. 4, 2, 5, 3, 7, 3, 3, 1 ] );
 533
 534         is_deeply(
 535             [ $obj->uniq ],
 536             [ 1 .. 4, 5, 7 ],
 537             'uniq returns expected values (in original order)'
 538         );
 539
 540         throws_ok { $obj->uniq(2) }
 541         qr/Cannot call uniq with any arguments/,
 542             'throws an error with when passing an argument to uniq';
 543
 544         $obj->_values( [ 1 .. 5 ] );
 545
 546         is(
 547             $obj->reduce( sub { $_[0] * $_[1] } ),
 548             120,
 549             'reduce returns expected value'
 550         );
 551
 552         throws_ok { $obj->reduce }
 553         qr/Cannot call reduce without at least 1 argument/,
 554             'throws an error with when passing no arguments to reduce';
 555
 556         throws_ok {
 557             $obj->reduce( sub { }, 2 );
 558         }
 559         qr/Cannot call reduce with more than 1 argument/,
 560             'throws an error with when passing two arguments to reduce';
 561
 562         throws_ok { $obj->reduce( {} ) }
 563         qr/Must provide a code reference as an argument/,
 564             'throws an error with when passing a non coderef to reduce';
 565
 566         is(
 567             $obj->reduce_curried,
 568             120,
 569             'reduce_curried returns expected value'
 570         );
 571
 572         throws_ok {
 573             $obj->reduce_curried( sub { } );
 574         }
 575         qr/Cannot call reduce with more than 1 argument/,
 576             'throws an error with when passing one argument to reduce_curried';
 577
 578         $obj->_values( [ 1 .. 6 ] );
 579
 580         my $it = $obj->natatime(2);
 581         my @nat;
 582         while ( my @v = $it->() ) {
 583             push @nat, \@v;
 584         }
 585
 586         is_deeply(
 587             [ [ 1, 2 ], [ 3, 4 ], [ 5, 6 ] ],
 588             \@nat,
 589             'natatime returns expected iterator'
 590         );
 591
 592         @nat = ();
 593         $obj->natatime( 2, sub { push @nat, [@_] } );
 594
 595         is_deeply(
 596             [ [ 1, 2 ], [ 3, 4 ], [ 5, 6 ] ],
 597             \@nat,
 598             'natatime with function returns expected value'
 599         );
 600
 601         throws_ok { $obj->natatime( {} ) }
 602         qr/Must provide an integer as an argument/,
 603             'throws an error with when passing a non integer to natatime';
 604
 605         throws_ok { $obj->natatime( 2, {} ) }
 606         qr/The second argument must be a code reference/,
 607             'throws an error with when passing a non code ref to natatime';
 608
 609         if ( $class->meta->get_attribute('_values')->is_lazy ) {
 610             my $obj = $class->new;
 611
 612             is( $obj->count, 2, 'count is 2 (lazy init)' );
 613
 614             $obj->_clear_values;
 615
 616             is_deeply( [ $obj->elements ], [ 42, 84],
 617                 'elements contains default with lazy init' );
 618
 619             $obj->_clear_values;
 620
 621             $obj->push(2);
 622
 623             is_deeply(
 624                 $obj->_values, [ 42, 84, 2 ],
 625                 'push works with lazy init'
 626             );
 627
 628             $obj->_clear_values;
 629
 630             $obj->unshift( 3, 4 );
 631
 632             is_deeply(
 633                 $obj->_values, [ 3, 4, 42, 84 ],
 634                 'unshift works with lazy init'
 635             );
 636         }
 637     }
 638     $class;
 639 }
 640
 641 done_testing;