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