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