lib/MooseX/AttributeHelpers/MethodProvider/Array.pm

   1 package MooseX::AttributeHelpers::MethodProvider::Array;
   2 use Moose::Role;
   3
   4 our $VERSION   = '0.14';
   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 @{$self->$reader()}, $i, $j, @elems;
 129         };
 130     }
 131     else {
 132         return sub {
 133             my ( $self, $i, $j, @elems ) = @_;
 134             CORE::splice @{$self->$reader()}, $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       die "Argument must be a code reference"
 144          unless ref $predicate eq "CODE";
 145       my @sorted =
 146          CORE::sort { $predicate->($a, $b) } @{$reader->($instance)};
 147       $writer->($instance, \@sorted);
 148    }
 149 }
 150
 151 1;
 152
 153 __END__
 154
 155 =pod
 156
 157 =head1 NAME
 158
 159 MooseX::AttributeHelpers::MethodProvider::Array
 160
 161 =head1 DESCRIPTION
 162
 163 This is a role which provides the method generators for
 164 L<MooseX::AttributeHelpers::Collection::Array>.
 165
 166 =head1 METHODS
 167
 168 =over 4
 169
 170 =item B<meta>
 171
 172 =back
 173
 174 =head1 PROVIDED METHODS
 175
 176 This module also consumes the B<List> method providers, to
 177 see those provied methods, refer to that documentation.
 178
 179 =over 4
 180
 181 =item B<get>
 182
 183 =item B<pop>
 184
 185 =item B<push>
 186
 187 =item B<set>
 188
 189 =item B<shift>
 190
 191 =item B<unshift>
 192
 193 =item B<clear>
 194
 195 =item B<delete>
 196
 197 =item B<insert>
 198
 199 =item B<splice>
 200
 201 =item B<sort_in_place>
 202 Sorts the array using the comparison subroutine given as argument.
 203 Instead of returning the sorted list, it modifies the order of the
 204 items in the ArrayRef attribute.
 205
 206 =back
 207
 208 =head1 BUGS
 209
 210 All complex software has bugs lurking in it, and this module is no
 211 exception. If you find a bug please either email me, or add the bug
 212 to cpan-RT.
 213
 214 =head1 AUTHOR
 215
 216 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 217
 218 =head1 COPYRIGHT AND LICENSE
 219
 220 Copyright 2007-2008 by Infinity Interactive, Inc.
 221
 222 L<http://www.iinteractive.com>
 223
 224 This library is free software; you can redistribute it and/or modify
 225 it under the same terms as Perl itself.
 226
 227 =cut