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 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 head : method {
  90     my ( $attr, $reader, $writer ) = @_;
  91     return sub {
  92         $reader->( $_[0] )->[0];
  93     };
  94 }
  95
  96 sub tail : method {
  97     my ( $attr, $reader, $writer ) = @_;
  98     return sub {
  99         my $arr = $reader->( $_[0] );
 100         return @{ $arr }[1..$#{ $arr }];
 101     };
 102 }
 103
 104 sub last : method {
 105     my ( $attr, $reader, $writer ) = @_;
 106     return sub {
 107         $reader->( $_[0] )->[-1];
 108     };
 109 }
 110
 111 sub push : method {
 112     my ( $attr, $reader, $writer ) = @_;
 113
 114     if (
 115         $attr->has_type_constraint
 116         && $attr->type_constraint->isa(
 117             'Moose::Meta::TypeConstraint::Parameterized')
 118       )
 119     {
 120         my $container_type_constraint = $attr->type_constraint->type_parameter;
 121         return sub {
 122             my $instance = CORE::shift;
 123             $container_type_constraint->check($_)
 124               || confess "Value "
 125               . ( $_ || 'undef' )
 126               . " did not pass container type constraint '$container_type_constraint'"
 127               foreach @_;
 128             CORE::push @{ $reader->($instance) } => @_;
 129         };
 130     }
 131     else {
 132         return sub {
 133             my $instance = CORE::shift;
 134             CORE::push @{ $reader->($instance) } => @_;
 135         };
 136     }
 137 }
 138
 139 sub pop : method {
 140     my ( $attr, $reader, $writer ) = @_;
 141     return sub {
 142         CORE::pop @{ $reader->( $_[0] ) };
 143     };
 144 }
 145
 146 sub unshift : method {
 147     my ( $attr, $reader, $writer ) = @_;
 148     if (
 149         $attr->has_type_constraint
 150         && $attr->type_constraint->isa(
 151             'Moose::Meta::TypeConstraint::Parameterized')
 152       )
 153     {
 154         my $container_type_constraint = $attr->type_constraint->type_parameter;
 155         return sub {
 156             my $instance = CORE::shift;
 157             $container_type_constraint->check($_)
 158               || confess "Value "
 159               . ( $_ || 'undef' )
 160               . " did not pass container type constraint '$container_type_constraint'"
 161               foreach @_;
 162             CORE::unshift @{ $reader->($instance) } => @_;
 163         };
 164     }
 165     else {
 166         return sub {
 167             my $instance = CORE::shift;
 168             CORE::unshift @{ $reader->($instance) } => @_;
 169         };
 170     }
 171 }
 172
 173 sub shift : method {
 174     my ( $attr, $reader, $writer ) = @_;
 175     return sub {
 176         CORE::shift @{ $reader->( $_[0] ) };
 177     };
 178 }
 179
 180 sub get : method {
 181     my ( $attr, $reader, $writer ) = @_;
 182     return sub {
 183         $reader->( $_[0] )->[ $_[1] ];
 184     };
 185 }
 186
 187 sub set : method {
 188     my ( $attr, $reader, $writer ) = @_;
 189     if (
 190         $attr->has_type_constraint
 191         && $attr->type_constraint->isa(
 192             'Moose::Meta::TypeConstraint::Parameterized')
 193       )
 194     {
 195         my $container_type_constraint = $attr->type_constraint->type_parameter;
 196         return sub {
 197             ( $container_type_constraint->check( $_[2] ) )
 198               || confess "Value "
 199               . ( $_[2] || 'undef' )
 200               . " did not pass container type constraint '$container_type_constraint'";
 201             $reader->( $_[0] )->[ $_[1] ] = $_[2];
 202         };
 203     }
 204     else {
 205         return sub {
 206             $reader->( $_[0] )->[ $_[1] ] = $_[2];
 207         };
 208     }
 209 }
 210
 211 sub accessor : method {
 212     my ( $attr, $reader, $writer ) = @_;
 213
 214     if (
 215         $attr->has_type_constraint
 216         && $attr->type_constraint->isa(
 217             'Moose::Meta::TypeConstraint::Parameterized')
 218       )
 219     {
 220         my $container_type_constraint = $attr->type_constraint->type_parameter;
 221         return sub {
 222             my $self = shift;
 223
 224             if ( @_ == 1 ) {    # reader
 225                 return $reader->($self)->[ $_[0] ];
 226             }
 227             elsif ( @_ == 2 ) {    # writer
 228                 ( $container_type_constraint->check( $_[1] ) )
 229                   || confess "Value "
 230                   . ( $_[1] || 'undef' )
 231                   . " did not pass container type constraint '$container_type_constraint'";
 232                 $reader->($self)->[ $_[0] ] = $_[1];
 233             }
 234             else {
 235                 confess "One or two arguments expected, not " . @_;
 236             }
 237         };
 238     }
 239     else {
 240         return sub {
 241             my $self = shift;
 242
 243             if ( @_ == 1 ) {    # reader
 244                 return $reader->($self)->[ $_[0] ];
 245             }
 246             elsif ( @_ == 2 ) {    # writer
 247                 $reader->($self)->[ $_[0] ] = $_[1];
 248             }
 249             else {
 250                 confess "One or two arguments expected, not " . @_;
 251             }
 252         };
 253     }
 254 }
 255
 256 sub clear : method {
 257     my ( $attr, $reader, $writer ) = @_;
 258     return sub {
 259         @{ $reader->( $_[0] ) } = ();
 260     };
 261 }
 262
 263 sub delete : method {
 264     my ( $attr, $reader, $writer ) = @_;
 265     return sub {
 266         CORE::splice @{ $reader->( $_[0] ) }, $_[1], 1;
 267       }
 268 }
 269
 270 sub insert : method {
 271     my ( $attr, $reader, $writer ) = @_;
 272     if (
 273         $attr->has_type_constraint
 274         && $attr->type_constraint->isa(
 275             'Moose::Meta::TypeConstraint::Parameterized')
 276       )
 277     {
 278         my $container_type_constraint = $attr->type_constraint->type_parameter;
 279         return sub {
 280             ( $container_type_constraint->check( $_[2] ) )
 281               || confess "Value "
 282               . ( $_[2] || 'undef' )
 283               . " did not pass container type constraint '$container_type_constraint'";
 284             CORE::splice @{ $reader->( $_[0] ) }, $_[1], 0, $_[2];
 285         };
 286     }
 287     else {
 288         return sub {
 289             CORE::splice @{ $reader->( $_[0] ) }, $_[1], 0, $_[2];
 290         };
 291     }
 292 }
 293
 294 sub splice : method {
 295     my ( $attr, $reader, $writer ) = @_;
 296     if (
 297         $attr->has_type_constraint
 298         && $attr->type_constraint->isa(
 299             'Moose::Meta::TypeConstraint::Parameterized')
 300       )
 301     {
 302         my $container_type_constraint = $attr->type_constraint->type_parameter;
 303         return sub {
 304             my ( $self, $i, $j, @elems ) = @_;
 305             ( $container_type_constraint->check($_) )
 306               || confess "Value "
 307               . ( defined($_) ? $_ : 'undef' )
 308               . " did not pass container type constraint '$container_type_constraint'"
 309               for @elems;
 310             CORE::splice @{ $reader->($self) }, $i, $j, @elems;
 311         };
 312     }
 313     else {
 314         return sub {
 315             my ( $self, $i, $j, @elems ) = @_;
 316             CORE::splice @{ $reader->($self) }, $i, $j, @elems;
 317         };
 318     }
 319 }
 320
 321 sub sort_in_place : method {
 322     my ( $attr, $reader, $writer ) = @_;
 323     return sub {
 324         my ( $instance, $predicate ) = @_;
 325
 326         die "Argument must be a code reference"
 327           if $predicate && ref $predicate ne 'CODE';
 328
 329         my @sorted;
 330         if ($predicate) {
 331             @sorted =
 332               CORE::sort { $predicate->( $a, $b ) } @{ $reader->($instance) };
 333         }
 334         else {
 335             @sorted = CORE::sort @{ $reader->($instance) };
 336         }
 337
 338         $writer->( $instance, \@sorted );
 339     };
 340 }
 341
 342 1;
 343
 344 __END__
 345
 346 =pod
 347
 348 =head1 NAME
 349
 350 Moose::Meta::Attribute::Native::MethodProvider::Array
 351
 352 =head1 DESCRIPTION
 353
 354 This is a role which provides the method generators for
 355 L<Moose::Meta::Attribute::Trait::Native::Array>. Please check there for
 356 documentation on what methods are provided.
 357
 358 =head1 METHODS
 359
 360 =over 4
 361
 362 =item B<meta>
 363
 364 =back
 365
 366 =head1 BUGS
 367
 368 All complex software has bugs lurking in it, and this module is no
 369 exception. If you find a bug please either email me, or add the bug
 370 to cpan-RT.
 371
 372 =head1 AUTHOR
 373
 374 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 375
 376 =head1 COPYRIGHT AND LICENSE
 377
 378 Copyright 2007-2009 by Infinity Interactive, Inc.
 379
 380 L<http://www.iinteractive.com>
 381
 382 This library is free software; you can redistribute it and/or modify
 383 it under the same terms as Perl itself.
 384
 385 =cut