This is an automated email from the git hooks/post-receive script.
js pushed a commit to tag 0.043_02
in repository libtype-tiny-perl.
commit 01413879c0fb9acbcacc7b2c0e3d618a11742440
Author: Toby Inkster <m...@tobyinkster.co.uk>
Date: Fri Apr 11 23:10:09 2014 +0100
Implement a find_parent method.
---
lib/Type/Tiny.pm | 34 ++++++++++++++++++++++++++++++++++
t/20-unit/Type-Tiny/basic.t | 20 ++++++++++++++++++++
2 files changed, 54 insertions(+)
diff --git a/lib/Type/Tiny.pm b/lib/Type/Tiny.pm
index 64d6efa..ee960ac 100644
--- a/lib/Type/Tiny.pm
+++ b/lib/Type/Tiny.pm
@@ -490,6 +490,30 @@ sub parents
return ($self->parent, $self->parent->parents);
}
+sub find_parent
+{
+ my $self = shift;
+ my ($test) = @_;
+
+ local ($_, $.);
+ my $type = $self;
+ my $count = 0;
+ while ($type)
+ {
+ if ($test->($_=$type, $.=$count))
+ {
+ return wantarray ? ($type, $count) : $type;
+ }
+ else
+ {
+ $type = $type->parent;
+ $count++;
+ }
+ }
+
+ return;
+}
+
sub check
{
my $self = shift;
@@ -1484,6 +1508,16 @@ place where multiple type constraints are returned; and
they are returned
as an arrayref in violation of the base class' documentation. I'm keeping
my behaviour as it seems more useful. >>
+=item C<< find_parent($coderef) >>
+
+Loops through the parent type constraints I<< including the invocant
+itself >> and returns the nearest ancestor type constraint where the
+coderef evaluates to true. Within the coderef the ancestor currently
+being checked is C<< $_ >>. Returns undef if there is no match.
+
+In list context also returns the number of type constraints which had
+been looped through before the matching constraint was found.
+
=item C<< coercibles >>
Return a type constraint which is the union of type constraints that can be
diff --git a/t/20-unit/Type-Tiny/basic.t b/t/20-unit/Type-Tiny/basic.t
index 4130464..461dd84 100644
--- a/t/20-unit/Type-Tiny/basic.t
+++ b/t/20-unit/Type-Tiny/basic.t
@@ -136,4 +136,24 @@ use Types::Standard ();
);
}
+my $t1 = Types::Standard::Int;
+my $t2 = $t1->create_child_type(name => 'T2');
+my $t3 = $t2->create_child_type(name => 'T3');
+my $t4 = $t3->create_child_type(name => 'T4');
+my $t5 = $t4->create_child_type(name => 'T5');
+my $t6 = $t5->create_child_type(name => 'T6');
+
+my $found = $t6->find_parent(sub {
+ $_->has_parent and $_->parent->name eq 'Int'
+});
+
+is($found->name, 'T2', 'find_parent (scalar context)');
+
+my ($found2, $n) = $t6->find_parent(sub {
+ $_->has_parent and $_->parent->name eq 'Int'
+});
+
+is($found2->name, 'T2', 'find_parent (list context)');
+is($n, 4, '... includes a count');
+
done_testing;
--
Alioth's /usr/local/bin/git-commit-notice on
/srv/git.debian.org/git/pkg-perl/packages/libtype-tiny-perl.git
_______________________________________________
Pkg-perl-cvs-commits mailing list
Pkg-perl-cvs-commits@lists.alioth.debian.org
http://lists.alioth.debian.org/cgi-bin/mailman/listinfo/pkg-perl-cvs-commits
