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"
  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"
  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";
  79             $reader->($_[0])->[$_[1]] = $_[2]
  80         };
  81     }
  82     else {
  83         return sub {
  84             $reader->($_[0])->[$_[1]] = $_[2]
  85         };
  86     }
  87 }
  88
  89 sub clear : method {
  90     my ($attr, $reader, $writer) = @_;
  91     return sub {
  92         @{$reader->($_[0])} = ()
  93     };
  94 }
  95
  96 sub delete : method {
  97     my ($attr, $reader, $writer) = @_;
  98     return sub {
  99         CORE::splice @{$reader->($_[0])}, $_[1], 1;
 100     }
 101 }
 102
 103 sub insert : method {
 104     my ($attr, $reader, $writer) = @_;
 105     if ($attr->has_type_constraint && $attr->type_constraint->isa('Moose::Meta::TypeConstraint::Parameterized')) {
 106         my $container_type_constraint = $attr->type_constraint->type_parameter;
 107         return sub {
 108             ($container_type_constraint->check($_[2]))
 109                 || confess "Value " . ($_[2]||'undef') . " did not pass container type constraint";
 110             CORE::splice @{$reader->($_[0])}, $_[1], 0, $_[2];
 111         };
 112     }
 113     else {
 114         return sub {
 115             CORE::splice @{$reader->($_[0])}, $_[1], 0, $_[2];
 116         };
 117     }
 118 }
 119
 120 sub splice : method {
 121     my ($attr, $reader, $writer) = @_;
 122     if ($attr->has_type_constraint && $attr->type_constraint->isa('Moose::Meta::TypeConstraint::Parameterized')) {
 123         my $container_type_constraint = $attr->type_constraint->type_parameter;
 124         return sub {
 125             my ( $self, $i, $j, @elems ) = @_;
 126             ($container_type_constraint->check($_))
 127                 || confess "Value " . (defined($_) ? $_ : 'undef') . " did not pass container type constraint" for @elems;
 128             CORE::splice @{$reader->($self)}, $i, $j, @elems;
 129         };
 130     }
 131     else {
 132         return sub {
 133             my ( $self, $i, $j, @elems ) = @_;
 134             CORE::splice @{$reader->($self)}, $i, $j, @elems;
 135         };
 136     }
 137 }
 138
 139 sub sort_in_place : method {
 140     my ($attr, $reader, $writer) = @_;
 141     return sub {
 142         my ($instance, $predicate) = @_;
 143
 144         die "Argument must be a code reference"
 145             if $predicate && ref $predicate ne 'CODE';
 146
 147         my @sorted;
 148         if ($predicate) {
 149             @sorted = CORE::sort { $predicate->($a, $b) } @{$reader->($instance)};
 150         }
 151         else {
 152             @sorted = CORE::sort @{$reader->($instance)};
 153         }
 154
 155         $writer->($instance, \@sorted);
 156     };
 157 }
 158
 159 1;
 160
 161 __END__
 162
 163 =pod
 164
 165 =head1 NAME
 166
 167 MooseX::AttributeHelpers::MethodProvider::Array
 168
 169 =head1 DESCRIPTION
 170
 171 This is a role which provides the method generators for
 172 L<MooseX::AttributeHelpers::Collection::Array>.
 173
 174 =head1 METHODS
 175
 176 =over 4
 177
 178 =item B<meta>
 179
 180 =back
 181
 182 =head1 PROVIDED METHODS
 183
 184 This module also consumes the B<List> method providers, to
 185 see those provied methods, refer to that documentation.
 186
 187 =over 4
 188
 189 =item B<get>
 190
 191 =item B<pop>
 192
 193 =item B<push>
 194
 195 =item B<set>
 196
 197 =item B<shift>
 198
 199 =item B<unshift>
 200
 201 =item B<clear>
 202
 203 =item B<delete>
 204
 205 =item B<insert>
 206
 207 =item B<splice>
 208
 209 =item B<sort_in_place>
 210
 211 Sorts the array I<in place>, modifying the value of the attribute.
 212
 213 You can provide an optional subroutine reference to sort with (as you
 214 can with the core C<sort> function). However, instead of using C<$a>
 215 and C<$b>, you will need to use C<$_[0]> and C<$_[1]> instead.
 216
 217 =back
 218
 219 =head1 BUGS
 220
 221 All complex software has bugs lurking in it, and this module is no
 222 exception. If you find a bug please either email me, or add the bug
 223 to cpan-RT.
 224
 225 =head1 AUTHOR
 226
 227 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 228
 229 =head1 COPYRIGHT AND LICENSE
 230
 231 Copyright 2007-2008 by Infinity Interactive, Inc.
 232
 233 L<http://www.iinteractive.com>
 234
 235 This library is free software; you can redistribute it and/or modify
 236 it under the same terms as Perl itself.
 237
 238 =cut