lib/MooseX/AttributeHelpers/MethodProvider/Array.pm

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