lib/MooseX/AttributeHelpers/MethodProvider/Array.pm

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