diff options
author | doy <doy@tozt.net> | 2008-12-05 21:39:31 -0500 |
---|---|---|
committer | doy <doy@tozt.net> | 2008-12-05 21:39:31 -0500 |
commit | 38889135a5f0854f07490c23b2e077e0893bf212 (patch) | |
tree | 788d4b3e557e2ef3ce008b66db31e90d59b9274e /lib/MooseX | |
download | moosex-role-matcher-38889135a5f0854f07490c23b2e077e0893bf212.tar.gz moosex-role-matcher-38889135a5f0854f07490c23b2e077e0893bf212.zip |
initial copy/paste from taeb
Diffstat (limited to 'lib/MooseX')
-rw-r--r-- | lib/MooseX/Role/Searchable.pm | 87 |
1 files changed, 87 insertions, 0 deletions
diff --git a/lib/MooseX/Role/Searchable.pm b/lib/MooseX/Role/Searchable.pm new file mode 100644 index 0000000..3ec380a --- /dev/null +++ b/lib/MooseX/Role/Searchable.pm @@ -0,0 +1,87 @@ +#!/usr/bin/perl +package MooseX::Role::Searchable; +use Moose::Role; +use List::Util qw/first/; +use List::MoreUtils qw/any apply/; + +sub _apply_to_matches { + my $on_match = shift; + my $code = shift; + my $matcher = shift; + + # pass in a coderef? return the first for which the coderef is true + if (ref($matcher) eq 'CODE') { + return $on_match->(sub { $code->($_) }, (grep { $matcher->($_) } @_)); + } + + # pass in a regex? return the first item for which the regex matches ID + if (ref($matcher) eq 'Regexp') { + return $on_match->(sub { $code->($_) }, (grep { $_->match(identity => $matcher) } @_)); + } + + my $value = shift; + + return $on_match->(sub { $code->($_) }, (grep { $_->match($matcher => $value) } @_)); +} + +sub first_match { + _apply_to_matches(\&first, @_); +} + +sub each_match { + _apply_to_matches(\&apply, @_); +} + +sub grep_matches { + # XXX: can you use grep like this? + _apply_to_matches(\&grep, @_); +} + +sub any_match { + _apply_to_matches(\&any, @_); +} + +sub _match { + my $self = shift; + my $value = shift; + my $seek = shift; + + return !defined $value if !defined $seek; + return 0 if !defined $value; + return $value =~ $seek if ref($seek) eq 'Regexp'; + return $seek->($value) if ref($seek) eq 'CODE'; + if (ref($seek) eq 'ARRAY') { + for (@$seek) { + return 1 if $self->_match($value => $_); + } + } + return $value eq $seek; +} + +sub match { + my $self = shift; + 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 =~ /^(not_)?(.*)$/; + 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 Moose::Role; + +1; |