lib/MooseX/AttributeHelpers/MethodProvider/Array.pm

   1 package MooseX::AttributeHelpers::MethodProvider::Array;
   2 use Moose::Role;
   3
   4 our $VERSION   = '0.12';
   5 our $AUTHORITY = 'cpan:STEVAN';
   6
   7 with 'MooseX::AttributeHelpers::MethodProvider::List';
   8
   9 sub push : method {
  10     my ($attr, $reader, $writer) = @_;
  11
  12     if ($attr->has_type_constraint && $attr->type_constraint->isa('Moose::Meta::TypeConstraint::Parameterized')) {
  13         my $container_type_constraint = $attr->type_constraint->type_parameter;
  14         return sub {
  15             my $instance = CORE::shift;
  16             $container_type_constraint->check($_)
  17                 || confess "Value " . ($_||'undef') . " did not pass container type constraint"
  18                     foreach @_;
  19             CORE::push @{$reader->($instance)} => @_;
  20         };
  21     }
  22     else {
  23         return sub {
  24             my $instance = CORE::shift;
  25             CORE::push @{$reader->($instance)} => @_;
  26         };
  27     }
  28 }
  29
  30 sub pop : method {
  31     my ($attr, $reader, $writer) = @_;
  32     return sub {
  33         CORE::pop @{$reader->($_[0])}
  34     };
  35 }
  36
  37 sub unshift : method {
  38     my ($attr, $reader, $writer) = @_;
  39     if ($attr->has_type_constraint && $attr->type_constraint->isa('Moose::Meta::TypeConstraint::Parameterized')) {
  40         my $container_type_constraint = $attr->type_constraint->type_parameter;
  41         return sub {
  42             my $instance = CORE::shift;
  43             $container_type_constraint->check($_)
  44                 || confess "Value " . ($_||'undef') . " did not pass container type constraint"
  45                     foreach @_;
  46             CORE::unshift @{$reader->($instance)} => @_;
  47         };
  48     }
  49     else {
  50         return sub {
  51             my $instance = CORE::shift;
  52             CORE::unshift @{$reader->($instance)} => @_;
  53         };
  54     }
  55 }
  56
  57 sub shift : method {
  58     my ($attr, $reader, $writer) = @_;
  59     return sub {
  60         CORE::shift @{$reader->($_[0])}
  61     };
  62 }
  63
  64 sub get : method {
  65     my ($attr, $reader, $writer) = @_;
  66     return sub {
  67         $reader->($_[0])->[$_[1]]
  68     };
  69 }
  70
  71 sub set : method {
  72     my ($attr, $reader, $writer) = @_;
  73     if ($attr->has_type_constraint && $attr->type_constraint->isa('Moose::Meta::TypeConstraint::Parameterized')) {
  74         my $container_type_constraint = $attr->type_constraint->type_parameter;
  75         return sub {
  76             ($container_type_constraint->check($_[2]))
  77                 || confess "Value " . ($_[2]||'undef') . " did not pass container type constraint";
  78             $reader->($_[0])->[$_[1]] = $_[2]
  79         };
  80     }
  81     else {
  82         return sub {
  83             $reader->($_[0])->[$_[1]] = $_[2]
  84         };
  85     }
  86 }
  87
  88 sub clear : method {
  89     my ($attr, $reader, $writer) = @_;
  90     return sub {
  91         @{$reader->($_[0])} = ()
  92     };
  93 }
  94
  95 sub delete : method {
  96     my ($attr, $reader, $writer) = @_;
  97     return sub {
  98         CORE::splice @{$reader->($_[0])}, $_[1], 1;
  99     }
 100 }
 101
 102 sub insert : method {
 103     my ($attr, $reader, $writer) = @_;
 104     if ($attr->has_type_constraint && $attr->type_constraint->isa('Moose::Meta::TypeConstraint::Parameterized')) {
 105         my $container_type_constraint = $attr->type_constraint->type_parameter;
 106         return sub {
 107             ($container_type_constraint->check($_[2]))
 108                 || confess "Value " . ($_[2]||'undef') . " did not pass container type constraint";
 109             CORE::splice @{$reader->($_[0])}, $_[1], 0, $_[2];
 110         };
 111     }
 112     else {
 113         return sub {
 114             CORE::splice @{$reader->($_[0])}, $_[1], 0, $_[2];
 115         };
 116     }
 117 }
 118
 119 sub splice : method {
 120     my ($attr, $reader, $writer) = @_;
 121     if ($attr->has_type_constraint && $attr->type_constraint->isa('Moose::Meta::TypeConstraint::Parameterized')) {
 122         my $container_type_constraint = $attr->type_constraint->type_parameter;
 123         return sub {
 124             my ( $self, $i, $j, @elems ) = @_;
 125             ($container_type_constraint->check($_))
 126                 || confess "Value " . (defined($_) ? $_ : 'undef') . " did not pass container type constraint" for @elems;
 127             CORE::splice @{$self->$reader()}, $i, $j, @elems;
 128         };
 129     }
 130     else {
 131         return sub {
 132             my ( $self, $i, $j, @elems ) = @_;
 133             CORE::splice @{$self->$reader()}, $i, $j, @elems;
 134         };
 135     }
 136 }
 137
 138 1;
 139
 140 __END__
 141
 142 =pod
 143
 144 =head1 NAME
 145
 146 MooseX::AttributeHelpers::MethodProvider::Array
 147
 148 =head1 DESCRIPTION
 149
 150 This is a role which provides the method generators for
 151 L<MooseX::AttributeHelpers::Collection::Array>.
 152
 153 =head1 METHODS
 154
 155 =over 4
 156
 157 =item B<meta>
 158
 159 =back
 160
 161 =head1 PROVIDED METHODS
 162
 163 This module also consumes the B<List> method providers, to
 164 see those provied methods, refer to that documentation.
 165
 166 =over 4
 167
 168 =item B<get>
 169
 170 =item B<pop>
 171
 172 =item B<push>
 173
 174 =item B<set>
 175
 176 =item B<shift>
 177
 178 =item B<unshift>
 179
 180 =item B<clear>
 181
 182 =item B<delete>
 183
 184 =item B<insert>
 185
 186 =item B<splice>
 187
 188 =back
 189
 190 =head1 BUGS
 191
 192 All complex software has bugs lurking in it, and this module is no
 193 exception. If you find a bug please either email me, or add the bug
 194 to cpan-RT.
 195
 196 =head1 AUTHOR
 197
 198 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 199
 200 =head1 COPYRIGHT AND LICENSE
 201
 202 Copyright 2007-2008 by Infinity Interactive, Inc.
 203
 204 L<http://www.iinteractive.com>
 205
 206 This library is free software; you can redistribute it and/or modify
 207 it under the same terms as Perl itself.
 208
 209 =cut