lib/MooseX/AttributeHelpers/MethodProvider/Array.pm

   1 package MooseX::AttributeHelpers::MethodProvider::Array;
   2 use Moose::Role;
   3
   4 our $VERSION   = '0.13';
   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 1;
 140
 141 __END__
 142
 143 =pod
 144
 145 =head1 NAME
 146
 147 MooseX::AttributeHelpers::MethodProvider::Array
 148
 149 =head1 DESCRIPTION
 150
 151 This is a role which provides the method generators for
 152 L<MooseX::AttributeHelpers::Collection::Array>.
 153
 154 =head1 METHODS
 155
 156 =over 4
 157
 158 =item B<meta>
 159
 160 =back
 161
 162 =head1 PROVIDED METHODS
 163
 164 This module also consumes the B<List> method providers, to
 165 see those provied methods, refer to that documentation.
 166
 167 =over 4
 168
 169 =item B<get>
 170
 171 =item B<pop>
 172
 173 =item B<push>
 174
 175 =item B<set>
 176
 177 =item B<shift>
 178
 179 =item B<unshift>
 180
 181 =item B<clear>
 182
 183 =item B<delete>
 184
 185 =item B<insert>
 186
 187 =item B<splice>
 188
 189 =back
 190
 191 =head1 BUGS
 192
 193 All complex software has bugs lurking in it, and this module is no
 194 exception. If you find a bug please either email me, or add the bug
 195 to cpan-RT.
 196
 197 =head1 AUTHOR
 198
 199 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 200
 201 =head1 COPYRIGHT AND LICENSE
 202
 203 Copyright 2007-2008 by Infinity Interactive, Inc.
 204
 205 L<http://www.iinteractive.com>
 206
 207 This library is free software; you can redistribute it and/or modify
 208 it under the same terms as Perl itself.
 209
 210 =cut