From: Fuji, Goro <gfuji@cpan.org>
Date: Mon, 8 Nov 2010 02:30:43 +0000 (+0900)
Subject: Fix 'Int' type constraint for dualvars (like $!)
X-Git-Tag: 0.83~1
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=gitmo%2FMouse.git;a=commitdiff_plain;h=7f881031a63a80846be81c6f06e7285095582782

Fix 'Int' type constraint for dualvars (like $!)
---

diff --git a/t/001_mouse/071_tc_dualvar.t b/t/001_mouse/071_tc_dualvar.t
new file mode 100644
index 0000000..44f468f
--- /dev/null
+++ b/t/001_mouse/071_tc_dualvar.t
@@ -0,0 +1,30 @@
+#!perl -w
+use strict;
+use Test::More;
+use Errno qw(ENOENT EPERM);
+{
+    package Foo;
+    use Mouse;
+    has intval => (
+        is  => 'rw',
+        isa => 'Int',
+    );
+    has numval => (
+        is  => 'rw',
+        isa => 'Num',
+    );
+}
+
+my $foo = Foo->new();
+
+for my $e(ENOENT, EPERM) {
+    $! = $e;
+    eval { $foo->intval($!) };
+    like $@, qr/Validation failed for 'Int'/, 'Int for dualvar';
+
+    $! = $e;
+    eval { $foo->numval($!) };
+    like $@, qr/Validation failed for 'Num'/, 'Num for dualvar';
+}
+done_testing;
+
diff --git a/xs-src/MouseTypeConstraints.xs b/xs-src/MouseTypeConstraints.xs
index 78ce1fd..f7e99a8 100644
--- a/xs-src/MouseTypeConstraints.xs
+++ b/xs-src/MouseTypeConstraints.xs
@@ -70,21 +70,21 @@ mouse_tc_Bool(pTHX_ SV* const data PERL_UNUSED_DECL, SV* const sv) {
     assert(sv);
 
     if(sv_true(sv)){
-        if(SvIOKp(sv)){
+        if(SvPOKp(sv)){ /* "1" */
+            return SvCUR(sv) == 1 && SvPVX(sv)[0] == '1';
+        }
+        else if(SvIOKp(sv)){
             return SvIVX(sv) == 1;
         }
         else if(SvNOKp(sv)){
             return SvNVX(sv) == 1.0;
         }
-        else if(SvPOKp(sv)){ /* "1" */
-            return SvCUR(sv) == 1 && SvPVX(sv)[0] == '1';
-        }
         else{
             return FALSE;
         }
     }
     else{
-        /* any false value must be boolean */
+        /* any false value is a boolean */
         return TRUE;
     }
 }
@@ -140,18 +140,16 @@ S_nv_is_integer(pTHX_ NV const nv) {
 int
 mouse_tc_Int(pTHX_ SV* const data PERL_UNUSED_DECL, SV* const sv) {
     assert(sv);
-    if(SvIOKp(sv)){
+    if(SvPOKp(sv)){
+        int const num_type = grok_number(SvPVX(sv), SvCUR(sv), NULL);
+        return num_type && !(num_type & IS_NUMBER_NOT_INT);
+    }
+    else if(SvIOKp(sv)){
         return TRUE;
     }
     else if(SvNOKp(sv)) {
         return S_nv_is_integer(aTHX_ SvNVX(sv));
     }
-    else if(SvPOKp(sv)){
-        int const num_type = grok_number(SvPVX(sv), SvCUR(sv), NULL);
-        if(num_type){
-            return !(num_type & IS_NUMBER_NOT_INT);
-        }
-    }
     return FALSE;
 }
 
@@ -162,7 +160,7 @@ mouse_tc_Str(pTHX_ SV* const data PERL_UNUSED_DECL, SV* const sv) {
 }
 
 int
-mouse_tc_ClassName(pTHX_ SV* const data PERL_UNUSED_DECL, SV* const sv){ 
+mouse_tc_ClassName(pTHX_ SV* const data PERL_UNUSED_DECL, SV* const sv){
     assert(sv);
     return is_class_loaded(sv);
 }
@@ -694,7 +692,7 @@ BOOT:
             (SV*)gv_fetchpvs( MTC_CLASS "::(\"\"", GV_ADDMULTI, SVt_PVCV ),
             code_ref );
     }
-            
+
     /* '0+' => '_identity' */
     {
         SV* const code_ref = sv_2mortal(newRV_inc(