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