[libtype-tiny-perl] 02/04: to_TypeTiny($coderef) wraps calls to the coderef in an eval and another layer of sub; this prevented Type::Tiny from spotting Sub::Quote quoted subs. to_TypeTiny can now handle quoted subs explicitly, inlining the eval.

[Jonas Smedegaard]

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

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

commit 35e7b9b44c83b462a47414fdb3de5dccac70261f
Author: Toby Inkster <m...@tobyinkster.co.uk>
Date:   Sat Apr 5 11:57:36 2014 +0100

    to_TypeTiny($coderef) wraps calls to the coderef in an eval and another 
layer of sub; this prevented Type::Tiny from spotting Sub::Quote quoted subs. 
to_TypeTiny can now handle quoted subs explicitly, inlining the eval.
---
 lib/Types/TypeTiny.pm              | 17 +++++++++++++++++
 t/30-integration/Sub-Quote/basic.t | 12 +++++++++++-
 2 files changed, 28 insertions(+), 1 deletion(-)

diff --git a/lib/Types/TypeTiny.pm b/lib/Types/TypeTiny.pm
index bcc4afd..3d5667a 100644
--- a/lib/Types/TypeTiny.pm
+++ b/lib/Types/TypeTiny.pm
@@ -275,6 +275,7 @@ sub _TypeTinyFromGeneric
        return $new;
 }
 
+my $QFS;
 sub _TypeTinyFromCodeRef
 {
        my $t = $_[0];
@@ -289,6 +290,22 @@ sub _TypeTinyFromCodeRef
                        return sprintf('%s did not pass type constraint', 
Type::Tiny::_dd($_));
                },
        );
+       
+       if ($QFS ||= "Sub::Quote"->can("quoted_from_sub"))
+       {
+               my (undef, $perlstring, $captures) = @{ $QFS->($t) || [] };
+               $perlstring = "!!eval{ $perlstring }";
+               $opts{inlined} = sub
+               {
+                       my $var = $_[1];
+                       Sub::Quote::inlinify(
+                               $perlstring,
+                               $var,
+                               $var eq q($_) ? '' : "local \$_ = $var;",
+                               1,
+                       );
+               } if $perlstring && !$captures;
+       }
 
        require Type::Tiny;
        my $new = "Type::Tiny"->new(%opts);
diff --git a/t/30-integration/Sub-Quote/basic.t 
b/t/30-integration/Sub-Quote/basic.t
index bfb8245..0040d8f 100644
--- a/t/30-integration/Sub-Quote/basic.t
+++ b/t/30-integration/Sub-Quote/basic.t
@@ -33,7 +33,7 @@ use Test::TypeTiny;
 
 use Sub::Quote;
 use Type::Tiny;
-use Types::Standard qw(Int);
+use Types::Standard qw( ArrayRef Int );
 
 my $Type1 = "Type::Tiny"->new(
        name       => "Type1",
@@ -105,4 +105,14 @@ should_pass(43, $Type6);
 should_fail(44.4, $Type6);
 ok(!$Type6->can_be_inlined, 'constraint built using quote_sub and 
non-inlinable parent cannot be inlined');
 
+my $Type7 = ArrayRef([Int]) & quote_sub q{ @$_ > 1 and @$_ < 4 };
+
+should_pass([1,2,3], $Type7);
+should_fail([1,2.1,3], $Type7);
+should_fail([1], $Type7);
+should_fail([1,2,3,4], $Type7);
+ok($Type7->can_be_inlined, 'constraint built as an intersection of an 
inlinable type constraint and a quoted sub can be inlined');
+
+note($Type7->inline_check('$VAR'));
+
 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