X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/15eb3045c00fb672689d55100ccff4bb2985aaf5..c77726bb7bf6d340166d67aac247e2e307158a9a:/universal.c diff --git a/universal.c b/universal.c index ad5b504..66eafc5 100644 --- a/universal.c +++ b/universal.c @@ -41,7 +41,6 @@ STATIC bool 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; const HV *our_stash; @@ -67,7 +66,7 @@ S_isa_lookup(pTHX_ HV *stash, const char * const name, STRLEN len, U32 flags) if (our_stash) { HEK *canon_name = HvENAME_HEK(our_stash); if (!canon_name) canon_name = HvNAME_HEK(our_stash); - + assert(canon_name); if (hv_common(isa, NULL, HEK_KEY(canon_name), HEK_LEN(canon_name), HEK_FLAGS(canon_name), HV_FETCH_ISEXISTS, NULL, HEK_HASH(canon_name))) { @@ -147,7 +146,6 @@ Perl_sv_derived_from_pv(pTHX_ SV *sv, const char *const name, U32 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_PVN; @@ -207,7 +205,7 @@ Perl_sv_does_sv(pTHX_ SV *sv, SV *namesv, U32 flags) return FALSE; } - if (sv_isobject(sv)) { + if (SvROK(sv) && SvOBJECT(SvRV(sv))) { classname = sv_ref(NULL,SvRV(sv),TRUE); } else { classname = sv; @@ -224,15 +222,18 @@ Perl_sv_does_sv(pTHX_ SV *sv, SV *namesv, U32 flags) PUSHs(namesv); PUTBACK; - methodname = newSVpvs_flags("isa", SVs_TEMP); - /* ugly hack: use the SvSCREAM flag so S_method_common - * can figure out we're calling DOES() and not isa(), - * and report eventual errors correctly. --rgs */ - SvSCREAM_on(methodname); + /* create a PV with value "isa", but with a special address + * so that perl knows we're really doing "DOES" instead */ + methodname = newSV_type(SVt_PV); + SvLEN_set(methodname, 0); + SvCUR_set(methodname, strlen(PL_isa_DOES)); + SvPVX(methodname) = (char *)PL_isa_DOES; /* discard 'const' qualifier */ + SvPOK_on(methodname); + sv_2mortal(methodname); call_sv(methodname, G_SCALAR | G_METHOD); SPAGAIN; - does_it = SvTRUE( TOPs ); + does_it = SvTRUE_NN( TOPs ); FREETMPS; LEAVE; @@ -296,7 +297,8 @@ A specialised variant of C for emitting the usage message for xsubs works out the package name and subroutine name from C, and then calls C. Hence if C is C<&ouch::awk>, it would call C as: - Perl_croak(aTHX_ "Usage: %"SVf"::%"SVf"(%s)", "ouch" "awk", "eee_yow"); + Perl_croak(aTHX_ "Usage: %" SVf "::%" SVf "(%s)", "ouch" "awk", + "eee_yow"); =cut */ @@ -304,34 +306,37 @@ C. Hence if C is C<&ouch::awk>, it would call C as: void Perl_croak_xs_usage(const CV *const cv, const char *const params) { - const GV *const gv = CvGV(cv); + /* Avoid CvGV as it requires aTHX. */ + const GV *gv = CvNAMED(cv) ? NULL : cv->sv_any->xcv_gv_u.xcv_gv; PERL_ARGS_ASSERT_CROAK_XS_USAGE; - if (gv) { + if (gv) got_gv: { const HV *const stash = GvSTASH(gv); if (HvNAME_get(stash)) /* diag_listed_as: SKIPME */ - Perl_croak_nocontext("Usage: %"HEKf"::%"HEKf"(%s)", + Perl_croak_nocontext("Usage: %" HEKf "::%" HEKf "(%s)", HEKfARG(HvNAME_HEK(stash)), HEKfARG(GvNAME_HEK(gv)), params); else /* diag_listed_as: SKIPME */ - Perl_croak_nocontext("Usage: %"HEKf"(%s)", + Perl_croak_nocontext("Usage: %" HEKf "(%s)", HEKfARG(GvNAME_HEK(gv)), params); } else { + dTHX; + if ((gv = CvGV(cv))) goto got_gv; + /* Pants. I don't think that it should be possible to get here. */ /* diag_listed_as: SKIPME */ - Perl_croak_nocontext("Usage: CODE(0x%"UVxf")(%s)", PTR2UV(cv), params); + Perl_croak(aTHX_ "Usage: CODE(0x%" UVxf ")(%s)", PTR2UV(cv), params); } } XS(XS_UNIVERSAL_isa); /* prototype to pass -Wmissing-prototypes */ XS(XS_UNIVERSAL_isa) { - dVAR; dXSARGS; if (items != 2) @@ -352,7 +357,6 @@ XS(XS_UNIVERSAL_isa) XS(XS_UNIVERSAL_can); /* prototype to pass -Wmissing-prototypes */ XS(XS_UNIVERSAL_can) { - dVAR; dXSARGS; SV *sv; SV *rv; @@ -388,7 +392,7 @@ XS(XS_UNIVERSAL_can) else { pkg = gv_stashsv(sv, 0); if (!pkg) - pkg = gv_stashpv("UNIVERSAL", 0); + pkg = gv_stashpvs("UNIVERSAL", 0); } if (pkg) { @@ -404,7 +408,6 @@ XS(XS_UNIVERSAL_can) XS(XS_UNIVERSAL_DOES); /* prototype to pass -Wmissing-prototypes */ XS(XS_UNIVERSAL_DOES) { - dVAR; dXSARGS; PERL_UNUSED_ARG(cv); @@ -422,7 +425,6 @@ XS(XS_UNIVERSAL_DOES) XS(XS_utf8_is_utf8); /* prototype to pass -Wmissing-prototypes */ XS(XS_utf8_is_utf8) { - dVAR; dXSARGS; if (items != 1) croak_xs_usage(cv, "sv"); @@ -440,7 +442,6 @@ XS(XS_utf8_is_utf8) XS(XS_utf8_valid); /* prototype to pass -Wmissing-prototypes */ XS(XS_utf8_valid) { - dVAR; dXSARGS; if (items != 1) croak_xs_usage(cv, "sv"); @@ -459,7 +460,6 @@ XS(XS_utf8_valid) XS(XS_utf8_encode); /* prototype to pass -Wmissing-prototypes */ XS(XS_utf8_encode) { - dVAR; dXSARGS; if (items != 1) croak_xs_usage(cv, "sv"); @@ -471,7 +471,6 @@ XS(XS_utf8_encode) XS(XS_utf8_decode); /* prototype to pass -Wmissing-prototypes */ XS(XS_utf8_decode) { - dVAR; dXSARGS; if (items != 1) croak_xs_usage(cv, "sv"); @@ -489,7 +488,6 @@ XS(XS_utf8_decode) XS(XS_utf8_upgrade); /* prototype to pass -Wmissing-prototypes */ XS(XS_utf8_upgrade) { - dVAR; dXSARGS; if (items != 1) croak_xs_usage(cv, "sv"); @@ -507,14 +505,14 @@ XS(XS_utf8_upgrade) XS(XS_utf8_downgrade); /* prototype to pass -Wmissing-prototypes */ XS(XS_utf8_downgrade) { - dVAR; dXSARGS; if (items < 1 || items > 2) croak_xs_usage(cv, "sv, failok=0"); else { - SV * const sv = ST(0); - const bool failok = (items < 2) ? 0 : (int)SvIV(ST(1)); - const bool RETVAL = sv_utf8_downgrade(sv, failok); + SV * const sv0 = ST(0); + SV * const sv1 = ST(1); + const bool failok = (items < 2) ? 0 : SvTRUE_NN(sv1) ? 1 : 0; + const bool RETVAL = sv_utf8_downgrade(sv0, failok); ST(0) = boolSV(RETVAL); } @@ -524,39 +522,35 @@ XS(XS_utf8_downgrade) XS(XS_utf8_native_to_unicode); /* prototype to pass -Wmissing-prototypes */ XS(XS_utf8_native_to_unicode) { - dVAR; dXSARGS; const UV uv = SvUV(ST(0)); if (items > 1) croak_xs_usage(cv, "sv"); - ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv))); + ST(0) = sv_2mortal(newSVuv(NATIVE_TO_UNI(uv))); XSRETURN(1); } XS(XS_utf8_unicode_to_native); /* prototype to pass -Wmissing-prototypes */ XS(XS_utf8_unicode_to_native) { - dVAR; dXSARGS; const UV uv = SvUV(ST(0)); if (items > 1) croak_xs_usage(cv, "sv"); - ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv))); + ST(0) = sv_2mortal(newSVuv(UNI_TO_NATIVE(uv))); XSRETURN(1); } XS(XS_Internals_SvREADONLY); /* prototype to pass -Wmissing-prototypes */ XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */ { - dVAR; dXSARGS; SV * const svz = ST(0); SV * sv; - PERL_UNUSED_ARG(cv); /* [perl #77776] - called as &foo() not foo() */ if (!SvROK(svz)) @@ -571,16 +565,14 @@ XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */ XSRETURN_NO; } else if (items == 2) { - if (SvTRUE(ST(1))) { -#ifdef PERL_OLD_COPY_ON_WRITE - if (SvIsCOW(sv)) sv_force_normal(sv); -#endif - SvREADONLY_on(sv); + SV *sv1 = ST(1); + if (SvTRUE_NN(sv1)) { + SvFLAGS(sv) |= SVf_READONLY; XSRETURN_YES; } else { /* I hope you really know what you are doing. */ - SvREADONLY_off(sv); + SvFLAGS(sv) &=~ SVf_READONLY; XSRETURN_NO; } } @@ -590,11 +582,9 @@ XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */ XS(XS_constant__make_const); /* prototype to pass -Wmissing-prototypes */ XS(XS_constant__make_const) /* This is dangerous stuff. */ { - dVAR; dXSARGS; SV * const svz = ST(0); SV * sv; - PERL_UNUSED_ARG(cv); /* [perl #77776] - called as &foo() not foo() */ if (!SvROK(svz) || items != 1) @@ -602,9 +592,6 @@ XS(XS_constant__make_const) /* This is dangerous stuff. */ sv = SvRV(svz); -#ifdef PERL_OLD_COPY_ON_WRITE - if (SvIsCOW(sv)) sv_force_normal(sv); -#endif SvREADONLY_on(sv); if (SvTYPE(sv) == SVt_PVAV && AvFILLp(sv) != -1) { /* for constant.pm; nobody else should be calling this @@ -621,12 +608,10 @@ XS(XS_constant__make_const) /* This is dangerous stuff. */ XS(XS_Internals_SvREFCNT); /* prototype to pass -Wmissing-prototypes */ XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */ { - dVAR; dXSARGS; SV * const svz = ST(0); SV * sv; U32 refcnt; - PERL_UNUSED_ARG(cv); /* [perl #77776] - called as &foo() not foo() */ if ((items != 1 && items != 2) || !SvROK(svz)) @@ -647,7 +632,6 @@ XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */ XS(XS_Internals_hv_clear_placehold); /* prototype to pass -Wmissing-prototypes */ XS(XS_Internals_hv_clear_placehold) { - dVAR; dXSARGS; if (items != 1 || !SvROK(ST(0))) @@ -662,7 +646,6 @@ XS(XS_Internals_hv_clear_placehold) XS(XS_PerlIO_get_layers); /* prototype to pass -Wmissing-prototypes */ XS(XS_PerlIO_get_layers) { - dVAR; dXSARGS; if (items < 1 || items % 2 == 0) croak_xs_usage(cv, "filehandle[,args]"); @@ -684,19 +667,19 @@ XS(XS_PerlIO_get_layers) switch (*key) { case 'i': - if (klen == 5 && memEQ(key, "input", 5)) { + if (memEQs(key, klen, "input")) { input = SvTRUE(*valp); break; } goto fail; case 'o': - if (klen == 6 && memEQ(key, "output", 6)) { + if (memEQs(key, klen, "output")) { input = !SvTRUE(*valp); break; } goto fail; case 'd': - if (klen == 7 && memEQ(key, "details", 7)) { + if (memEQs(key, klen, "details")) { details = SvTRUE(*valp); break; } @@ -722,7 +705,7 @@ XS(XS_PerlIO_get_layers) AV* const av = PerlIO_get_layers(aTHX_ input ? IoIFP(io) : IoOFP(io)); SSize_t i; - const SSize_t last = av_len(av); + const SSize_t last = av_tindex(av); SSize_t nitem = 0; for (i = last; i >= 0; i -= 3) { @@ -756,7 +739,7 @@ XS(XS_PerlIO_get_layers) } else { if (namok && argok) - PUSHs(sv_2mortal(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")", + PUSHs(sv_2mortal(Perl_newSVpvf(aTHX_ "%" SVf "(%" SVf ")", SVfARG(*namsvp), SVfARG(*argsvp)))); else if (namok) @@ -785,13 +768,10 @@ XS(XS_PerlIO_get_layers) XSRETURN(0); } - XS(XS_re_is_regexp); /* prototype to pass -Wmissing-prototypes */ XS(XS_re_is_regexp) { - dVAR; dXSARGS; - PERL_UNUSED_VAR(cv); if (items != 1) croak_xs_usage(cv, "sv"); @@ -808,15 +788,11 @@ XS(XS_re_regnames_count) { REGEXP *rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL; SV * ret; - dVAR; dXSARGS; if (items != 0) croak_xs_usage(cv, ""); - SP -= items; - PUTBACK; - if (!rx) XSRETURN_UNDEF; @@ -830,7 +806,6 @@ XS(XS_re_regnames_count) XS(XS_re_regname); /* prototype to pass -Wmissing-prototypes */ XS(XS_re_regname) { - dVAR; dXSARGS; REGEXP * rx; U32 flags; @@ -847,7 +822,7 @@ XS(XS_re_regname) if (!rx) XSRETURN_UNDEF; - if (items == 2 && SvTRUE(ST(1))) { + if (items == 2 && SvTRUE_NN(ST(1))) { flags = RXapif_ALL; } else { flags = RXapif_ONE; @@ -863,7 +838,6 @@ XS(XS_re_regname) XS(XS_re_regnames); /* prototype to pass -Wmissing-prototypes */ XS(XS_re_regnames) { - dVAR; dXSARGS; REGEXP * rx; U32 flags; @@ -881,7 +855,7 @@ XS(XS_re_regnames) if (!rx) XSRETURN_UNDEF; - if (items == 1 && SvTRUE(ST(0))) { + if (items == 1 && SvTRUE_NN(ST(0))) { flags = RXapif_ALL; } else { flags = RXapif_ONE; @@ -898,7 +872,7 @@ XS(XS_re_regnames) XSRETURN_UNDEF; av = MUTABLE_AV(SvRV(ret)); - length = av_len(av); + length = av_tindex(av); EXTEND(SP, length+1); /* better extend stack just once */ for (i = 0; i <= length; i++) { @@ -919,9 +893,9 @@ XS(XS_re_regnames) XS(XS_re_regexp_pattern); /* prototype to pass -Wmissing-prototypes */ XS(XS_re_regexp_pattern) { - dVAR; dXSARGS; REGEXP *re; + U8 const gimme = GIMME_V; EXTEND(SP, 2); SP -= items; @@ -944,7 +918,7 @@ XS(XS_re_regexp_pattern) /* Houston, we have a regex! */ SV *pattern; - if ( GIMME_V == G_ARRAY ) { + if ( gimme == G_ARRAY ) { STRLEN left = 0; char reflags[sizeof(INT_PAT_MODS) + MAX_CHARSET_NAME_LENGTH]; const char *fptr; @@ -984,21 +958,16 @@ XS(XS_re_regexp_pattern) XSRETURN(2); } else { /* Scalar, so use the string that Perl would return */ - /* return the pattern in (?msix:..) format */ -#if PERL_VERSION >= 11 + /* return the pattern in (?msixn:..) format */ pattern = sv_2mortal(newSVsv(MUTABLE_SV(re))); -#else - pattern = newSVpvn_flags(RX_WRAPPED(re), RX_WRAPLEN(re), - (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP); -#endif PUSHs(pattern); XSRETURN(1); } } else { /* It ain't a regexp folks */ - if ( GIMME_V == G_ARRAY ) { + if ( gimme == G_ARRAY ) { /* return the empty list */ - XSRETURN_UNDEF; + XSRETURN_EMPTY; } else { /* Because of the (?:..) wrapping involved in a stringified pattern it is impossible to get a @@ -1014,9 +983,28 @@ XS(XS_re_regexp_pattern) XSRETURN_NO; } } - /* NOT-REACHED */ + NOT_REACHED; /* NOTREACHED */ +} + +#ifdef HAS_GETCWD + +XS(XS_Internals_getcwd) +{ + dXSARGS; + SV *sv = sv_newmortal(); + + if (items != 0) + croak_xs_usage(cv, ""); + + (void)getcwd_sv(sv); + + SvTAINTED_on(sv); + PUSHs(sv); + XSRETURN(1); } +#endif + #include "vutil.h" #include "vxs.inc" @@ -1026,7 +1014,7 @@ struct xsub_details { const char *proto; }; -static const struct xsub_details details[] = { +static const struct xsub_details these_details[] = { {"UNIVERSAL::isa", XS_UNIVERSAL_isa, NULL}, {"UNIVERSAL::can", XS_UNIVERSAL_can, NULL}, {"UNIVERSAL::DOES", XS_UNIVERSAL_DOES, NULL}, @@ -1042,46 +1030,108 @@ static const struct xsub_details details[] = { {"utf8::native_to_unicode", XS_utf8_native_to_unicode, NULL}, {"utf8::unicode_to_native", XS_utf8_unicode_to_native, NULL}, {"Internals::SvREADONLY", XS_Internals_SvREADONLY, "\\[$%@];$"}, - {"constant::_make_const", XS_constant__make_const, "\\[$@]"}, {"Internals::SvREFCNT", XS_Internals_SvREFCNT, "\\[$%@];$"}, {"Internals::hv_clear_placeholders", XS_Internals_hv_clear_placehold, "\\%"}, + {"constant::_make_const", XS_constant__make_const, "\\[$@]"}, {"PerlIO::get_layers", XS_PerlIO_get_layers, "*;@"}, {"re::is_regexp", XS_re_is_regexp, "$"}, {"re::regname", XS_re_regname, ";$$"}, {"re::regnames", XS_re_regnames, ";$"}, {"re::regnames_count", XS_re_regnames_count, ""}, {"re::regexp_pattern", XS_re_regexp_pattern, "$"}, +#ifdef HAS_GETCWD + {"Internals::getcwd", XS_Internals_getcwd, ""}, +#endif }; +STATIC OP* +optimize_out_native_convert_function(pTHX_ OP* entersubop, + GV* namegv, + SV* protosv) +{ + /* Optimizes out an identity function, i.e., one that just returns its + * argument. The passed in function is assumed to be an identity function, + * with no checking. This is designed to be called for utf8_to_native() + * and native_to_utf8() on ASCII platforms, as they just return their + * arguments, but it could work on any such function. + * + * The code is mostly just cargo-culted from Memoize::Lift */ + + OP *pushop, *argop; + OP *parent; + SV* prototype = newSVpvs("$"); + + PERL_UNUSED_ARG(protosv); + + assert(entersubop->op_type == OP_ENTERSUB); + + entersubop = ck_entersub_args_proto(entersubop, namegv, prototype); + parent = entersubop; + + SvREFCNT_dec(prototype); + + pushop = cUNOPx(entersubop)->op_first; + if (! OpHAS_SIBLING(pushop)) { + parent = pushop; + pushop = cUNOPx(pushop)->op_first; + } + argop = OpSIBLING(pushop); + + /* Carry on without doing the optimization if it is not something we're + * expecting, so continues to work */ + if ( ! argop + || ! OpHAS_SIBLING(argop) + || OpHAS_SIBLING(OpSIBLING(argop)) + ) { + return entersubop; + } + + /* cut argop from the subtree */ + (void)op_sibling_splice(parent, pushop, 1, NULL); + + op_free(entersubop); + return argop; +} + void Perl_boot_core_UNIVERSAL(pTHX) { - dVAR; static const char file[] = __FILE__; - const struct xsub_details *xsub = details; - const struct xsub_details *end - = details + sizeof(details) / sizeof(details[0]); + const struct xsub_details *xsub = these_details; + const struct xsub_details *end = C_ARRAY_END(these_details); do { newXS_flags(xsub->name, xsub->xsub, file, xsub->proto, 0); } while (++xsub < end); +#ifndef EBCDIC + { /* On ASCII platforms these functions just return their argument, so can + be optimized away */ + + CV* to_native_cv = get_cv("utf8::unicode_to_native", 0); + CV* to_unicode_cv = get_cv("utf8::native_to_unicode", 0); + + cv_set_call_checker_flags(to_native_cv, + optimize_out_native_convert_function, + (SV*) to_native_cv, 0); + cv_set_call_checker_flags(to_unicode_cv, + optimize_out_native_convert_function, + (SV*) to_unicode_cv, 0); + } +#endif + /* Providing a Regexp::DESTROY fixes #21347. See test in t/op/ref.t */ { CV * const cv = newCONSTSUB(get_hv("Regexp::", GV_ADD), "DESTROY", NULL); - Safefree(CvFILE(cv)); - CvFILE(cv) = (char *)file; + char ** cvfile = &CvFILE(cv); + char * oldfile = *cvfile; CvDYNFILE_off(cv); + *cvfile = (char *)file; + Safefree(oldfile); } } /* - * Local variables: - * c-indentation-style: bsd - * c-basic-offset: 4 - * indent-tabs-mode: nil - * End: - * * ex: set ts=8 sts=4 sw=4 et: */