universal.c: ->isa, sv_derived_from UTF8 cleanup.

This makes them both nul-and-UTF8 clean, although the latter
is somewhat superficial, as mro isn't clean yet.

(Tests coming once ->can and ->DOES are clean)

diff --git a/embed.fnc b/embed.fnc
index dea3bed..86b8b17 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -1248,6 +1248,10 @@ Apd      |void   |sv_dec         |NULLOK SV *const sv
 Apd    |void   |sv_dec_nomg    |NULLOK SV *const sv
 Ap     |void   |sv_dump        |NN SV* sv
 ApdR   |bool   |sv_derived_from|NN SV* sv|NN const char *const name
+ApdR   |bool   |sv_derived_from_sv|NN SV* sv|NN SV *namesv|U32 flags
+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
 Amd    |I32    |sv_eq          |NULLOK SV* sv1|NULLOK SV* sv2
 Apd    |I32    |sv_eq_flags    |NULLOK SV* sv1|NULLOK SV* sv2|const U32 flags
@@ -2071,7 +2075,8 @@ s |void   |printbuf       |NN const char *const fmt|NN const char *const s
 #endif
 
 #if defined(PERL_IN_UNIVERSAL_C)
-s      |bool|isa_lookup        |NN HV *stash|NN const char * const name
+s      |bool|isa_lookup        |NN HV *stash|NN const char * const name \
+                                        |STRLEN len|U32 flags
 #endif
 
 #if defined(PERL_IN_LOCALE_C)

diff --git a/embed.h b/embed.h
index fde7a9c..d8498c9 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -556,6 +556,9 @@
 #define sv_dec(a)              Perl_sv_dec(aTHX_ a)
 #define sv_dec_nomg(a)         Perl_sv_dec_nomg(aTHX_ a)
 #define sv_derived_from(a,b)   Perl_sv_derived_from(aTHX_ a,b)
+#define sv_derived_from_pv(a,b,c)      Perl_sv_derived_from_pv(aTHX_ a,b,c)
+#define sv_derived_from_pvn(a,b,c,d)   Perl_sv_derived_from_pvn(aTHX_ a,b,c,d)
+#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_dump(a)             Perl_sv_dump(aTHX_ a)
@@ -1560,7 +1563,7 @@
 #    endif
 #  endif
 #  if defined(PERL_IN_UNIVERSAL_C)
-#define isa_lookup(a,b)                S_isa_lookup(aTHX_ a,b)
+#define isa_lookup(a,b,c,d)    S_isa_lookup(aTHX_ a,b,c,d)
 #  endif
 #  if defined(PERL_IN_UTF8_C)
 #define is_utf8_char_slow      S_is_utf8_char_slow

diff --git a/proto.h b/proto.h
index 0b9f5a6..77eed76 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -3827,6 +3827,27 @@ PERL_CALLCONV bool       Perl_sv_derived_from(pTHX_ SV* sv, const char *const name)
 #define PERL_ARGS_ASSERT_SV_DERIVED_FROM       \
        assert(sv); assert(name)
 
+PERL_CALLCONV bool     Perl_sv_derived_from_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_DERIVED_FROM_PV    \
+       assert(sv); assert(name)
+
+PERL_CALLCONV bool     Perl_sv_derived_from_pvn(pTHX_ SV* sv, const char *const name, STRLEN len, U32 flags)
+                       __attribute__warn_unused_result__
+                       __attribute__nonnull__(pTHX_1)
+                       __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_SV_DERIVED_FROM_PVN   \
+       assert(sv); assert(name)
+
+PERL_CALLCONV bool     Perl_sv_derived_from_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_DERIVED_FROM_SV    \
+       assert(sv); assert(namesv)
+
 PERL_CALLCONV bool     Perl_sv_destroyable(pTHX_ SV *sv);
 PERL_CALLCONV bool     Perl_sv_does(pTHX_ SV* sv, const char *const name)
                        __attribute__warn_unused_result__
@@ -6911,7 +6932,7 @@ STATIC void       S_start_force(pTHX_ int where);
 #  endif
 #endif
 #if defined(PERL_IN_UNIVERSAL_C)
-STATIC bool    S_isa_lookup(pTHX_ HV *stash, const char * const name)
+STATIC bool    S_isa_lookup(pTHX_ HV *stash, const char * const name, STRLEN len, U32 flags)
                        __attribute__nonnull__(pTHX_1)
                        __attribute__nonnull__(pTHX_2);
 #define PERL_ARGS_ASSERT_ISA_LOOKUP    \

diff --git a/universal.c b/universal.c
index 76702ff..6ba565d 100644 (file)
--- a/universal.c
+++ b/universal.c
@@ -39,12 +39,11 @@
  */
 
 STATIC bool
-S_isa_lookup(pTHX_ HV *stash, const char * const name)
+S_isa_lookup(pTHX_ HV *stash, const char * const name, STRLEN len, U32 flags)
 {
     dVAR;
     const struct mro_meta *const meta = HvMROMETA(stash);
     HV *isa = meta->isa;
-    STRLEN len = strlen(name);
     const HV *our_stash;
 
     PERL_ARGS_ASSERT_ISA_LOOKUP;
@@ -54,8 +53,7 @@ S_isa_lookup(pTHX_ HV *stash, const char * const name)
        isa = meta->isa;
     }
 
-    if (hv_common(isa, NULL, name, len, 0 /* No "UTF-8" flag possible with only
-                                            a char * argument*/,
+    if (hv_common(isa, NULL, name, len, ( flags & SVf_UTF8 ? HVhek_UTF8 : 0),
                  HV_FETCH_ISEXISTS, NULL, 0)) {
        /* Direct name lookup worked.  */
        return TRUE;
@@ -64,7 +62,7 @@ S_isa_lookup(pTHX_ HV *stash, const char * const name)
     /* A stash/class can go by many names (ie. User == main::User), so 
        we use the HvENAME in the stash itself, which is canonical, falling
        back to HvNAME if necessary.  */
-    our_stash = gv_stashpvn(name, len, 0);
+    our_stash = gv_stashpvn(name, len, flags);
 
     if (our_stash) {
        HEK *canon_name = HvENAME_HEK(our_stash);
@@ -83,26 +81,80 @@ S_isa_lookup(pTHX_ HV *stash, const char * const name)
 /*
 =head1 SV Manipulation Functions
 
-=for apidoc sv_derived_from
+=for apidoc sv_derived_from_pvn
 
 Returns a boolean indicating whether the SV is derived from the specified class
 I<at the C level>.  To check derivation at the Perl level, call C<isa()> as a
 normal Perl method.
 
+Currently, the only significant value for C<flags> is SVf_UTF8.
+
+=cut
+
+=for apidoc sv_derived_from_sv
+
+Exactly like L</sv_derived_from_pvn>, but takes the name string in the form
+of an SV instead of a string/length pair.
+
+=cut
+
+*/
+
+bool
+Perl_sv_derived_from_sv(pTHX_ SV *sv, SV *namesv, U32 flags)
+{
+    char *namepv;
+    STRLEN namelen;
+    PERL_ARGS_ASSERT_SV_DERIVED_FROM_SV;
+    namepv = SvPV(namesv, namelen);
+    if (SvUTF8(namesv))
+       flags |= SVf_UTF8;
+    return sv_derived_from_pvn(sv, namepv, namelen, flags);
+}
+
+/*
+=for apidoc sv_derived_from
+
+Exactly like L</sv_derived_from_pv>, but doesn't take a C<flags> parameter.
+
 =cut
 */
 
 bool
 Perl_sv_derived_from(pTHX_ SV *sv, const char *const name)
 {
+    PERL_ARGS_ASSERT_SV_DERIVED_FROM;
+    return sv_derived_from_pvn(sv, name, strlen(name), 0);
+}
+
+/*
+=for apidoc sv_derived_from_pv
+
+Exactly like L</sv_derived_from_pvn>, but takes a nul-terminated string 
+instead of a string/length pair.
+
+=cut
+*/
+
+
+bool
+Perl_sv_derived_from_pv(pTHX_ SV *sv, const char *const name, U32 flags)
+{
+    PERL_ARGS_ASSERT_SV_DERIVED_FROM_PV;
+    return sv_derived_from_pvn(sv, name, strlen(name), flags);
+}
+
+bool
+Perl_sv_derived_from_pvn(pTHX_ SV *sv, const char *const name, const STRLEN len, U32 flags)
+{
     dVAR;
     HV *stash;
 
-    PERL_ARGS_ASSERT_SV_DERIVED_FROM;
+    PERL_ARGS_ASSERT_SV_DERIVED_FROM_PVN;
 
     SvGETMAGIC(sv);
 
-    if (SvROK(sv)) {
+    if (SvROK(sv)) { /* hugdo: */
        const char *type;
         sv = SvRV(sv);
         type = sv_reftype(sv,0);
@@ -114,7 +166,7 @@ Perl_sv_derived_from(pTHX_ SV *sv, const char *const name)
         stash = gv_stashsv(sv, 0);
     }
 
-    return stash ? isa_lookup(stash, name) : FALSE;
+    return stash ? isa_lookup(stash, name, len, flags) : FALSE;
 }
 
 /*
@@ -226,7 +278,6 @@ XS(XS_UNIVERSAL_isa)
        croak_xs_usage(cv, "reference, kind");
     else {
        SV * const sv = ST(0);
-       const char *name;
 
        SvGETMAGIC(sv);
 
@@ -234,9 +285,7 @@ XS(XS_UNIVERSAL_isa)
                    || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv))))
            XSRETURN_UNDEF;
 
-       name = SvPV_nolen_const(ST(1));
-
-       ST(0) = boolSV(sv_derived_from(sv, name));
+       ST(0) = boolSV(sv_derived_from_sv(sv, ST(1), 0));
        XSRETURN(1);
     }
 }