This is an automated email from the git hooks/post-receive script.

js pushed a commit to tag 0.043_03
in repository libtype-tiny-perl.

commit 4a7a29c0b852893cd9d309909655a627805eae73
Author: Toby Inkster <m...@tobyinkster.co.uk>
Date:   Tue Apr 15 12:06:08 2014 +0100

    add Type::Utils::classifier
---
 lib/Type/Utils.pm                 | 39 +++++++++++++++++++++++++++
 t/20-unit/Type-Utils/classifier.t | 56 +++++++++++++++++++++++++++++++++++++++
 2 files changed, 95 insertions(+)

diff --git a/lib/Type/Utils.pm b/lib/Type/Utils.pm
index 01fd405..5a6f378 100644
--- a/lib/Type/Utils.pm
+++ b/lib/Type/Utils.pm
@@ -28,6 +28,7 @@ our @EXPORT_OK = (
                extends type subtype
                match_on_type compile_match_on_type
                dwim_type english_list
+               classifier
        >,
 );
 
@@ -444,6 +445,23 @@ sub compile_match_on_type
        );
 }
 
+sub classifier
+{
+       my $i;
+       compile_match_on_type(
+               +(
+                       map {
+                               my $type = $_->[0];
+                               $type => sub { $type };
+                       }
+                       sort { $b->[1] <=> $a->[1] or $a->[2] <=> $b->[2] }
+                       map [$_, scalar(my @parents = $_->parents), ++$i],
+                       @_
+               ),
+               q[ undef ],
+       );
+}
+
 {
        package #hide
        Type::Registry::DWIM;
@@ -903,6 +921,27 @@ are good for this. (Same sort of idea as L<Type::Params>.)
 
 This function is not exported by default.
 
+=item C<< my $coderef = classifier(@types) >>
+
+Returns a coderef that can be used to classify values according to their
+type constraint. The coderef, when passed a value, returns a type
+constraint which the value satisfies.
+
+   use feature qw( say );
+   use Type::Utils qw( classifier );
+   use Types::Standard qw( Int Num Str Any );
+   
+   my $classifier = classifier(Str, Int, Num, Any);
+   
+   say $classifier->( "42"  )->name;   # Int
+   say $classifier->( "4.2" )->name;   # Num
+   say $classifier->( []    )->name;   # Any
+
+Note that, for example, "42" satisfies Int, but it would satisfy the
+type constraints Num, Str, and Any as well. In this case, the
+classifier has picked the most specific type constraint that "42"
+satisfies.
+
 =item C<< dwim_type($string, %options) >>
 
 Given a string like "ArrayRef[Int|CodeRef]", turns it into a type constraint
diff --git a/t/20-unit/Type-Utils/classifier.t 
b/t/20-unit/Type-Utils/classifier.t
new file mode 100644
index 0000000..37a5f0b
--- /dev/null
+++ b/t/20-unit/Type-Utils/classifier.t
@@ -0,0 +1,56 @@
+=pod
+
+=encoding utf-8
+
+=head1 PURPOSE
+
+Test L<Type::Utils> C<classifier> function.
+
+=head1 AUTHOR
+
+Toby Inkster E<lt>toby...@cpan.orge<gt>.
+
+=head1 COPYRIGHT AND LICENCE
+
+This software is copyright (c) 2014 by Toby Inkster.
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
+
+=cut
+
+use strict;
+use warnings;
+
+use Test::More;
+
+use Type::Utils qw( classifier );
+use Types::Standard -types;
+
+my $classify = classifier(Num, Str, Int, Ref, ArrayRef, HashRef, Any, 
InstanceOf['Type::Tiny']);
+
+sub classified ($$)
+{
+       my $got       = $classify->($_[0]);
+       my $expected  = $_[1];
+       local $Test::Builder::Level = $Test::Builder::Level + 1;
+       is(
+               $got->name,
+               $expected->name,
+               sprintf("%s classified as %s", Type::Tiny::_dd($_[0]), 
$expected),
+       );
+}
+
+classified(42, Int);
+classified(1.1, Num);
+classified("Hello world", Str);
+classified("42", Int);
+classified("1.1", Num);
+classified((\(my $x)), Ref);
+classified([], ArrayRef);
+classified({}, HashRef);
+classified(undef, Any);
+classified(Num, InstanceOf['Type::Tiny']);
+
+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

Reply via email to