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