lib/MooseX/AttributeHelpers/MethodProvider/List.pm

   1 package MooseX::AttributeHelpers::MethodProvider::List;
   2 use Moose::Role;
   3
   4 our $VERSION   = '0.14';
   5 $VERSION = eval $VERSION;
   6 our $AUTHORITY = 'cpan:STEVAN';
   7
   8 sub count : method {
   9     my ($attr, $reader, $writer) = @_;
  10     return sub {
  11         scalar @{$reader->($_[0])}
  12     };
  13 }
  14
  15 sub empty : method {
  16     my ($attr, $reader, $writer) = @_;
  17     return sub {
  18         scalar @{$reader->($_[0])} ? 1 : 0
  19     };
  20 }
  21
  22 sub find : method {
  23     my ($attr, $reader, $writer) = @_;
  24     return sub {
  25         my ($instance, $predicate) = @_;
  26         foreach my $val (@{$reader->($instance)}) {
  27             return $val if $predicate->($val);
  28         }
  29         return;
  30     };
  31 }
  32
  33 sub map : method {
  34     my ($attr, $reader, $writer) = @_;
  35     return sub {
  36         my ($instance, $f) = @_;
  37         CORE::map { $f->($_) } @{$reader->($instance)}
  38     };
  39 }
  40
  41 sub sort : method {
  42     my ($attr, $reader, $writer) = @_;
  43     return sub {
  44         my ($instance, $predicate) = @_;
  45         die "Argument must be a code reference"
  46             unless ref $predicate eq "CODE";
  47         CORE::sort { $predicate->($a, $b) } @{$reader->($instance)};
  48     };
  49 }
  50
  51 sub grep : method {
  52     my ($attr, $reader, $writer) = @_;
  53     return sub {
  54         my ($instance, $predicate) = @_;
  55         CORE::grep { $predicate->($_) } @{$reader->($instance)}
  56     };
  57 }
  58
  59 sub elements : method {
  60     my ($attr, $reader, $writer) = @_;
  61     return sub {
  62         my ($instance) = @_;
  63         @{$reader->($instance)}
  64     };
  65 }
  66
  67 sub join : method {
  68     my ($attr, $reader, $writer) = @_;
  69     return sub {
  70         my ($instance, $separator) = @_;
  71         join $separator, @{$reader->($instance)}
  72     };
  73 }
  74
  75 sub get : method {
  76     my ($attr, $reader, $writer) = @_;
  77     return sub {
  78         $reader->($_[0])->[$_[1]]
  79     };
  80 }
  81
  82 sub first : method {
  83     my ($attr, $reader, $writer) = @_;
  84     return sub {
  85         $reader->($_[0])->[0]
  86     };
  87 }
  88
  89 sub last : method {
  90     my ($attr, $reader, $writer) = @_;
  91     return sub {
  92         $reader->($_[0])->[-1]
  93     };
  94 }
  95
  96 1;
  97
  98 __END__
  99
 100 =pod
 101
 102 =head1 NAME
 103
 104 MooseX::AttributeHelpers::MethodProvider::List
 105
 106 =head1 SYNOPSIS
 107
 108    package Stuff;
 109    use Moose;
 110    use MooseX::AttributeHelpers;
 111
 112    has 'options' => (
 113       metaclass  => 'Collection::List',
 114       is         => 'rw',
 115       isa        => 'ArrayRef[Str]',
 116       default    => sub { [] },
 117       auto_deref => 1,
 118       provides   => {
 119          map   => 'map_options',
 120          grep  => 'filter_options',
 121          find  => 'find_option',
 122          first => 'first_option',
 123          last  => 'last_option',
 124          get   => 'get_option',
 125          join  => 'join_options',
 126          count => 'count_options',
 127          empty => 'do_i_have_options',
 128          sort  => 'sort_options',
 129
 130       }
 131    );
 132
 133    no Moose;
 134    1;
 135
 136 =head1 DESCRIPTION
 137
 138 This is a role which provides the method generators for
 139 L<MooseX::AttributeHelpers::Collection::List>.
 140
 141 =head1 METHODS
 142
 143 =over 4
 144
 145 =item B<meta>
 146
 147 =back
 148
 149 =head1 PROVIDED METHODS
 150
 151 =over 4
 152
 153 =item B<count>
 154 Returns the number of elements of the list.
 155
 156    $stuff = Stuff->new;
 157    $stuff->options(["foo", "bar", "baz", "boo"]);
 158
 159    my $count = $stuff->count_options;
 160    print "$count\n"; # prints 4
 161
 162 =item B<empty>
 163 If the list is populated, returns true. Otherwise, returns false.
 164
 165    $stuff->do_i_have_options ? print "Good boy.\n" : die "No options!\n" ;
 166
 167 =item B<find>
 168 Returns the first element that returns true in the anonymous subroutine
 169 passed as argument.
 170
 171    my $found = $stuff->find_option( sub { $_[0] =~ /^b/ } );
 172    print "$found\n"; # prints "bar"
 173
 174 =item B<grep>
 175 Returns every element of the list that returns true in the anonymous
 176 subroutine passed as argument.
 177
 178    my @found = $stuff->filter_options( sub { $_[0] =~ /^b/ } );
 179    print "@found\n"; # prints "bar baz boo"
 180
 181 =item B<map>
 182 Executes the anonymous subroutine given as argument sequentially
 183 for each element of the list.
 184
 185    my @mod_options = $stuff->map_options( sub { $_[0] . "-tag" } );
 186    print "@mod_options\n"; # prints "foo-tag bar-tag baz-tag boo-tag"
 187
 188 =item B<sort>
 189 Returns a sorted list of the elements, using the anonymous subroutine
 190 given as argument.
 191
 192 This subroutine should perform a comparison between the two arguments passed
 193 to it, and return a numeric list with the results of such comparison:
 194
 195    # Descending alphabetical order
 196    my @sorted_options = $stuff->sort_options( sub { $_[1] cmp $_[0] } );
 197    print "@sorted_options\n"; # prints "foo boo baz bar"
 198
 199 =item B<elements>
 200 Returns an element of the list by its index.
 201
 202    my $option = $stuff->get_option(1);
 203    print "$option\n"; # prints "bar"
 204
 205 =item B<join>
 206 Joins every element of the list using the separator given as argument.
 207
 208    my $joined = $stuff->join_options( ':' );
 209    print "$joined\n"; # prints "foo:bar:baz:boo"
 210
 211 =item B<get>
 212 Returns an element of the list by its index.
 213
 214    my $option = $stuff->get_option(1);
 215    print "$option\n"; # prints "bar"
 216
 217 =item B<first>
 218 Returns the first element.
 219
 220    my $first = $stuff->first_option;
 221    print "$first\n"; # prints "foo"
 222
 223 =item B<last>
 224 Returns the last item.
 225
 226    my $last = $stuff->last_option;
 227    print "$last\n"; # prints "boo"
 228
 229 =back
 230
 231 =head1 BUGS
 232
 233 All complex software has bugs lurking in it, and this module is no
 234 exception. If you find a bug please either email me, or add the bug
 235 to cpan-RT.
 236
 237 =head1 AUTHOR
 238
 239 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 240
 241 =head1 COPYRIGHT AND LICENSE
 242
 243 Copyright 2007-2008 by Infinity Interactive, Inc.
 244
 245 L<http://www.iinteractive.com>
 246
 247 This library is free software; you can redistribute it and/or modify
 248 it under the same terms as Perl itself.
 249
 250 =cut