Add the new method UNIVERSAL::DOES() and the API function sv_does()

Subject: Re: [PROPOSED PATCH: universal.c, t/op/universal.t] Add does()
Message-Id: <200605301741.08363.chromatic@wgz.org>

p4raw-id: //depot/perl@28387

diff --git a/embed.fnc b/embed.fnc
index 4ffa057..ed7d397 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -809,6 +809,7 @@ Apd |int    |getcwd_sv      |NN SV* sv
 Apd    |void   |sv_dec         |NN SV* sv
 Ap     |void   |sv_dump        |NN SV* sv
 ApdR   |bool   |sv_derived_from|NN SV* sv|NN const char* name
+ApdR   |bool   |sv_does        |NN SV* sv|NN const char* name
 Apd    |I32    |sv_eq          |NULLOK SV* sv1|NULLOK SV* sv2
 Apd    |void   |sv_free        |NULLOK SV* sv
 poMX   |void   |sv_free2       |NN SV* sv

diff --git a/embed.h b/embed.h
index 95b2de2..d2de6e9 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -842,6 +842,7 @@
 #define sv_dec                 Perl_sv_dec
 #define sv_dump                        Perl_sv_dump
 #define sv_derived_from                Perl_sv_derived_from
+#define sv_does                        Perl_sv_does
 #define sv_eq                  Perl_sv_eq
 #define sv_free                        Perl_sv_free
 #ifdef PERL_CORE
@@ -3027,6 +3028,7 @@
 #define sv_dec(a)              Perl_sv_dec(aTHX_ a)
 #define sv_dump(a)             Perl_sv_dump(aTHX_ a)
 #define sv_derived_from(a,b)   Perl_sv_derived_from(aTHX_ a,b)
+#define sv_does(a,b)           Perl_sv_does(aTHX_ a,b)
 #define sv_eq(a,b)             Perl_sv_eq(aTHX_ a,b)
 #define sv_free(a)             Perl_sv_free(aTHX_ a)
 #ifdef PERL_CORE

diff --git a/global.sym b/global.sym
index e1ce974..bf8b843 100644 (file)
--- a/global.sym
+++ b/global.sym
@@ -484,6 +484,7 @@ Perl_getcwd_sv
 Perl_sv_dec
 Perl_sv_dump
 Perl_sv_derived_from
+Perl_sv_does
 Perl_sv_eq
 Perl_sv_free
 Perl_sv_free2

diff --git a/pod/perlapi.pod b/pod/perlapi.pod
index ca9dfa3..dad3072 100644 (file)
--- a/pod/perlapi.pod
+++ b/pod/perlapi.pod
@@ -4637,6 +4637,17 @@ normal Perl method.
 =for hackers
 Found in file universal.c
 
+=item sv_does
+X<sv_does>
+
+Returns a boolean indicating whether the SV performs a specific, named role.
+The SV can be a Perl object or the name of a Perl class.
+
+       bool    sv_does(SV* sv, const char* name)
+
+=for hackers
+Found in file universal.c
+
 =item sv_report_used
 X<sv_report_used>
 

diff --git a/proto.h b/proto.h
index a0d5dec..e1ba341 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -2212,6 +2212,11 @@ PERL_CALLCONV bool       Perl_sv_derived_from(pTHX_ SV* sv, const char* name)
                        __attribute__nonnull__(pTHX_1)
                        __attribute__nonnull__(pTHX_2);
 
+PERL_CALLCONV bool     Perl_sv_does(pTHX_ SV* sv, const char* name)
+                       __attribute__warn_unused_result__
+                       __attribute__nonnull__(pTHX_1)
+                       __attribute__nonnull__(pTHX_2);
+
 PERL_CALLCONV I32      Perl_sv_eq(pTHX_ SV* sv1, SV* sv2);
 PERL_CALLCONV void     Perl_sv_free(pTHX_ SV* sv);
 PERL_CALLCONV void     Perl_sv_free2(pTHX_ SV* sv)

diff --git a/t/op/universal.t b/t/op/universal.t
index 1850127..e37bfc7 100755 (executable)
--- a/t/op/universal.t
+++ b/t/op/universal.t
@@ -10,7 +10,7 @@ BEGIN {
     require "./test.pl";
 }
 
-plan tests => 104;
+plan tests => 109;
 
 $a = {};
 bless $a, "Bob";
@@ -123,9 +123,9 @@ my $subs = join ' ', sort grep { defined &{"UNIVERSAL::$_"} } keys %UNIVERSAL::;
 ## The test for import here is *not* because we want to ensure that UNIVERSAL
 ## can always import; it is an historical accident that UNIVERSAL can import.
 if ('a' lt 'A') {
-    is $subs, "can import isa VERSION";
+    is $subs, "can does import isa VERSION";
 } else {
-    is $subs, "VERSION can import isa";
+    is $subs, "VERSION can does import isa";
 }
 
 ok $a->isa("UNIVERSAL");
@@ -146,9 +146,9 @@ ok $a->isa("UNIVERSAL");
 my $sub2 = join ' ', sort grep { defined &{"UNIVERSAL::$_"} } keys %UNIVERSAL::;
 # XXX import being here is really a bug
 if ('a' lt 'A') {
-    is $sub2, "can import isa VERSION";
+    is $sub2, "can does import isa VERSION";
 } else {
-    is $sub2, "VERSION can import isa";
+    is $sub2, "VERSION can does import isa";
 }
 
 eval 'sub UNIVERSAL::sleep {}';
@@ -200,3 +200,19 @@ is $@, '';
 # This segfaulted in a blead.
 fresh_perl_is('package Foo; Foo->VERSION;  print "ok"', 'ok');
 
+package Foo;
+
+sub does { 1 }
+
+package Bar;
+
+@Bar::ISA = 'Foo';
+
+package Baz;
+
+package main;
+ok( Foo->does( 'bar' ), 'does() should call does() on class' );
+ok( Bar->does( 'Bar' ), '... and should fall back to isa()' );
+ok( Bar->does( 'Foo' ), '... even when inherited' );
+ok( Baz->does( 'Baz' ), '... even without inheriting any other does()' );
+ok( ! Baz->does( 'Foo' ), '... returning true or false appropriately' );

diff --git a/universal.c b/universal.c
index a1e91b7..7cbaaf7 100644 (file)
--- a/universal.c
+++ b/universal.c
@@ -166,10 +166,60 @@ Perl_sv_derived_from(pTHX_ SV *sv, const char *name)
 
 }
 
+/*
+=for apidoc sv_does
+
+Returns a boolean indicating whether the SV performs a specific, named role.
+The SV can be a Perl object or the name of a Perl class.
+
+=cut
+*/
+
 #include "XSUB.h"
 
+bool
+Perl_sv_does(pTHX_ SV *sv, const char *name)
+{
+    const char *classname;
+    bool does_it;
+
+    dSP;
+    ENTER;
+    SAVETMPS;
+
+    SvGETMAGIC(sv);
+
+    if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))
+               || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
+       return FALSE;
+
+    if (sv_isobject(sv)) {
+       classname = sv_reftype(SvRV(sv),TRUE);
+    } else {
+       classname = SvPV(sv,PL_na);
+    }
+
+    if (strEQ(name,classname))
+       return TRUE;
+
+    PUSHMARK(SP);
+    XPUSHs(sv);
+    XPUSHs(sv_2mortal(newSVpv(name, 0)));
+    PUTBACK;
+
+    call_method("isa", G_SCALAR);
+    SPAGAIN;
+
+    does_it = SvTRUE( TOPs );
+    FREETMPS;
+    LEAVE;
+
+    return does_it;
+}
+
 PERL_XS_EXPORT_C void XS_UNIVERSAL_isa(pTHX_ CV *cv);
 PERL_XS_EXPORT_C void XS_UNIVERSAL_can(pTHX_ CV *cv);
+PERL_XS_EXPORT_C void XS_UNIVERSAL_DOES(pTHX_ CV *cv);
 PERL_XS_EXPORT_C void XS_UNIVERSAL_VERSION(pTHX_ CV *cv);
 XS(XS_version_new);
 XS(XS_version_stringify);
@@ -210,6 +260,7 @@ Perl_boot_core_UNIVERSAL(pTHX)
 
     newXS("UNIVERSAL::isa",             XS_UNIVERSAL_isa,         file);
     newXS("UNIVERSAL::can",             XS_UNIVERSAL_can,         file);
+    newXS("UNIVERSAL::DOES",            XS_UNIVERSAL_DOES,        file);
     newXS("UNIVERSAL::VERSION",        XS_UNIVERSAL_VERSION,     file);
     {
        /* register the overloading (type 'A') magic */
@@ -321,6 +372,25 @@ XS(XS_UNIVERSAL_can)
     XSRETURN(1);
 }
 
+XS(XS_UNIVERSAL_DOES)
+{
+    dVAR;
+    dXSARGS;
+
+    if (items != 2)
+       Perl_croak(aTHX_ "Usage: invocant->does(kind)");
+    else {
+       SV * const sv = ST(0);
+       const char *name;
+
+       name = SvPV_nolen_const(ST(1));
+       if (sv_does( sv, name ))
+           XSRETURN_YES;
+
+       XSRETURN_NO;
+    }
+}
+
 XS(XS_UNIVERSAL_VERSION)
 {
     dVAR;