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