universal.c: sv_does() UTF8 cleanup.

This adds _sv, _pv, and _pvn forms to sv_does, and changes it to use
sv_ref() instead of sv_reftype().

diff --git a/embed.fnc b/embed.fnc
index 09363ef..03bbfca 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -1253,6 +1253,10 @@ ApdR     |bool   |sv_derived_from_pv|NN SV* sv|NN const char *const name|U32 flags
 ApdR   |bool   |sv_derived_from_pvn|NN SV* sv|NN const char *const name \
                                     |STRLEN len|U32 flags
 ApdR   |bool   |sv_does        |NN SV* sv|NN const char *const name
+ApdR   |bool   |sv_does_sv     |NN SV* sv|NN SV* namesv|U32 flags
+ApdR   |bool   |sv_does_pv     |NN SV* sv|NN const char *const name|U32 flags
+ApdR   |bool   |sv_does_pvn    |NN SV* sv|NN const char *const name|const STRLEN len \
+                                |U32 flags
 Amd    |I32    |sv_eq          |NULLOK SV* sv1|NULLOK SV* sv2
 Apd    |I32    |sv_eq_flags    |NULLOK SV* sv1|NULLOK SV* sv2|const U32 flags
 Apd    |void   |sv_free        |NULLOK SV *const sv

diff --git a/embed.h b/embed.h
index 72a9ece..2f4744e 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -561,6 +561,9 @@
 #define sv_derived_from_sv(a,b,c)      Perl_sv_derived_from_sv(aTHX_ a,b,c)
 #define sv_destroyable(a)      Perl_sv_destroyable(aTHX_ a)
 #define sv_does(a,b)           Perl_sv_does(aTHX_ a,b)
+#define sv_does_pv(a,b,c)      Perl_sv_does_pv(aTHX_ a,b,c)
+#define sv_does_pvn(a,b,c,d)   Perl_sv_does_pvn(aTHX_ a,b,c,d)
+#define sv_does_sv(a,b,c)      Perl_sv_does_sv(aTHX_ a,b,c)
 #define sv_dump(a)             Perl_sv_dump(aTHX_ a)
 #define sv_eq_flags(a,b,c)     Perl_sv_eq_flags(aTHX_ a,b,c)
 #define sv_force_normal_flags(a,b)     Perl_sv_force_normal_flags(aTHX_ a,b)
@@ -1169,6 +1172,7 @@
 #define sv_clean_objs()                Perl_sv_clean_objs(aTHX)
 #define sv_del_backref(a,b)    Perl_sv_del_backref(aTHX_ a,b)
 #define sv_free_arenas()       Perl_sv_free_arenas(aTHX)
+#define sv_ref(a,b,c)          Perl_sv_ref(aTHX_ a,b,c)
 #define sv_sethek(a,b)         Perl_sv_sethek(aTHX_ a,b)
 #ifndef PERL_IMPLICIT_CONTEXT
 #define tied_method            Perl_tied_method

diff --git a/proto.h b/proto.h
index 72e2f4a..7a5fab0 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -3856,6 +3856,27 @@ PERL_CALLCONV bool       Perl_sv_does(pTHX_ SV* sv, const char *const name)
 #define PERL_ARGS_ASSERT_SV_DOES       \
        assert(sv); assert(name)
 
+PERL_CALLCONV bool     Perl_sv_does_pv(pTHX_ SV* sv, const char *const name, U32 flags)
+                       __attribute__warn_unused_result__
+                       __attribute__nonnull__(pTHX_1)
+                       __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_SV_DOES_PV    \
+       assert(sv); assert(name)
+
+PERL_CALLCONV bool     Perl_sv_does_pvn(pTHX_ SV* sv, const char *const name, const STRLEN len, U32 flags)
+                       __attribute__warn_unused_result__
+                       __attribute__nonnull__(pTHX_1)
+                       __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_SV_DOES_PVN   \
+       assert(sv); assert(name)
+
+PERL_CALLCONV bool     Perl_sv_does_sv(pTHX_ SV* sv, SV* namesv, U32 flags)
+                       __attribute__warn_unused_result__
+                       __attribute__nonnull__(pTHX_1)
+                       __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_SV_DOES_SV    \
+       assert(sv); assert(namesv)
+
 PERL_CALLCONV void     Perl_sv_dump(pTHX_ SV* sv)
                        __attribute__nonnull__(pTHX_1);
 #define PERL_ARGS_ASSERT_SV_DUMP       \
@@ -4026,6 +4047,11 @@ PERL_CALLCONV char*      Perl_sv_recode_to_utf8(pTHX_ SV* sv, SV *encoding)
 #define PERL_ARGS_ASSERT_SV_RECODE_TO_UTF8     \
        assert(sv); assert(encoding)
 
+PERL_CALLCONV SV*      Perl_sv_ref(pTHX_ SV *dst, const SV *const sv, const int ob)
+                       __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_SV_REF        \
+       assert(sv)
+
 PERL_CALLCONV const char*      Perl_sv_reftype(pTHX_ const SV *const sv, const int ob)
                        __attribute__warn_unused_result__
                        __attribute__nonnull__(pTHX_1);

diff --git a/universal.c b/universal.c
index 314af37..8570940 100644 (file)
--- a/universal.c
+++ b/universal.c
@@ -181,14 +181,15 @@ The SV can be a Perl object or the name of a Perl class.
 #include "XSUB.h"
 
 bool
-Perl_sv_does(pTHX_ SV *sv, const char *const name)
+Perl_sv_does_sv(pTHX_ SV *sv, SV *namesv, U32 flags)
 {
-    const char *classname;
+    SV *classname;
     bool does_it;
     SV *methodname;
     dSP;
 
-    PERL_ARGS_ASSERT_SV_DOES;
+    PERL_ARGS_ASSERT_SV_DOES_SV;
+    PERL_UNUSED_ARG(flags);
 
     ENTER;
     SAVETMPS;
@@ -202,19 +203,20 @@ Perl_sv_does(pTHX_ SV *sv, const char *const name)
     }
 
     if (sv_isobject(sv)) {
-       classname = sv_reftype(SvRV(sv),TRUE);
+       classname = sv_ref(NULL,SvRV(sv),TRUE);
     } else {
-       classname = SvPV_nolen(sv);
+       classname = sv;
     }
 
-    if (strEQ(name,classname)) {
+    if (sv_eq(classname, namesv)) {
        LEAVE;
        return TRUE;
     }
 
     PUSHMARK(SP);
-    XPUSHs(sv);
-    mXPUSHs(newSVpv(name, 0));
+    EXTEND(SP, 2);
+    PUSHs(sv);
+    PUSHs(namesv);
     PUTBACK;
 
     methodname = newSVpvs_flags("isa", SVs_TEMP);
@@ -233,6 +235,46 @@ Perl_sv_does(pTHX_ SV *sv, const char *const name)
 }
 
 /*
+=for apidoc sv_does
+
+Exactly like L</sv_does_pv>, but doesn't take a C<flags> parameter.
+
+=cut
+*/
+
+bool
+Perl_sv_does(pTHX_ SV *sv, const char *const name)
+{
+    PERL_ARGS_ASSERT_SV_DOES;
+    return sv_does_sv(sv, newSVpvn_flags(name, strlen(name), SVs_TEMP), 0);
+}
+
+/*
+=for apidoc sv_does_pv
+
+Exactly like L</sv_does_pvn>, but takes a nul-terminated string 
+instead of a string/length pair.
+
+=cut
+*/
+
+
+bool
+Perl_sv_does_pv(pTHX_ SV *sv, const char *const name, U32 flags)
+{
+    PERL_ARGS_ASSERT_SV_DOES_PV;
+    return sv_does_sv(sv, newSVpvn_flags(name, strlen(name), SVs_TEMP | flags), flags);
+}
+
+bool
+Perl_sv_does_pvn(pTHX_ SV *sv, const char *const name, const STRLEN len, U32 flags)
+{
+    PERL_ARGS_ASSERT_SV_DOES_PVN;
+
+    return sv_does_sv(sv, newSVpvn_flags(name, len, flags | SVs_TEMP), flags);
+}
+
+/*
 =for apidoc croak_xs_usage
 
 A specialised variant of C<croak()> for emitting the usage message for xsubs
@@ -340,10 +382,7 @@ XS(XS_UNIVERSAL_DOES)
        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 ))
+       if (sv_does_sv( sv, ST(1), 0 ))
            XSRETURN_YES;
 
        XSRETURN_NO;