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