path: root/lib/MooseX/Role/Matcher.pm

#!/usr/bin/perl
package MooseX::Role::Matcher;
use MooseX::Role::Parameterized;
use List::Util qw/first/;
use List::MoreUtils qw/any all/;

=head1 NAME

MooseX::Role::Matcher - generic object matching based on attributes and methods

=head1 SYNOPSIS

  package Person;
  use Moose;
  with 'MooseX::Role::Matcher' => { default_match => 'name' };

  has name  => (is => 'ro', isa => 'Str');
  has age   => (is => 'ro', isa => 'Num');
  has phone => (is => 'ro', isa => 'Str');

  package main;
  my @people = (
      Person->new(name => 'James', age => 22, phone => '555-1914'),
      Person->new(name => 'Jesse', age => 22, phone => '555-6287'),
      Person->new(name => 'Eric',  age => 21, phone => '555-7634'),
  );

  # is James 22?
  $people[0]->match(age => 22);

  # which people are not 22?
  my @not_twenty_two = Person->grep_matches([@people], '!age' => 22);

  # do any of the 22-year-olds have a phone number ending in 4?
  Person->any_match([@people], age => 22, phone => qr/4$/);

  # does everyone's name start with either J or E?
  Person->all_match([@people], name => [qr/^J/, qr/^E/]);

  # find the first person whose name is 4 characters long (using the
  # default_match of name)
  my $four = Person->first_match([@people], sub { length == 4 });

=head1 DESCRIPTION

This role adds flexible matching and searching capabilities to your Moose
class. It provides a match method, which tests attributes and methods of your
object against strings, regexes, or coderefs, and also provides several class
methods for using match on lists of objects.

=head1 PARAMETERS

MooseX::Role::Matcher is a parameterized role (see
L<MooseX::Role::Parameterized>). The parameters it takes are:

=over

=item default_match

Which attribute/method to test against by default, if none are specified
explicitly. Setting default_match to 'foo' allows using
C<< $obj->match('bar') >> rather than C<< $obj->match(foo => 'bar') >>.

=item allow_missing_methods

If set to true, matching against a method that doesn't exist is treated as though matching against undef. Otherwise, the match call dies.

=back

=cut

parameter default_match => (
    isa => 'Str',
);

parameter allow_missing_methods => (
    isa => 'Bool',
);

role {
my $p = shift;
my $default = $p->default_match;
my $allow_missing_methods = $p->allow_missing_methods;

method _apply_to_matches => sub {
    my $class = shift;
    my $on_match = shift;
    my @list = @{ shift() };
    my @matchers = @_;
    $on_match->(sub { $_->match(@matchers) }, @list);
};

=head1 METHODS

=head2 first_match

  my $four = Person->first_match([@people], sub { length == 4 });

Class method which takes an arrayref of objects in the class that consumed this
role, and calls C<match> on each object in the arrayref, passing it the
remaining arguments, and returns the first object for which match returns true.

=cut

method first_match => sub {
    my $class = shift;
    $class->_apply_to_matches(\&first, @_);
};

=head2 grep_matches

  my @not_twenty_two = Person->grep_matches([@people], '!age' => 22);

Class method which takes an arrayref of objects in the class that consumed this
role, and calls C<match> on each object in the arrayref, passing it the
remaining arguments, and returns the each object for which match returns true.

=cut

method grep_matches => sub {
    my $class = shift;
    my $grep = sub { my $code = shift; grep { $code->() } @_ };
    $class->_apply_to_matches($grep, @_);
};

=head2 any_match

  Person->any_match([@people], age => 22, number => qr/4$/);

Class method which takes an arrayref of objects in the class that consumed this
role, and calls C<match> on each object in the arrayref, passing it the
remaining arguments, and returns true if any C<match> calls return true,
otherwise returns false.

=cut

method any_match => sub {
    my $class = shift;
    $class->_apply_to_matches(\&any, @_);
};

=head2 all_match

  Person->all_match([@people], name => [qr/^J/, qr/^E/]);

Class method which takes an arrayref of objects in the class that consumed this
role, and calls C<match> on each object in the arrayref, passing it the
remaining arguments, and returns false if any C<match> calls return false,
otherwise returns true.

=cut

method all_match => sub {
    my $class = shift;
    $class->_apply_to_matches(\&all, @_);
};

method _match => sub {
    my $self = shift;
    my $value = shift;
    my $seek = shift;

    # first check seek types that could match undef
    if (!defined $seek) {
        return !defined $value;
    }
    elsif (ref($seek) eq 'CODE') {
        local $_ = $value;
        return $seek->();
    }
    elsif (ref($seek) eq 'ARRAY') {
        for (@$seek) {
            return 1 if $self->_match($value => $_);
        }
        return 0;
    }
    # then bail out if we still have an undef value
    elsif (!defined $value) {
        return 0;
    }
    # and now check seek types that would error with an undef value
    elsif (ref($seek) eq 'Regexp') {
        return $value =~ $seek;
    }
    elsif (ref($seek) eq 'HASH') {
        return 0 unless blessed($value) &&
                        $value->does('MooseX::Role::Matcher');
        return $value->match(%$seek);
    }
    return $value eq $seek;
};

=head2 match

  $person->match(age => 22);

This method provides the majority of the functionality of this role. It accepts
a hash of arguments, with keys being the methods (usually attributes) of the
object to be tested, and values being things to test against them. Possible
types of values are:

=over

=item SCALAR

Returns true if the result of the method is equal to (C<eq>) the value of the
scalar, otherwise returns false.

=item REGEXP

Returns true if the result of the method matches the regexp, otherwise returns
false.

=item CODEREF

Calls the coderef with C<$_> set to the result of the method, returning true if
the coderef returns true, and false otherwise.

=item UNDEF

Returns true if the method returns undef, or if the object doesn't have a
method by this name, otherwise returns false.

=item ARRAYREF

Matches the result of the method against each element in the arrayref as
described above, returning true if any of the submatches return true, and false
otherwise.

=item HASHREF

If the method does not return an object which does MooseX::Role::Matcher,
returns false. Otherwise, returns the result of calling C<match> on the
returned object, with the contents of the hashref as arguments.

=back

Method names can also be given with a leading '!', which inverts that test. The first key can be omitted from the argument list if it is the method name passed to the default_match parameter when composing this role.

=cut

method match => sub {
    my $self = shift;
    unshift @_, $default if @_ % 2 == 1;
    my %args = @_;

    # All the conditions must be true for true to be returned. Return
    # immediately if a false condition is found.
    for my $matcher (keys %args) {
        my ($invert, $name) = $matcher =~ /^(!)?(.*)$/;
        confess blessed($self) . " has no method named $name"
            unless $self->can($name) || $allow_missing_methods;
        my $value = $self->can($name) ? $self->$name : undef;
        my $seek = $args{$matcher};

        my $matched = $self->_match($value => $seek) ? 1 : 0;

        if ($invert) {
            return 0 if $matched;
        }
        else {
            return 0 unless $matched;
        }
    }

    return 1;
};

};

no MooseX::Role::Parameterized;

=head1 AUTHOR

  Jesse Luehrs <doy at tozt dot net>

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2008-2009 by Jesse Luehrs.

This is free software; you can redistribute it and/or modify it under
the same terms as perl itself.

=head1 TODO

Better error handling/reporting

=head1 SEE ALSO

L<Moose>

L<MooseX::Role::Parameterized>

=head1 BUGS

No known bugs.

Please report any bugs through RT: email
C<bug-moosex-role-matcher at rt.cpan.org>, or browse to
L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=MooseX-Role-Matcher>.

=head1 SUPPORT

You can find this documentation for this module with the perldoc command.

    perldoc MooseX::Role::Matcher

You can also look for information at:

=over 4

=item * AnnoCPAN: Annotated CPAN documentation

L<http://annocpan.org/dist/MooseX-Role-Matcher>

=item * CPAN Ratings

L<http://cpanratings.perl.org/d/MooseX-Role-Matcher>

=item * RT: CPAN's request tracker

L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=MooseX-Role-Matcher>

=item * Search CPAN

L<http://search.cpan.org/dist/MooseX-Role-Matcher>

=back

=cut

1;