diff options
| -rw-r--r-- | embed.fnc | 7 | ||||
| -rw-r--r-- | embed.h | 5 | ||||
| -rw-r--r-- | proto.h | 23 | ||||
| -rw-r--r-- | universal.c | 75 |
4 files changed, 94 insertions, 16 deletions
@@ -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) @@ -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 @@ -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 76702ffb39..6ba565d187 100644 --- 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); } } |