lib/Moose/AttributeHelpers/MethodProvider/Array.pm

   1 package Moose::AttributeHelpers::MethodProvider::Array;
   2 use Moose::Role;
   3
   4 our $VERSION   = '0.87';
   5 $VERSION = eval $VERSION;
   6 our $AUTHORITY = 'cpan:STEVAN';
   7
   8 with 'Moose::AttributeHelpers::MethodProvider::List';
   9
  10 sub push : method {
  11     my ( $attr, $reader, $writer ) = @_;
  12
  13     if (
  14         $attr->has_type_constraint
  15         && $attr->type_constraint->isa(
  16             'Moose::Meta::TypeConstraint::Parameterized')
  17         ) {
  18         my $container_type_constraint
  19             = $attr->type_constraint->type_parameter;
  20         return sub {
  21             my $instance = CORE::shift;
  22             $container_type_constraint->check($_)
  23                 || confess "Value "
  24                 . ( $_ || 'undef' )
  25                 . " did not pass container type constraint '$container_type_constraint'"
  26                 foreach @_;
  27             CORE::push @{ $reader->($instance) } => @_;
  28         };
  29     }
  30     else {
  31         return sub {
  32             my $instance = CORE::shift;
  33             CORE::push @{ $reader->($instance) } => @_;
  34         };
  35     }
  36 }
  37
  38 sub pop : method {
  39     my ( $attr, $reader, $writer ) = @_;
  40     return sub {
  41         CORE::pop @{ $reader->( $_[0] ) };
  42     };
  43 }
  44
  45 sub unshift : method {
  46     my ( $attr, $reader, $writer ) = @_;
  47     if (
  48         $attr->has_type_constraint
  49         && $attr->type_constraint->isa(
  50             'Moose::Meta::TypeConstraint::Parameterized')
  51         ) {
  52         my $container_type_constraint
  53             = $attr->type_constraint->type_parameter;
  54         return sub {
  55             my $instance = CORE::shift;
  56             $container_type_constraint->check($_)
  57                 || confess "Value "
  58                 . ( $_ || 'undef' )
  59                 . " did not pass container type constraint '$container_type_constraint'"
  60                 foreach @_;
  61             CORE::unshift @{ $reader->($instance) } => @_;
  62         };
  63     }
  64     else {
  65         return sub {
  66             my $instance = CORE::shift;
  67             CORE::unshift @{ $reader->($instance) } => @_;
  68         };
  69     }
  70 }
  71
  72 sub shift : method {
  73     my ( $attr, $reader, $writer ) = @_;
  74     return sub {
  75         CORE::shift @{ $reader->( $_[0] ) };
  76     };
  77 }
  78
  79 sub get : method {
  80     my ( $attr, $reader, $writer ) = @_;
  81     return sub {
  82         $reader->( $_[0] )->[ $_[1] ];
  83     };
  84 }
  85
  86 sub set : method {
  87     my ( $attr, $reader, $writer ) = @_;
  88     if (
  89         $attr->has_type_constraint
  90         && $attr->type_constraint->isa(
  91             'Moose::Meta::TypeConstraint::Parameterized')
  92         ) {
  93         my $container_type_constraint
  94             = $attr->type_constraint->type_parameter;
  95         return sub {
  96             ( $container_type_constraint->check( $_[2] ) )
  97                 || confess "Value "
  98                 . ( $_[2] || 'undef' )
  99                 . " did not pass container type constraint '$container_type_constraint'";
 100             $reader->( $_[0] )->[ $_[1] ] = $_[2];
 101         };
 102     }
 103     else {
 104         return sub {
 105             $reader->( $_[0] )->[ $_[1] ] = $_[2];
 106         };
 107     }
 108 }
 109
 110 sub accessor : method {
 111     my ( $attr, $reader, $writer ) = @_;
 112
 113     if (
 114         $attr->has_type_constraint
 115         && $attr->type_constraint->isa(
 116             'Moose::Meta::TypeConstraint::Parameterized')
 117         ) {
 118         my $container_type_constraint
 119             = $attr->type_constraint->type_parameter;
 120         return sub {
 121             my $self = shift;
 122
 123             if ( @_ == 1 ) {    # reader
 124                 return $reader->($self)->[ $_[0] ];
 125             }
 126             elsif ( @_ == 2 ) {    # writer
 127                 ( $container_type_constraint->check( $_[1] ) )
 128                     || confess "Value "
 129                     . ( $_[1] || 'undef' )
 130                     . " did not pass container type constraint '$container_type_constraint'";
 131                 $reader->($self)->[ $_[0] ] = $_[1];
 132             }
 133             else {
 134                 confess "One or two arguments expected, not " . @_;
 135             }
 136         };
 137     }
 138     else {
 139         return sub {
 140             my $self = shift;
 141
 142             if ( @_ == 1 ) {    # reader
 143                 return $reader->($self)->[ $_[0] ];
 144             }
 145             elsif ( @_ == 2 ) {    # writer
 146                 $reader->($self)->[ $_[0] ] = $_[1];
 147             }
 148             else {
 149                 confess "One or two arguments expected, not " . @_;
 150             }
 151         };
 152     }
 153 }
 154
 155 sub clear : method {
 156     my ( $attr, $reader, $writer ) = @_;
 157     return sub {
 158         @{ $reader->( $_[0] ) } = ();
 159     };
 160 }
 161
 162 sub delete : method {
 163     my ( $attr, $reader, $writer ) = @_;
 164     return sub {
 165         CORE::splice @{ $reader->( $_[0] ) }, $_[1], 1;
 166         }
 167 }
 168
 169 sub insert : method {
 170     my ( $attr, $reader, $writer ) = @_;
 171     if (
 172         $attr->has_type_constraint
 173         && $attr->type_constraint->isa(
 174             'Moose::Meta::TypeConstraint::Parameterized')
 175         ) {
 176         my $container_type_constraint
 177             = $attr->type_constraint->type_parameter;
 178         return sub {
 179             ( $container_type_constraint->check( $_[2] ) )
 180                 || confess "Value "
 181                 . ( $_[2] || 'undef' )
 182                 . " did not pass container type constraint '$container_type_constraint'";
 183             CORE::splice @{ $reader->( $_[0] ) }, $_[1], 0, $_[2];
 184         };
 185     }
 186     else {
 187         return sub {
 188             CORE::splice @{ $reader->( $_[0] ) }, $_[1], 0, $_[2];
 189         };
 190     }
 191 }
 192
 193 sub splice : method {
 194     my ( $attr, $reader, $writer ) = @_;
 195     if (
 196         $attr->has_type_constraint
 197         && $attr->type_constraint->isa(
 198             'Moose::Meta::TypeConstraint::Parameterized')
 199         ) {
 200         my $container_type_constraint
 201             = $attr->type_constraint->type_parameter;
 202         return sub {
 203             my ( $self, $i, $j, @elems ) = @_;
 204             ( $container_type_constraint->check($_) )
 205                 || confess "Value "
 206                 . ( defined($_) ? $_ : 'undef' )
 207                 . " did not pass container type constraint '$container_type_constraint'"
 208                 for @elems;
 209             CORE::splice @{ $reader->($self) }, $i, $j, @elems;
 210         };
 211     }
 212     else {
 213         return sub {
 214             my ( $self, $i, $j, @elems ) = @_;
 215             CORE::splice @{ $reader->($self) }, $i, $j, @elems;
 216         };
 217     }
 218 }
 219
 220 sub sort_in_place : method {
 221     my ( $attr, $reader, $writer ) = @_;
 222     return sub {
 223         my ( $instance, $predicate ) = @_;
 224
 225         die "Argument must be a code reference"
 226             if $predicate && ref $predicate ne 'CODE';
 227
 228         my @sorted;
 229         if ($predicate) {
 230             @sorted = CORE::sort { $predicate->( $a, $b ) }
 231             @{ $reader->($instance) };
 232         }
 233         else {
 234             @sorted = CORE::sort @{ $reader->($instance) };
 235         }
 236
 237         $writer->( $instance, \@sorted );
 238     };
 239 }
 240
 241 1;
 242
 243 __END__
 244
 245 =pod
 246
 247 =head1 NAME
 248
 249 Moose::AttributeHelpers::MethodProvider::Array
 250
 251 =head1 DESCRIPTION
 252
 253 This is a role which provides the method generators for
 254 L<Moose::AttributeHelpers::Collection::Array>.
 255
 256 =head1 METHODS
 257
 258 =over 4
 259
 260 =item B<meta>
 261
 262 =back
 263
 264 =head1 PROVIDED METHODS
 265
 266 This module also consumes the B<List> method providers, to
 267 see those provided methods, refer to that documentation.
 268
 269 =over 4
 270
 271 =item B<get>
 272
 273 =item B<pop>
 274
 275 =item B<push>
 276
 277 =item B<set>
 278
 279 =item B<shift>
 280
 281 =item B<unshift>
 282
 283 =item B<clear>
 284
 285 =item B<delete>
 286
 287 =item B<insert>
 288
 289 =item B<splice>
 290
 291 =item B<sort_in_place>
 292
 293 Sorts the array I<in place>, modifying the value of the attribute.
 294
 295 You can provide an optional subroutine reference to sort with (as you
 296 can with the core C<sort> function). However, instead of using C<$a>
 297 and C<$b>, you will need to use C<$_[0]> and C<$_[1]> instead.
 298
 299 =item B<accessor>
 300
 301 If passed one argument, returns the value of the requested element.
 302 If passed two arguments, sets the value of the requested element.
 303
 304 =back
 305
 306 =head1 BUGS
 307
 308 All complex software has bugs lurking in it, and this module is no
 309 exception. If you find a bug please either email me, or add the bug
 310 to cpan-RT.
 311
 312 =head1 AUTHOR
 313
 314 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 315
 316 =head1 COPYRIGHT AND LICENSE
 317
 318 Copyright 2007-2009 by Infinity Interactive, Inc.
 319
 320 L<http://www.iinteractive.com>
 321
 322 This library is free software; you can redistribute it and/or modify
 323 it under the same terms as Perl itself.
 324
 325 =cut