X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/1ee8edd0f0d0f301e1084aca5f8a9a83c483d072..f4a67abafa1e7c5a13bff02284af8fce11f8ff4d:/universal.c?ds=sidebyside diff --git a/universal.c b/universal.c index 168a5cb..c891b54 100644 --- a/universal.c +++ b/universal.c @@ -21,7 +21,7 @@ * * It is also used to store XS functions that need to be present in * miniperl for a lack of a better place to put them. It might be - * clever to move them to seperate XS files which would then be pulled + * clever to move them to separate XS files which would then be pulled * in by some to-be-written build process. */ @@ -33,41 +33,6 @@ #include "perliol.h" /* For the PERLIO_F_XXX */ #endif -static HV * -S_get_isa_hash(pTHX_ HV *const stash) -{ - dVAR; - struct mro_meta *const meta = HvMROMETA(stash); - - PERL_ARGS_ASSERT_GET_ISA_HASH; - - if (!meta->isa) { - AV *const isa = mro_get_linear_isa(stash); - if (!meta->isa) { - HV *const isa_hash = newHV(); - /* Linearisation didn't build it for us, so do it here. */ - SV *const *svp = AvARRAY(isa); - SV *const *const svp_end = svp + AvFILLp(isa) + 1; - const HEK *const canon_name = HvNAME_HEK(stash); - - while (svp < svp_end) { - (void) hv_store_ent(isa_hash, *svp++, &PL_sv_undef, 0); - } - - (void) hv_common(isa_hash, NULL, HEK_KEY(canon_name), - HEK_LEN(canon_name), HEK_FLAGS(canon_name), - HV_FETCH_ISSTORE, &PL_sv_undef, - HEK_HASH(canon_name)); - (void) hv_store(isa_hash, "UNIVERSAL", 9, &PL_sv_undef, 0); - - SvREADONLY_on(isa_hash); - - meta->isa = isa_hash; - } - } - return meta->isa; -} - /* * Contributed by Graham Barr * The main guts of traverse_isa was actually copied from gv_fetchmeth @@ -78,12 +43,17 @@ S_isa_lookup(pTHX_ HV *stash, const char * const name) { dVAR; const struct mro_meta *const meta = HvMROMETA(stash); - HV *const isa = meta->isa ? meta->isa : S_get_isa_hash(aTHX_ stash); + HV *isa = meta->isa; STRLEN len = strlen(name); const HV *our_stash; PERL_ARGS_ASSERT_ISA_LOOKUP; + if (!isa) { + (void)mro_get_linear_isa(stash); + isa = meta->isa; + } + if (hv_common(isa, NULL, name, len, 0 /* No "UTF-8" flag possible with only a char * argument*/, HV_FETCH_ISEXISTS, NULL, 0)) { @@ -92,11 +62,13 @@ 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 name in the stash itself, which is canonical. */ + we use the HvENAME in the stash itself, which is canonical, falling + back to HvNAME if necessary. */ our_stash = gv_stashpvn(name, len, 0); if (our_stash) { - HEK *const canon_name = HvNAME_HEK(our_stash); + HEK *canon_name = HvENAME_HEK(our_stash); + if (!canon_name) canon_name = HvNAME_HEK(our_stash); if (hv_common(isa, NULL, HEK_KEY(canon_name), HEK_LEN(canon_name), HEK_FLAGS(canon_name), @@ -339,6 +311,7 @@ XS(XS_UNIVERSAL_VERSION) GV **gvp; GV *gv; SV *sv; + SV *ret; const char *undef; PERL_UNUSED_ARG(cv); @@ -355,15 +328,12 @@ XS(XS_UNIVERSAL_VERSION) gvp = pkg ? (GV**)hv_fetchs(pkg, "VERSION", FALSE) : NULL; if (gvp && isGV(gv = *gvp) && (sv = GvSV(gv)) && SvOK(sv)) { - SV * const nsv = sv_newmortal(); - sv_setsv(nsv, sv); - sv = nsv; - if ( !sv_derived_from(sv, "version")) - upg_version(sv, FALSE); + ret = sv_newmortal(); + sv_setsv(ret, sv); undef = NULL; } else { - sv = &PL_sv_undef; + sv = ret = &PL_sv_undef; undef = "(undef)"; } @@ -383,6 +353,9 @@ XS(XS_UNIVERSAL_VERSION) } } + if ( !sv_derived_from(sv, "version")) + upg_version(sv, FALSE); + if ( !sv_derived_from(req, "version")) { /* req may very well be R/O, so create a new object */ req = sv_2mortal( new_version(req) ); @@ -404,11 +377,7 @@ XS(XS_UNIVERSAL_VERSION) } - if ( SvOK(sv) && sv_derived_from(sv, "version") ) { - ST(0) = sv_2mortal(vstringify(sv)); - } else { - ST(0) = sv; - } + ST(0) = ret; XSRETURN(1); } @@ -723,9 +692,10 @@ XS(XS_utf8_decode) croak_xs_usage(cv, "sv"); else { SV * const sv = ST(0); - const bool RETVAL = sv_utf8_decode(sv); + bool RETVAL; + if (SvIsCOW(sv)) sv_force_normal(sv); + RETVAL = sv_utf8_decode(sv); ST(0) = boolSV(RETVAL); - sv_2mortal(ST(0)); } XSRETURN(1); } @@ -759,7 +729,6 @@ XS(XS_utf8_downgrade) const bool RETVAL = sv_utf8_downgrade(sv, failok); ST(0) = boolSV(RETVAL); - sv_2mortal(ST(0)); } XSRETURN(1); } @@ -805,19 +774,20 @@ XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */ sv = SvRV(svz); if (items == 1) { - if (SvREADONLY(sv)) + if (SvREADONLY(sv) && !SvIsCOW(sv)) XSRETURN_YES; else XSRETURN_NO; } else if (items == 2) { if (SvTRUE(ST(1))) { + if (SvIsCOW(sv)) sv_force_normal(sv); SvREADONLY_on(sv); XSRETURN_YES; } else { /* I hope you really know what you are doing. */ - SvREADONLY_off(sv); + if (!SvIsCOW(sv)) SvREADONLY_off(sv); XSRETURN_NO; } } @@ -1172,7 +1142,7 @@ XS(XS_re_regexp_pattern) Otherwise in list context it returns the pattern and the modifiers, in scalar context it returns the pattern just as it would if the qr// was stringified normally, regardless as - to the class of the variable and any strigification overloads + to the class of the variable and any stringification overloads on the object. */ @@ -1183,8 +1153,7 @@ XS(XS_re_regexp_pattern) if ( GIMME_V == G_ARRAY ) { STRLEN left = 0; - char reflags[sizeof(INT_PAT_MODS) + 1]; /* The +1 is for the charset - modifier */ + char reflags[sizeof(INT_PAT_MODS) + MAX_CHARSET_NAME_LENGTH]; const char *fptr; char ch; U16 match_flags; @@ -1192,17 +1161,18 @@ XS(XS_re_regexp_pattern) /* we are in list context so stringify the modifiers that apply. We ignore "negative - modifiers" in this scenario. + modifiers" in this scenario, and the default character set */ - if (RX_EXTFLAGS(re) & RXf_PMf_LOCALE) { - reflags[left++] = LOCALE_PAT_MOD; - } - else if (RX_EXTFLAGS(re) & RXf_PMf_UNICODE) { - reflags[left++] = UNICODE_PAT_MOD; + if (get_regex_charset(RX_EXTFLAGS(re)) != REGEX_DEPENDS_CHARSET) { + STRLEN len; + const char* const name = get_regex_charset_name(RX_EXTFLAGS(re), + &len); + Copy(name, reflags + left, len, char); + left += len; } fptr = INT_PAT_MODS; - match_flags = (U16)((RX_EXTFLAGS(re) & PMf_COMPILETIME) + match_flags = (U16)((RX_EXTFLAGS(re) & RXf_PMf_COMPILETIME) >> RXf_PMf_STD_PMMOD_SHIFT); while((ch = *fptr++)) { @@ -1254,190 +1224,6 @@ XS(XS_re_regexp_pattern) /* NOT-REACHED */ } -static void -S_named_capture_common(pTHX_ CV *const cv, const bool fatal, const int expect, - const U32 action) -{ - dVAR; - dXSARGS; - REGEXP * rx; - U32 flags; - SV * ret; - - if (items != expect) - croak_xs_usage(cv, expect == 2 ? "$key" : ""); - - rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL; - - if (!rx || !SvROK(ST(0))) { - if (fatal) - Perl_croak_no_modify(aTHX); - else - XSRETURN_UNDEF; - } - - SP -= items; - PUTBACK; - - flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0)))); - ret = RX_ENGINE(rx)->named_buff(aTHX_ (rx), expect >= 2 ? ST(1) : NULL, - NULL, flags | action); - - SPAGAIN; - PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef); - XSRETURN(1); -} - -XS(XS_Tie_Hash_NamedCapture_FETCH) -{ - S_named_capture_common(aTHX_ cv, FALSE, 2, RXapif_FETCH); -} - -XS(XS_Tie_Hash_NamedCapture_STORE) -{ - dVAR; - dXSARGS; - REGEXP * rx; - U32 flags; - SV *ret; - - if (items != 3) - croak_xs_usage(cv, "$key, $value"); - - rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL; - - if (!rx || !SvROK(ST(0))) { - Perl_croak_no_modify(aTHX); - } - - SP -= items; - PUTBACK; - - flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0)))); - ret = RX_ENGINE(rx)->named_buff(aTHX_ (rx), ST(1), ST(2), flags | RXapif_STORE); - - - /* Perl_magic_setpack calls us with G_DISCARD, so our return stack state - is thrown away. */ - - /* If we were returned anything, free it immediately. */ - SvREFCNT_dec(ret); - XSRETURN_EMPTY; -} - -XS(XS_Tie_Hash_NamedCapture_DELETE) -{ - S_named_capture_common(aTHX_ cv, TRUE, 2, RXapif_DELETE); -} - -XS(XS_Tie_Hash_NamedCapture_CLEAR) -{ - dVAR; - dXSARGS; - REGEXP * rx; - U32 flags; - SV *ret; - - if (items != 1) - croak_xs_usage(cv, ""); - - rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL; - - if (!rx || !SvROK(ST(0))) - Perl_croak_no_modify(aTHX); - - SP -= items; - PUTBACK; - - flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0)))); - ret = RX_ENGINE(rx)->named_buff(aTHX_ (rx), NULL, NULL, flags | RXapif_CLEAR); - - /* Perl_magic_wipepack calls us with G_DISCARD, so our return stack state - is thrown away. */ - - /* If we were returned anything, free it immediately. */ - SvREFCNT_dec(ret); - XSRETURN_EMPTY; -} - -XS(XS_Tie_Hash_NamedCapture_EXISTS) -{ - S_named_capture_common(aTHX_ cv, FALSE, 2, RXapif_EXISTS); -} - -XS(XS_Tie_Hash_NamedCapture_FIRSTK) -{ - dVAR; - dXSARGS; - REGEXP * rx; - U32 flags; - SV * ret; - - if (items != 1) - croak_xs_usage(cv, ""); - - rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL; - - if (!rx || !SvROK(ST(0))) - XSRETURN_UNDEF; - - SP -= items; - PUTBACK; - - flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0)))); - ret = RX_ENGINE(rx)->named_buff_iter(aTHX_ (rx), NULL, flags | RXapif_FIRSTKEY); - - SPAGAIN; - PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef); - XSRETURN(1); -} - -XS(XS_Tie_Hash_NamedCapture_NEXTK) -{ - dVAR; - dXSARGS; - REGEXP * rx; - U32 flags; - SV * ret; - - if (items != 2) - croak_xs_usage(cv, "$lastkey"); - - rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL; - - if (!rx || !SvROK(ST(0))) - XSRETURN_UNDEF; - - SP -= items; - PUTBACK; - - flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0)))); - ret = RX_ENGINE(rx)->named_buff_iter(aTHX_ (rx), ST(1), flags | RXapif_NEXTKEY); - - SPAGAIN; - PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef); - XSRETURN(1); -} - -XS(XS_Tie_Hash_NamedCapture_SCALAR) -{ - S_named_capture_common(aTHX_ cv, FALSE, 1, RXapif_SCALAR); -} - -XS(XS_Tie_Hash_NamedCapture_flags) -{ - dVAR; - dXSARGS; - - if (items != 0) - croak_xs_usage(cv, ""); - - mXPUSHu(RXapif_ONE); - mXPUSHu(RXapif_ALL); - PUTBACK; - return; -} - struct xsub_details { const char *name; XSUBADDR_t xsub; @@ -1488,15 +1274,6 @@ struct xsub_details details[] = { {"re::regnames", XS_re_regnames, ";$"}, {"re::regnames_count", XS_re_regnames_count, ""}, {"re::regexp_pattern", XS_re_regexp_pattern, "$"}, - {"Tie::Hash::NamedCapture::FETCH", XS_Tie_Hash_NamedCapture_FETCH, NULL}, - {"Tie::Hash::NamedCapture::STORE", XS_Tie_Hash_NamedCapture_STORE, NULL}, - {"Tie::Hash::NamedCapture::DELETE", XS_Tie_Hash_NamedCapture_DELETE, NULL}, - {"Tie::Hash::NamedCapture::CLEAR", XS_Tie_Hash_NamedCapture_CLEAR, NULL}, - {"Tie::Hash::NamedCapture::EXISTS", XS_Tie_Hash_NamedCapture_EXISTS, NULL}, - {"Tie::Hash::NamedCapture::FIRSTKEY", XS_Tie_Hash_NamedCapture_FIRSTK, NULL}, - {"Tie::Hash::NamedCapture::NEXTKEY", XS_Tie_Hash_NamedCapture_NEXTK, NULL}, - {"Tie::Hash::NamedCapture::SCALAR", XS_Tie_Hash_NamedCapture_SCALAR, NULL}, - {"Tie::Hash::NamedCapture::flags", XS_Tie_Hash_NamedCapture_flags, NULL} }; void