X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/ae77754ae288180ef1b6bab63dd49fa724d9fddd..c77726bb7bf6d340166d67aac247e2e307158a9a:/universal.c diff --git a/universal.c b/universal.c index 200ce87..66eafc5 100644 --- a/universal.c +++ b/universal.c @@ -205,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; @@ -222,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; @@ -294,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 */ @@ -303,27 +307,30 @@ void Perl_croak_xs_usage(const CV *const cv, const char *const params) { /* Avoid CvGV as it requires aTHX. */ - const GV *const gv = CvNAMED(cv) ? NULL : cv->sv_any->xcv_gv_u.xcv_gv; + 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); } } @@ -502,9 +509,10 @@ XS(XS_utf8_downgrade) if (items < 1 || items > 2) croak_xs_usage(cv, "sv, failok=0"); else { - SV * const sv = ST(0); - const bool failok = (items < 2) ? 0 : SvTRUE(ST(1)) ? 1 : 0; - 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); } @@ -520,7 +528,7 @@ XS(XS_utf8_native_to_unicode) 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); } @@ -533,7 +541,7 @@ XS(XS_utf8_unicode_to_native) 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); } @@ -543,7 +551,6 @@ XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */ dXSARGS; SV * const svz = ST(0); SV * sv; - PERL_UNUSED_ARG(cv); /* [perl #77776] - called as &foo() not foo() */ if (!SvROK(svz)) @@ -558,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; } } @@ -580,7 +585,6 @@ XS(XS_constant__make_const) /* This is dangerous stuff. */ dXSARGS; SV * const svz = ST(0); SV * sv; - PERL_UNUSED_ARG(cv); /* [perl #77776] - called as &foo() not foo() */ if (!SvROK(svz) || items != 1) @@ -588,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 @@ -611,7 +612,6 @@ XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */ 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)) @@ -667,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; } @@ -739,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) @@ -768,12 +768,10 @@ XS(XS_PerlIO_get_layers) XSRETURN(0); } - XS(XS_re_is_regexp); /* prototype to pass -Wmissing-prototypes */ XS(XS_re_is_regexp) { dXSARGS; - PERL_UNUSED_VAR(cv); if (items != 1) croak_xs_usage(cv, "sv"); @@ -795,9 +793,6 @@ XS(XS_re_regnames_count) if (items != 0) croak_xs_usage(cv, ""); - SP -= items; - PUTBACK; - if (!rx) XSRETURN_UNDEF; @@ -827,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; @@ -860,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; @@ -900,6 +895,7 @@ XS(XS_re_regexp_pattern) { dXSARGS; REGEXP *re; + U8 const gimme = GIMME_V; EXTEND(SP, 2); SP -= items; @@ -922,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; @@ -962,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 @@ -992,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" @@ -1004,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}, @@ -1020,44 +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) { static const char file[] = __FILE__; - const struct xsub_details *xsub = details; - const struct xsub_details *end = C_ARRAY_END(details); + 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: */