lib/Moose/Meta/Attribute/Native/MethodProvider/Array.pm

   1 package Moose::Meta::Attribute::Native::MethodProvider::Array;
   2 use Moose::Role;
   3
   4 our $VERSION   = '0.87';
   5 $VERSION = eval $VERSION;
   6 our $AUTHORITY = 'cpan:STEVAN';
   7
   8 sub count : method {
   9     my ( $attr, $reader, $writer ) = @_;
  10     return sub {
  11         scalar @{ $reader->( $_[0] ) };
  12     };
  13 }
  14
  15 sub empty : method {
  16     my ( $attr, $reader, $writer ) = @_;
  17     return sub {
  18         scalar @{ $reader->( $_[0] ) } ? 1 : 0;
  19     };
  20 }
  21
  22 sub find : method {
  23     my ( $attr, $reader, $writer ) = @_;
  24     return sub {
  25         my ( $instance, $predicate ) = @_;
  26         foreach my $val ( @{ $reader->($instance) } ) {
  27             return $val if $predicate->($val);
  28         }
  29         return;
  30     };
  31 }
  32
  33 sub map : method {
  34     my ( $attr, $reader, $writer ) = @_;
  35     return sub {
  36         my ( $instance, $f ) = @_;
  37         CORE::map { $f->($_) } @{ $reader->($instance) };
  38     };
  39 }
  40
  41 sub sort : method {
  42     my ( $attr, $reader, $writer ) = @_;
  43     return sub {
  44         my ( $instance, $predicate ) = @_;
  45         die "Argument must be a code reference"
  46             if $predicate && ref $predicate ne 'CODE';
  47
  48         if ($predicate) {
  49             CORE::sort { $predicate->( $a, $b ) } @{ $reader->($instance) };
  50         }
  51         else {
  52             CORE::sort @{ $reader->($instance) };
  53         }
  54     };
  55 }
  56
  57 sub grep : method {
  58     my ( $attr, $reader, $writer ) = @_;
  59     return sub {
  60         my ( $instance, $predicate ) = @_;
  61         CORE::grep { $predicate->($_) } @{ $reader->($instance) };
  62     };
  63 }
  64
  65 sub elements : method {
  66     my ( $attr, $reader, $writer ) = @_;
  67     return sub {
  68         my ($instance) = @_;
  69         @{ $reader->($instance) };
  70     };
  71 }
  72
  73 sub join : method {
  74     my ( $attr, $reader, $writer ) = @_;
  75     return sub {
  76         my ( $instance, $separator ) = @_;
  77         join $separator, @{ $reader->($instance) };
  78     };
  79 }
  80
  81 sub first : method {
  82     my ( $attr, $reader, $writer ) = @_;
  83     return sub {
  84         $reader->( $_[0] )->[0];
  85     };
  86 }
  87
  88 sub last : method {
  89     my ( $attr, $reader, $writer ) = @_;
  90     return sub {
  91         $reader->( $_[0] )->[-1];
  92     };
  93 }
  94
  95 sub push : method {
  96     my ( $attr, $reader, $writer ) = @_;
  97
  98     if (
  99         $attr->has_type_constraint
 100         && $attr->type_constraint->isa(
 101             'Moose::Meta::TypeConstraint::Parameterized')
 102         ) {
 103         my $container_type_constraint
 104             = $attr->type_constraint->type_parameter;
 105         return sub {
 106             my $instance = CORE::shift;
 107             $container_type_constraint->check($_)
 108                 || confess "Value "
 109                 . ( $_ || 'undef' )
 110                 . " did not pass container type constraint '$container_type_constraint'"
 111                 foreach @_;
 112             CORE::push @{ $reader->($instance) } => @_;
 113         };
 114     }
 115     else {
 116         return sub {
 117             my $instance = CORE::shift;
 118             CORE::push @{ $reader->($instance) } => @_;
 119         };
 120     }
 121 }
 122
 123 sub pop : method {
 124     my ( $attr, $reader, $writer ) = @_;
 125     return sub {
 126         CORE::pop @{ $reader->( $_[0] ) };
 127     };
 128 }
 129
 130 sub unshift : method {
 131     my ( $attr, $reader, $writer ) = @_;
 132     if (
 133         $attr->has_type_constraint
 134         && $attr->type_constraint->isa(
 135             'Moose::Meta::TypeConstraint::Parameterized')
 136         ) {
 137         my $container_type_constraint
 138             = $attr->type_constraint->type_parameter;
 139         return sub {
 140             my $instance = CORE::shift;
 141             $container_type_constraint->check($_)
 142                 || confess "Value "
 143                 . ( $_ || 'undef' )
 144                 . " did not pass container type constraint '$container_type_constraint'"
 145                 foreach @_;
 146             CORE::unshift @{ $reader->($instance) } => @_;
 147         };
 148     }
 149     else {
 150         return sub {
 151             my $instance = CORE::shift;
 152             CORE::unshift @{ $reader->($instance) } => @_;
 153         };
 154     }
 155 }
 156
 157 sub shift : method {
 158     my ( $attr, $reader, $writer ) = @_;
 159     return sub {
 160         CORE::shift @{ $reader->( $_[0] ) };
 161     };
 162 }
 163
 164 sub get : method {
 165     my ( $attr, $reader, $writer ) = @_;
 166     return sub {
 167         $reader->( $_[0] )->[ $_[1] ];
 168     };
 169 }
 170
 171 sub set : method {
 172     my ( $attr, $reader, $writer ) = @_;
 173     if (
 174         $attr->has_type_constraint
 175         && $attr->type_constraint->isa(
 176             'Moose::Meta::TypeConstraint::Parameterized')
 177         ) {
 178         my $container_type_constraint
 179             = $attr->type_constraint->type_parameter;
 180         return sub {
 181             ( $container_type_constraint->check( $_[2] ) )
 182                 || confess "Value "
 183                 . ( $_[2] || 'undef' )
 184                 . " did not pass container type constraint '$container_type_constraint'";
 185             $reader->( $_[0] )->[ $_[1] ] = $_[2];
 186         };
 187     }
 188     else {
 189         return sub {
 190             $reader->( $_[0] )->[ $_[1] ] = $_[2];
 191         };
 192     }
 193 }
 194
 195 sub accessor : method {
 196     my ( $attr, $reader, $writer ) = @_;
 197
 198     if (
 199         $attr->has_type_constraint
 200         && $attr->type_constraint->isa(
 201             'Moose::Meta::TypeConstraint::Parameterized')
 202         ) {
 203         my $container_type_constraint
 204             = $attr->type_constraint->type_parameter;
 205         return sub {
 206             my $self = shift;
 207
 208             if ( @_ == 1 ) {    # reader
 209                 return $reader->($self)->[ $_[0] ];
 210             }
 211             elsif ( @_ == 2 ) {    # writer
 212                 ( $container_type_constraint->check( $_[1] ) )
 213                     || confess "Value "
 214                     . ( $_[1] || 'undef' )
 215                     . " did not pass container type constraint '$container_type_constraint'";
 216                 $reader->($self)->[ $_[0] ] = $_[1];
 217             }
 218             else {
 219                 confess "One or two arguments expected, not " . @_;
 220             }
 221         };
 222     }
 223     else {
 224         return sub {
 225             my $self = shift;
 226
 227             if ( @_ == 1 ) {    # reader
 228                 return $reader->($self)->[ $_[0] ];
 229             }
 230             elsif ( @_ == 2 ) {    # writer
 231                 $reader->($self)->[ $_[0] ] = $_[1];
 232             }
 233             else {
 234                 confess "One or two arguments expected, not " . @_;
 235             }
 236         };
 237     }
 238 }
 239
 240 sub clear : method {
 241     my ( $attr, $reader, $writer ) = @_;
 242     return sub {
 243         @{ $reader->( $_[0] ) } = ();
 244     };
 245 }
 246
 247 sub delete : method {
 248     my ( $attr, $reader, $writer ) = @_;
 249     return sub {
 250         CORE::splice @{ $reader->( $_[0] ) }, $_[1], 1;
 251         }
 252 }
 253
 254 sub insert : method {
 255     my ( $attr, $reader, $writer ) = @_;
 256     if (
 257         $attr->has_type_constraint
 258         && $attr->type_constraint->isa(
 259             'Moose::Meta::TypeConstraint::Parameterized')
 260         ) {
 261         my $container_type_constraint
 262             = $attr->type_constraint->type_parameter;
 263         return sub {
 264             ( $container_type_constraint->check( $_[2] ) )
 265                 || confess "Value "
 266                 . ( $_[2] || 'undef' )
 267                 . " did not pass container type constraint '$container_type_constraint'";
 268             CORE::splice @{ $reader->( $_[0] ) }, $_[1], 0, $_[2];
 269         };
 270     }
 271     else {
 272         return sub {
 273             CORE::splice @{ $reader->( $_[0] ) }, $_[1], 0, $_[2];
 274         };
 275     }
 276 }
 277
 278 sub splice : method {
 279     my ( $attr, $reader, $writer ) = @_;
 280     if (
 281         $attr->has_type_constraint
 282         && $attr->type_constraint->isa(
 283             'Moose::Meta::TypeConstraint::Parameterized')
 284         ) {
 285         my $container_type_constraint
 286             = $attr->type_constraint->type_parameter;
 287         return sub {
 288             my ( $self, $i, $j, @elems ) = @_;
 289             ( $container_type_constraint->check($_) )
 290                 || confess "Value "
 291                 . ( defined($_) ? $_ : 'undef' )
 292                 . " did not pass container type constraint '$container_type_constraint'"
 293                 for @elems;
 294             CORE::splice @{ $reader->($self) }, $i, $j, @elems;
 295         };
 296     }
 297     else {
 298         return sub {
 299             my ( $self, $i, $j, @elems ) = @_;
 300             CORE::splice @{ $reader->($self) }, $i, $j, @elems;
 301         };
 302     }
 303 }
 304
 305 sub sort_in_place : method {
 306     my ( $attr, $reader, $writer ) = @_;
 307     return sub {
 308         my ( $instance, $predicate ) = @_;
 309
 310         die "Argument must be a code reference"
 311             if $predicate && ref $predicate ne 'CODE';
 312
 313         my @sorted;
 314         if ($predicate) {
 315             @sorted = CORE::sort { $predicate->( $a, $b ) }
 316             @{ $reader->($instance) };
 317         }
 318         else {
 319             @sorted = CORE::sort @{ $reader->($instance) };
 320         }
 321
 322         $writer->( $instance, \@sorted );
 323     };
 324 }
 325
 326 1;
 327
 328 __END__
 329
 330 =pod
 331
 332 =head1 NAME
 333
 334 Moose::Meta::Attribute::Native::MethodProvider::Array
 335
 336 =head1 SYNOPSIS
 337
 338    package Stuff;
 339    use Moose;
 340    use Moose::AttributeHelpers;
 341
 342    has 'options' => (
 343        metaclass  => 'Array',
 344        is         => 'rw',
 345        isa        => 'ArrayRef[Str]',
 346        default    => sub { [] },
 347        auto_deref => 1,
 348        handles   => {
 349            all_options       => 'elements',
 350            map_options       => 'map',
 351            filter_options    => 'grep',
 352            find_option       => 'find',
 353            first_option      => 'first',
 354            last_option       => 'last',
 355            get_option        => 'get',
 356            join_options      => 'join',
 357            count_options     => 'count',
 358            do_i_have_options => 'empty',
 359            sorted_options    => 'sort',
 360        }
 361    );
 362
 363    no Moose;
 364    1;
 365
 366 =head1 DESCRIPTION
 367
 368 This is a role which provides the method generators for
 369 L<Moose::Meta::Attribute::Trait::Native::Array>.
 370
 371 =head1 METHODS
 372
 373 =over 4
 374
 375 =item B<meta>
 376
 377 =back
 378
 379 =head1 PROVIDED METHODS
 380
 381 =over 4
 382
 383 =item B<count>
 384
 385 Returns the number of elements in the array.
 386
 387    $stuff = Stuff->new;
 388    $stuff->options(["foo", "bar", "baz", "boo"]);
 389
 390    my $count = $stuff->count_options;
 391    print "$count\n"; # prints 4
 392
 393 =item B<empty>
 394
 395 If the array is populated, returns true. Otherwise, returns false.
 396
 397    $stuff->do_i_have_options ? print "Good boy.\n" : die "No options!\n" ;
 398
 399 =item B<find>
 400
 401 This method accepts a subroutine reference as its argument. That sub
 402 will receive each element of the array in turn. If it returns true for
 403 an element, that element will be returned by the C<find> method.
 404
 405    my $found = $stuff->find_option( sub { $_[0] =~ /^b/ } );
 406    print "$found\n"; # prints "bar"
 407
 408 =item B<grep>
 409
 410 This method accepts a subroutine reference as its argument. This
 411 method returns every element for which that subroutine reference
 412 returns a true value.
 413
 414    my @found = $stuff->filter_options( sub { $_[0] =~ /^b/ } );
 415    print "@found\n"; # prints "bar baz boo"
 416
 417 =item B<map>
 418
 419 This method accepts a subroutine reference as its argument. The
 420 subroutine will be executed for each element of the array. It is
 421 expected to return a modified version of that element. The return
 422 value of the method is a list of the modified options.
 423
 424    my @mod_options = $stuff->map_options( sub { $_[0] . "-tag" } );
 425    print "@mod_options\n"; # prints "foo-tag bar-tag baz-tag boo-tag"
 426
 427 =item B<sort>
 428
 429 Sorts and returns the elements of the array.
 430
 431 You can provide an optional subroutine reference to sort with (as you
 432 can with the core C<sort> function). However, instead of using C<$a>
 433 and C<$b>, you will need to use C<$_[0]> and C<$_[1]> instead.
 434
 435    # ascending ASCIIbetical
 436    my @sorted = $stuff->sort_options();
 437
 438    # Descending alphabetical order
 439    my @sorted_options = $stuff->sort_options( sub { lc $_[1] cmp lc $_[0] } );
 440    print "@sorted_options\n"; # prints "foo boo baz bar"
 441
 442 =item B<elements>
 443
 444 Returns all of the elements of the array
 445
 446    my @option = $stuff->all_options;
 447    print "@options\n"; # prints "foo bar baz boo"
 448
 449 =item B<join>
 450
 451 Joins every element of the array using the separator given as argument.
 452
 453    my $joined = $stuff->join_options( ':' );
 454    print "$joined\n"; # prints "foo:bar:baz:boo"
 455
 456 =item B<get>
 457
 458 Returns an element of the array by its index.
 459
 460    my $option = $stuff->get_option(1);
 461    print "$option\n"; # prints "bar"
 462
 463 =item B<first>
 464
 465 Returns the first element of the array.
 466
 467    my $first = $stuff->first_option;
 468    print "$first\n"; # prints "foo"
 469
 470 =item B<last>
 471
 472 Returns the last element of the array.
 473
 474    my $last = $stuff->last_option;
 475    print "$last\n"; # prints "boo"
 476
 477 =item B<pop>
 478
 479 =item B<push>
 480
 481 =item B<set>
 482
 483 =item B<shift>
 484
 485 =item B<unshift>
 486
 487 =item B<clear>
 488
 489 =item B<delete>
 490
 491 =item B<insert>
 492
 493 =item B<splice>
 494
 495 =item B<sort_in_place>
 496
 497 Sorts the array I<in place>, modifying the value of the attribute.
 498
 499 You can provide an optional subroutine reference to sort with (as you
 500 can with the core C<sort> function). However, instead of using C<$a>
 501 and C<$b>, you will need to use C<$_[0]> and C<$_[1]> instead.
 502
 503 =item B<accessor>
 504
 505 If passed one argument, returns the value of the requested element.
 506 If passed two arguments, sets the value of the requested element.
 507
 508 =back
 509
 510 =head1 BUGS
 511
 512 All complex software has bugs lurking in it, and this module is no
 513 exception. If you find a bug please either email me, or add the bug
 514 to cpan-RT.
 515
 516 =head1 AUTHOR
 517
 518 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 519
 520 =head1 COPYRIGHT AND LICENSE
 521
 522 Copyright 2007-2009 by Infinity Interactive, Inc.
 523
 524 L<http://www.iinteractive.com>
 525
 526 This library is free software; you can redistribute it and/or modify
 527 it under the same terms as Perl itself.
 528
 529 =cut