From: gfx <gfuji@cpan.org>
Date: Wed, 9 Dec 2009 11:54:54 +0000 (+0900)
Subject: Add duck_type to Mouse::Util::TypeConstraints
X-Git-Tag: 0.44~9
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=ebe91068002fbe34a924a0a9e2cd79553867938c;p=gitmo%2FMouse.git

Add duck_type to Mouse::Util::TypeConstraints
---

diff --git a/lib/Mouse/PurePerl.pm b/lib/Mouse/PurePerl.pm
index 1f77bf0..fc6b457 100644
--- a/lib/Mouse/PurePerl.pm
+++ b/lib/Mouse/PurePerl.pm
@@ -97,6 +97,32 @@ sub generate_isa_predicate_for {
     return $predicate;
 }
 
+sub generate_can_predicate_for {
+    my($methods_ref, $name) = @_;
+
+    my @methods = @{$methods_ref};
+
+    my $predicate = sub{
+        my($instance) = @_;
+        if(Scalar::Util::blessed($instance)){
+            foreach my $method(@methods){
+                if(!$instance->can($method)){
+                    return 0;
+                }
+            }
+            return 1;
+        }
+        return 0;
+    };
+
+    if(defined $name){
+        no strict 'refs';
+        *{ caller() . '::' . $name } = $predicate;
+        return;
+    }
+
+    return $predicate;
+}
 
 package
     Mouse::Util::TypeConstraints;
diff --git a/lib/Mouse/Util/TypeConstraints.pm b/lib/Mouse/Util/TypeConstraints.pm
index 2b2d558..fc99aa8 100644
--- a/lib/Mouse/Util/TypeConstraints.pm
+++ b/lib/Mouse/Util/TypeConstraints.pm
@@ -11,7 +11,11 @@ Mouse::Exporter->setup_import_methods(
     as_is => [qw(
         as where message optimize_as
         from via
-        type subtype coerce class_type role_type enum
+
+        type subtype class_type role_type duck_type
+        enum
+        coerce
+
         find_type_constraint
     )],
 );
@@ -172,6 +176,22 @@ sub role_type {
     );
 }
 
+sub duck_type {
+    my($name, @methods);
+
+    if(!(@_ == 1 && ref($_[0]) eq 'ARRAY')){
+        $name = shift;
+    }
+
+    @methods = (@_ == 1 && ref($_[0]) eq 'ARRAY') ? @{$_[0]} : @_;
+
+    return _create_type 'type', $name => (
+        optimized_as => Mouse::Util::generate_can_predicate_for(\@methods),
+
+        type => 'DuckType',
+    );
+}
+
 sub typecast_constraints { # DEPRECATED
     my($class, $pkg, $type, $value) = @_;
     Carp::croak("wrong arguments count") unless @_ == 4;
diff --git a/mouse.h b/mouse.h
index efed6ca..f30029f 100644
--- a/mouse.h
+++ b/mouse.h
@@ -201,6 +201,7 @@ int mouse_tc_FileHandle(pTHX_ SV*, SV* const sv);
 int mouse_tc_Object    (pTHX_ SV*, SV* const sv);
 
 CV* mouse_generate_isa_predicate_for(pTHX_ SV* const klass, const char* const predicate_name);
+CV* mouse_generate_can_predicate_for(pTHX_ SV* const klass, const char* const predicate_name);
 
 int mouse_is_an_instance_of(pTHX_ HV* const stash, SV* const instance);
 
diff --git a/xs-src/MouseTypeConstraints.xs b/xs-src/MouseTypeConstraints.xs
index 5260d88..96cb6eb 100644
--- a/xs-src/MouseTypeConstraints.xs
+++ b/xs-src/MouseTypeConstraints.xs
@@ -320,6 +320,7 @@ mouse_types_check(pTHX_ AV* const types, SV* const sv) {
 #define MY_CXT_KEY "Mouse::Util::TypeConstraints::_guts" XS_VERSION
 typedef struct sui_cxt{
     GV* universal_isa;
+    GV* universal_can;
 } my_cxt_t;
 START_MY_CXT
 
@@ -411,6 +412,56 @@ mouse_is_an_instance_of_universal(pTHX_ SV* const data, SV* const sv){
     return SvROK(sv) && SvOBJECT(SvRV(sv));
 }
 
+static int
+mouse_can_methods(pTHX_ AV* const methods, SV* const instance){
+    if(IsObject(instance)){
+        dMY_CXT;
+        HV* const mystash      = SvSTASH(SvRV(instance));
+        GV* const mycan        = gv_fetchmeth_autoload(mystash, "can", sizeof("can")-1, 0);
+        bool const use_builtin = (mycan == NULL || GvCV(mycan) == GvCV(MY_CXT.universal_isa)) ? TRUE : FALSE;
+        I32 const len           = AvFILLp(methods) + 1;
+        I32 i;
+        for(i = 0; i < len; i++){
+            SV* const name = MOUSE_av_at(methods, i);
+
+            if(use_builtin){
+                if(!gv_fetchmeth_autoload(mystash, SvPVX(name), SvCUR(name), 0)){
+                    return FALSE;
+                }
+            }
+            else{
+                bool ok;
+                dSP;
+
+                ENTER;
+                SAVETMPS;
+
+                PUSHMARK(SP);
+                EXTEND(SP, 2);
+                PUSHs(instance);
+                PUSHs(sv_mortalcopy(name));
+                PUTBACK;
+
+                call_method("can", G_SCALAR);
+
+                SPAGAIN;
+                ok = SvTRUE(TOPs);
+                (void)POPs;
+                PUTBACK;
+
+                FREETMPS;
+                LEAVE;
+
+                if(!ok){
+                    return FALSE;
+                }
+            }
+        }
+        return TRUE;
+    }
+    return FALSE;
+}
+
 static MGVTBL mouse_util_type_constraints_vtbl; /* not used, only for identity */
 
 static CV*
@@ -456,6 +507,32 @@ mouse_generate_isa_predicate_for(pTHX_ SV* const klass, const char* const predic
     return mouse_tc_generate(aTHX_ predicate_name, fptr, param);
 }
 
+CV*
+mouse_generate_can_predicate_for(pTHX_ SV* const methods, const char* const predicate_name){
+    AV* av;
+    AV* const param = newAV_mortal();
+    I32 len;
+    I32 i;
+
+    SvGETMAGIC(methods);
+    if(!IsArrayRef(methods)){
+        croak("You must pass an ARRAY ref method names");
+    }
+    av = (AV*)SvRV(methods);
+
+    len = av_len(av) + 1;
+    for(i = 0; i < len; i++){
+        SV* const name = *av_fetch(av, i, TRUE);
+        STRLEN pvlen;
+        const char* const pv = SvPV_const(name, pvlen);
+
+        av_push(param, newSVpvn_share(pv, pvlen, 0U));
+    }
+
+    return mouse_tc_generate(aTHX_ predicate_name, (check_fptr_t)mouse_can_methods, (SV*)param);
+}
+
+
 XS(XS_Mouse_constraint_check) {
     dVAR;
     dXSARGS;
@@ -474,6 +551,9 @@ static void
 setup_my_cxt(pTHX_ pMY_CXT){
     MY_CXT.universal_isa = gv_fetchpvs("UNIVERSAL::isa", GV_ADD, SVt_PVCV);
     SvREFCNT_inc_simple_void_NN(MY_CXT.universal_isa);
+
+    MY_CXT.universal_can = gv_fetchpvs("UNIVERSAL::can", GV_ADD, SVt_PVCV);
+    SvREFCNT_inc_simple_void_NN(MY_CXT.universal_can);
 }
 
 #define DEFINE_TC(name) mouse_tc_generate(aTHX_ "Mouse::Util::TypeConstraints::" STRINGIFY(name), CAT2(mouse_tc_, name), NULL)
diff --git a/xs-src/MouseUtil.xs b/xs-src/MouseUtil.xs
index 3e97648..93160fc 100644
--- a/xs-src/MouseUtil.xs
+++ b/xs-src/MouseUtil.xs
@@ -347,27 +347,35 @@ OUTPUT:
     RETVAL
 
 void
-generate_isa_predicate_for(SV* klass, SV* predicate_name = NULL)
+generate_isa_predicate_for(SV* arg, SV* predicate_name = NULL)
+ALIAS:
+    generate_isa_predicate_for = 0
+    generate_can_predicate_for = 1
 PPCODE:
 {
     const char* name_pv = NULL;
     CV* xsub;
 
-    SvGETMAGIC(klass);
+    SvGETMAGIC(arg);
 
-    if(!SvOK(klass)){
-        croak("You must define a class name");
+    if(!SvOK(arg)){
+        croak("You must define %s", ix == 0 ? "a class name" : "method names");
     }
 
     if(predicate_name){
         SvGETMAGIC(predicate_name);
         if(!SvOK(predicate_name)){
-            croak("You must define a predicate_name");
+            croak("You must define %s", "a predicate name");
         }
         name_pv = SvPV_nolen_const(predicate_name);
     }
 
-    xsub = mouse_generate_isa_predicate_for(aTHX_ klass, name_pv);
+    if(ix == 0){
+        xsub = mouse_generate_isa_predicate_for(aTHX_ arg, name_pv);
+    }
+    else{
+        xsub = mouse_generate_can_predicate_for(aTHX_ arg, name_pv);
+    }
 
     if(predicate_name == NULL){ /* anonymous predicate */
         XPUSHs( newRV_noinc((SV*)xsub) );