From: Fuji, Goro <gfuji@cpan.org>
Date: Wed, 22 Sep 2010 16:07:55 +0000 (+0900)
Subject: Move overload stuff to XS
X-Git-Tag: 0.71~36
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=6e647cac2be257e5058f04188a5b1ff8b7281069;p=gitmo%2FMouse.git

Move overload stuff to XS
---

diff --git a/lib/Mouse/Meta/TypeConstraint.pm b/lib/Mouse/Meta/TypeConstraint.pm
index c889401..44e2eae 100644
--- a/lib/Mouse/Meta/TypeConstraint.pm
+++ b/lib/Mouse/Meta/TypeConstraint.pm
@@ -2,19 +2,6 @@ package Mouse::Meta::TypeConstraint;
 use Mouse::Util qw(:meta); # enables strict and warnings
 use Scalar::Util ();
 
-use overload
-    'bool'   => sub (){ 1 },           # always true
-    '""'     => sub { $_[0]->name },   # stringify to tc name
-    '0+'     => sub { Scalar::Util::refaddr($_[0]) },
-    '|'      => sub {                  # or-combination
-        require Mouse::Util::TypeConstraints;
-        return Mouse::Util::TypeConstraints::find_or_parse_type_constraint(
-            "$_[0] | $_[1]",
-        );
-    },
-
-    fallback => 1;
-
 sub new {
     my $class = shift;
     my %args  = @_ == 1 ? %{$_[0]} : @_;
@@ -166,7 +153,12 @@ sub get_message {
         return $msg->($value);
     }
     else {
-        $value = ( defined $value ? overload::StrVal($value) : 'undef' );
+        if(not defined $value) {
+            $value = 'undef';
+        }
+        elsif( ref($value) && defined(&overload::StrVal) ) {
+            $value = overload::StrVal($value);
+        }
         return "Validation failed for '$self' with value $value";
     }
 }
@@ -225,6 +217,17 @@ sub assert_valid {
     return 1;
 }
 
+sub _as_string { $_[0]->name                  } # overload ""
+sub _identity  { Scalar::Util::refaddr($_[0]) } # overload 0+
+
+sub _unite { # overload infix:<|>
+    my($lhs, $rhs) = @_;
+    require Mouse::Util::TypeConstraints;
+    return Mouse::Util::TypeConstraints::find_or_parse_type_constraint(
+       " $lhs | $rhs",
+    );
+}
+
 sub throw_error {
     require Mouse::Meta::Module;
     goto &Mouse::Meta::Module::throw_error;
diff --git a/lib/Mouse/PurePerl.pm b/lib/Mouse/PurePerl.pm
index 5b32267..432d4c7 100644
--- a/lib/Mouse/PurePerl.pm
+++ b/lib/Mouse/PurePerl.pm
@@ -628,6 +628,13 @@ sub _process_options{
 
 package Mouse::Meta::TypeConstraint;
 
+use overload
+    '""' => '_as_string',
+    '0=' => '_identity',
+    '|'  => '_unite',
+
+    fallback => 1;
+
 sub name    { $_[0]->{name}    }
 sub parent  { $_[0]->{parent}  }
 sub message { $_[0]->{message} }
diff --git a/xs-src/MouseTypeConstraints.xs b/xs-src/MouseTypeConstraints.xs
index 1001fbd..57ed21a 100644
--- a/xs-src/MouseTypeConstraints.xs
+++ b/xs-src/MouseTypeConstraints.xs
@@ -1,5 +1,7 @@
 /*
- *   full definition of built-in type constraints (ware in Moose::Util::TypeConstraints::OptimizedConstraints)
+ * TypeConstraint stuff
+ *  - Mouse::Util::TypeConstraints (including OptimizedConstraionts)
+ *  - Mouse::Meta::TypeConstraint
  */
 
 #include "mouse.h"
@@ -559,6 +561,14 @@ XS(XS_Mouse_constraint_check) {
     XSRETURN(1);
 }
 
+XS(XS_Mouse_TypeConstraint_fallback); /* -Wmissing-prototypes */
+XS(XS_Mouse_TypeConstraint_fallback) {
+    dXSARGS;
+    PERL_UNUSED_VAR(cv);
+    PERL_UNUSED_VAR(items);
+    XSRETURN_EMPTY;
+}
+
 static void
 setup_my_cxt(pTHX_ pMY_CXT){
     MY_CXT.universal_isa = gv_fetchpvs("UNIVERSAL::isa", GV_ADD, SVt_PVCV);
@@ -570,6 +580,8 @@ setup_my_cxt(pTHX_ pMY_CXT){
 
 #define DEFINE_TC(name) mouse_tc_generate(aTHX_ "Mouse::Util::TypeConstraints::" STRINGIFY(name), CAT2(mouse_tc_, name), NULL)
 
+#define MTC_CLASS "Mouse::Meta::TypeConstraint"
+
 MODULE = Mouse::Util::TypeConstraints    PACKAGE = Mouse::Util::TypeConstraints
 
 PROTOTYPES:   DISABLE
@@ -663,6 +675,45 @@ BOOT:
     INSTALL_SIMPLE_PREDICATE_WITH_KEY(TypeConstraint, has_coercion, _compiled_type_coercion);
     INSTALL_SIMPLE_PREDICATE_WITH_KEY(TypeConstraint, __is_parameterized, type_parameter); /* Mouse specific */
 
+    /* overload stuff */
+    PL_amagic_generation++;
+    (void)newXS( MTC_CLASS "::()",
+        XS_Mouse_TypeConstraint_fallback, file);
+
+    /* fallback => 1 */
+    sv_setsv(
+        get_sv( MTC_CLASS "::()", GV_ADD ),
+        &PL_sv_yes
+    );
+
+    /* '""' => '_as_string' */
+    {
+        SV* const code_ref = sv_2mortal(newRV_inc(
+            (SV*)get_cv( MTC_CLASS "::_as_string", GV_ADD )));
+        sv_setsv_mg(
+            (SV*)gv_fetchpvs( MTC_CLASS "::(\"\"", GV_ADDMULTI, SVt_PVCV ),
+            code_ref );
+    }
+            
+    /* '0+' => '_identity' */
+    {
+        SV* const code_ref = sv_2mortal(newRV_inc(
+            (SV*)get_cv( MTC_CLASS "::_identity", GV_ADD )));
+        sv_setsv_mg(
+            (SV*)gv_fetchpvs( MTC_CLASS "::(0+", GV_ADDMULTI, SVt_PVCV ),
+            code_ref );
+    }
+
+    /* '|' => '_unite' */
+    {
+        SV* const code_ref = sv_2mortal(newRV_inc(
+            (SV*)get_cv( MTC_CLASS "::_unite", GV_ADD )));
+        sv_setsv_mg(
+            (SV*)gv_fetchpvs( MTC_CLASS "::(|", GV_ADDMULTI, SVt_PVCV ),
+            code_ref );
+    }
+
+
 void
 compile_type_constraint(SV* self)
 CODE: