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

   1 package Moose::Meta::Attribute::Native::MethodProvider::Array;
   2 use Moose::Role;
   3
   4 use List::Util;
   5 use List::MoreUtils;
   6
   7 our $VERSION = '1.14';
   8 $VERSION = eval $VERSION;
   9 our $AUTHORITY = 'cpan:STEVAN';
  10
  11 sub reduce : method {
  12     my ( $attr, $reader, $writer ) = @_;
  13     return sub {
  14         my ( $instance, $f ) = @_;
  15         our ($a, $b);
  16         List::Util::reduce { $f->($a, $b) } @{ $reader->($instance) };
  17     };
  18 }
  19
  20 sub sort : method {
  21     my ( $attr, $reader, $writer ) = @_;
  22     return sub {
  23         my ( $instance, $predicate ) = @_;
  24         die "Argument must be a code reference"
  25           if $predicate && ref $predicate ne 'CODE';
  26
  27         if ($predicate) {
  28             # Although it would be nice if we could support just using $a and
  29             # $b like sort already does, using $a or $b once in a package
  30             # triggers the 'Name "main::a" used only once' warning, and there
  31             # is no good way to avoid that, since it happens when the file
  32             # which defines the coderef is compiled, before we even get a
  33             # chance to see it here. So, we have no real choice but to use
  34             # normal parameters. --doy
  35             CORE::sort { $predicate->( $a, $b ) } @{ $reader->($instance) };
  36         }
  37         else {
  38             CORE::sort @{ $reader->($instance) };
  39         }
  40     };
  41 }
  42
  43 sub shuffle : method {
  44     my ( $attr, $reader, $writer ) = @_;
  45     return sub {
  46         my ( $instance ) = @_;
  47         List::Util::shuffle @{ $reader->($instance) };
  48     };
  49 }
  50
  51 sub grep : method {
  52     my ( $attr, $reader, $writer ) = @_;
  53     return sub {
  54         my ( $instance, $predicate ) = @_;
  55         CORE::grep { $predicate->() } @{ $reader->($instance) };
  56     };
  57 }
  58
  59 sub uniq : method {
  60     my ( $attr, $reader, $writer ) = @_;
  61     return sub {
  62         my ( $instance ) = @_;
  63         List::MoreUtils::uniq @{ $reader->($instance) };
  64     };
  65 }
  66
  67 sub join : method {
  68     my ( $attr, $reader, $writer ) = @_;
  69     return sub {
  70         my ( $instance, $separator ) = @_;
  71         join $separator, @{ $reader->($instance) };
  72     };
  73 }
  74
  75 sub push : method {
  76     my ( $attr, $reader, $writer ) = @_;
  77
  78     if (
  79         $attr->has_type_constraint
  80         && $attr->type_constraint->isa(
  81             'Moose::Meta::TypeConstraint::Parameterized')
  82       )
  83     {
  84         my $container_type_constraint = $attr->type_constraint->type_parameter;
  85         return sub {
  86             my $instance = CORE::shift;
  87             $container_type_constraint->check($_)
  88               || confess "Value "
  89               . ( $_ || 'undef' )
  90               . " did not pass container type constraint '$container_type_constraint'"
  91               foreach @_;
  92             CORE::push @{ $reader->($instance) } => @_;
  93         };
  94     }
  95     else {
  96         return sub {
  97             my $instance = CORE::shift;
  98             CORE::push @{ $reader->($instance) } => @_;
  99         };
 100     }
 101 }
 102
 103 sub pop : method {
 104     my ( $attr, $reader, $writer ) = @_;
 105     return sub {
 106         CORE::pop @{ $reader->( $_[0] ) };
 107     };
 108 }
 109
 110 sub unshift : method {
 111     my ( $attr, $reader, $writer ) = @_;
 112     if (
 113         $attr->has_type_constraint
 114         && $attr->type_constraint->isa(
 115             'Moose::Meta::TypeConstraint::Parameterized')
 116       )
 117     {
 118         my $container_type_constraint = $attr->type_constraint->type_parameter;
 119         return sub {
 120             my $instance = CORE::shift;
 121             $container_type_constraint->check($_)
 122               || confess "Value "
 123               . ( $_ || 'undef' )
 124               . " did not pass container type constraint '$container_type_constraint'"
 125               foreach @_;
 126             CORE::unshift @{ $reader->($instance) } => @_;
 127         };
 128     }
 129     else {
 130         return sub {
 131             my $instance = CORE::shift;
 132             CORE::unshift @{ $reader->($instance) } => @_;
 133         };
 134     }
 135 }
 136
 137 sub shift : method {
 138     my ( $attr, $reader, $writer ) = @_;
 139     return sub {
 140         CORE::shift @{ $reader->( $_[0] ) };
 141     };
 142 }
 143
 144 sub get : method {
 145     my ( $attr, $reader, $writer ) = @_;
 146     return sub {
 147         $reader->( $_[0] )->[ $_[1] ];
 148     };
 149 }
 150
 151 sub set : method {
 152     my ( $attr, $reader, $writer ) = @_;
 153     if (
 154         $attr->has_type_constraint
 155         && $attr->type_constraint->isa(
 156             'Moose::Meta::TypeConstraint::Parameterized')
 157       )
 158     {
 159         my $container_type_constraint = $attr->type_constraint->type_parameter;
 160         return sub {
 161             ( $container_type_constraint->check( $_[2] ) )
 162               || confess "Value "
 163               . ( $_[2] || 'undef' )
 164               . " did not pass container type constraint '$container_type_constraint'";
 165             $reader->( $_[0] )->[ $_[1] ] = $_[2];
 166         };
 167     }
 168     else {
 169         return sub {
 170             $reader->( $_[0] )->[ $_[1] ] = $_[2];
 171         };
 172     }
 173 }
 174
 175 sub accessor : method {
 176     my ( $attr, $reader, $writer ) = @_;
 177
 178     if (
 179         $attr->has_type_constraint
 180         && $attr->type_constraint->isa(
 181             'Moose::Meta::TypeConstraint::Parameterized')
 182       )
 183     {
 184         my $container_type_constraint = $attr->type_constraint->type_parameter;
 185         return sub {
 186             my $self = shift;
 187
 188             if ( @_ == 1 ) {    # reader
 189                 return $reader->($self)->[ $_[0] ];
 190             }
 191             elsif ( @_ == 2 ) {    # writer
 192                 ( $container_type_constraint->check( $_[1] ) )
 193                   || confess "Value "
 194                   . ( $_[1] || 'undef' )
 195                   . " did not pass container type constraint '$container_type_constraint'";
 196                 $reader->($self)->[ $_[0] ] = $_[1];
 197             }
 198             else {
 199                 confess "One or two arguments expected, not " . @_;
 200             }
 201         };
 202     }
 203     else {
 204         return sub {
 205             my $self = shift;
 206
 207             if ( @_ == 1 ) {    # reader
 208                 return $reader->($self)->[ $_[0] ];
 209             }
 210             elsif ( @_ == 2 ) {    # writer
 211                 $reader->($self)->[ $_[0] ] = $_[1];
 212             }
 213             else {
 214                 confess "One or two arguments expected, not " . @_;
 215             }
 216         };
 217     }
 218 }
 219
 220 sub clear : method {
 221     my ( $attr, $reader, $writer ) = @_;
 222     return sub {
 223         @{ $reader->( $_[0] ) } = ();
 224     };
 225 }
 226
 227 sub delete : method {
 228     my ( $attr, $reader, $writer ) = @_;
 229     return sub {
 230         CORE::splice @{ $reader->( $_[0] ) }, $_[1], 1;
 231       }
 232 }
 233
 234 sub insert : method {
 235     my ( $attr, $reader, $writer ) = @_;
 236     if (
 237         $attr->has_type_constraint
 238         && $attr->type_constraint->isa(
 239             'Moose::Meta::TypeConstraint::Parameterized')
 240       )
 241     {
 242         my $container_type_constraint = $attr->type_constraint->type_parameter;
 243         return sub {
 244             ( $container_type_constraint->check( $_[2] ) )
 245               || confess "Value "
 246               . ( $_[2] || 'undef' )
 247               . " did not pass container type constraint '$container_type_constraint'";
 248             CORE::splice @{ $reader->( $_[0] ) }, $_[1], 0, $_[2];
 249         };
 250     }
 251     else {
 252         return sub {
 253             CORE::splice @{ $reader->( $_[0] ) }, $_[1], 0, $_[2];
 254         };
 255     }
 256 }
 257
 258 sub splice : method {
 259     my ( $attr, $reader, $writer ) = @_;
 260     if (
 261         $attr->has_type_constraint
 262         && $attr->type_constraint->isa(
 263             'Moose::Meta::TypeConstraint::Parameterized')
 264       )
 265     {
 266         my $container_type_constraint = $attr->type_constraint->type_parameter;
 267         return sub {
 268             my ( $self, $i, $j, @elems ) = @_;
 269             ( $container_type_constraint->check($_) )
 270               || confess "Value "
 271               . ( defined($_) ? $_ : 'undef' )
 272               . " did not pass container type constraint '$container_type_constraint'"
 273               for @elems;
 274             CORE::splice @{ $reader->($self) }, $i, $j, @elems;
 275         };
 276     }
 277     else {
 278         return sub {
 279             my ( $self, $i, $j, @elems ) = @_;
 280             CORE::splice @{ $reader->($self) }, $i, $j, @elems;
 281         };
 282     }
 283 }
 284
 285 sub sort_in_place : method {
 286     my ( $attr, $reader, $writer ) = @_;
 287     return sub {
 288         my ( $instance, $predicate ) = @_;
 289
 290         die "Argument must be a code reference"
 291           if $predicate && ref $predicate ne 'CODE';
 292
 293         my @sorted;
 294         if ($predicate) {
 295             @sorted =
 296               CORE::sort { $predicate->( $a, $b ) } @{ $reader->($instance) };
 297         }
 298         else {
 299             @sorted = CORE::sort @{ $reader->($instance) };
 300         }
 301
 302         $writer->( $instance, \@sorted );
 303     };
 304 }
 305
 306 sub natatime : method {
 307     my ( $attr, $reader, $writer ) = @_;
 308     return sub {
 309         my ( $instance, $n, $f ) = @_;
 310         my $it = List::MoreUtils::natatime($n, @{ $reader->($instance) });
 311         return $it unless $f;
 312
 313         while (my @vals = $it->()) {
 314             $f->(@vals);
 315         }
 316
 317         return;
 318     };
 319 }
 320
 321 1;
 322
 323 __END__
 324
 325 =pod
 326
 327 =head1 NAME
 328
 329 Moose::Meta::Attribute::Native::MethodProvider::Array - role providing method generators for Array trait
 330
 331 =head1 DESCRIPTION
 332
 333 This is a role which provides the method generators for
 334 L<Moose::Meta::Attribute::Native::Trait::Array>. Please check there for
 335 documentation on what methods are provided.
 336
 337 =head1 METHODS
 338
 339 =over 4
 340
 341 =item B<meta>
 342
 343 =back
 344
 345 =head1 BUGS
 346
 347 See L<Moose/BUGS> for details on reporting bugs.
 348
 349 =head1 AUTHOR
 350
 351 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 352
 353 =head1 COPYRIGHT AND LICENSE
 354
 355 Copyright 2007-2009 by Infinity Interactive, Inc.
 356
 357 L<http://www.iinteractive.com>
 358
 359 This library is free software; you can redistribute it and/or modify
 360 it under the same terms as Perl itself.
 361
 362 =cut