t/070_native_traits/010_trait_array.t

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