lib/MooseX/AttributeHelpers/MethodProvider/Array.pm

   1 package MooseX::AttributeHelpers::MethodProvider::Array;
   2 use Moose::Role;
   3
   4 our $VERSION   = '0.03';
   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_container_type) {
  13         my $container_type_constraint = $attr->container_type_constraint;
  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_container_type) {
  40         my $container_type_constraint = $attr->container_type_constraint;
  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_container_type) {
  74         my $container_type_constraint = $attr->container_type_constraint;
  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_container_type) {
 105         my $container_type_constraint = $attr->container_type_constraint;
 106         return sub {
 107             ($container_type_constraint->check($_[2]))
 108                 || confess "Value " . ($_[2]||'undef') . " did not pass container type constraint";
 109             splice @{$reader->($_[0])}, $_[1], 0, $_[2];
 110         };
 111     }
 112     else {
 113         return sub {
 114             splice @{$reader->($_[0])}, $_[1], 0, $_[2];
 115         };
 116     }
 117 }
 118
 119 1;
 120
 121 __END__
 122
 123 =pod
 124
 125 =head1 NAME
 126
 127 MooseX::AttributeHelpers::MethodProvider::Array
 128
 129 =head1 DESCRIPTION
 130
 131 This is a role which provides the method generators for
 132 L<MooseX::AttributeHelpers::Collection::Array>.
 133
 134 =head1 METHODS
 135
 136 =over 4
 137
 138 =item B<meta>
 139
 140 =back
 141
 142 =head1 PROVIDED METHODS
 143
 144 This module also consumes the B<List> method providers, to
 145 see those provied methods, refer to that documentation.
 146
 147 =over 4
 148
 149 =item B<get>
 150
 151 =item B<pop>
 152
 153 =item B<push>
 154
 155 =item B<set>
 156
 157 =item B<shift>
 158
 159 =item B<unshift>
 160
 161 =item B<clear>
 162
 163 =item B<delete>
 164
 165 =item B<insert>
 166
 167 =back
 168
 169 =head1 BUGS
 170
 171 All complex software has bugs lurking in it, and this module is no
 172 exception. If you find a bug please either email me, or add the bug
 173 to cpan-RT.
 174
 175 =head1 AUTHOR
 176
 177 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 178
 179 =head1 COPYRIGHT AND LICENSE
 180
 181 Copyright 2007 by Infinity Interactive, Inc.
 182
 183 L<http://www.iinteractive.com>
 184
 185 This library is free software; you can redistribute it and/or modify
 186 it under the same terms as Perl itself.
 187
 188 =cut