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.89';
   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] ) } ? 0 : 1;
  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     {
 104         my $container_type_constraint = $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     {
 138         my $container_type_constraint = $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     {
 179         my $container_type_constraint = $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     {
 204         my $container_type_constraint = $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     {
 262         my $container_type_constraint = $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     {
 286         my $container_type_constraint = $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 =
 316               CORE::sort { $predicate->( $a, $b ) } @{ $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 DESCRIPTION
 337
 338 This is a role which provides the method generators for
 339 L<Moose::Meta::Attribute::Trait::Native::Array>. Please check there for
 340 documentation on what methods are provided.
 341
 342 =head1 METHODS
 343
 344 =over 4
 345
 346 =item B<meta>
 347
 348 =back
 349
 350 =head1 BUGS
 351
 352 All complex software has bugs lurking in it, and this module is no
 353 exception. If you find a bug please either email me, or add the bug
 354 to cpan-RT.
 355
 356 =head1 AUTHOR
 357
 358 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 359
 360 =head1 COPYRIGHT AND LICENSE
 361
 362 Copyright 2007-2009 by Infinity Interactive, Inc.
 363
 364 L<http://www.iinteractive.com>
 365
 366 This library is free software; you can redistribute it and/or modify
 367 it under the same terms as Perl itself.
 368
 369 =cut