X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/10f9b9bf77ed09ee67da058d1ba1658a4ce67626..f47d3375897f813737cab9a7ccbc3b404dd73b84:/universal.c diff --git a/universal.c b/universal.c index b4ae238..2262939 100644 --- a/universal.c +++ b/universal.c @@ -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,7 @@ 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", + Perl_croak(aTHX_ "Usage: %" SVf "::%" SVf "(%s)", "ouch" "awk", "eee_yow"); =cut @@ -313,13 +316,13 @@ Perl_croak_xs_usage(const CV *const cv, const char *const params) 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; @@ -327,7 +330,7 @@ Perl_croak_xs_usage(const CV *const cv, const char *const params) /* Pants. I don't think that it should be possible to get here. */ /* diag_listed_as: SKIPME */ - Perl_croak(aTHX_ "Usage: CODE(0x%"UVxf")(%s)", PTR2UV(cv), params); + Perl_croak(aTHX_ "Usage: CODE(0x%" UVxf ")(%s)", PTR2UV(cv), params); } } @@ -506,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); } @@ -547,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)) @@ -562,7 +565,8 @@ XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */ XSRETURN_NO; } else if (items == 2) { - if (SvTRUE(ST(1))) { + SV *sv1 = ST(1); + if (SvTRUE_NN(sv1)) { SvFLAGS(sv) |= SVf_READONLY; XSRETURN_YES; } @@ -581,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) @@ -609,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)) @@ -627,6 +629,20 @@ 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) +{ + dXSARGS; + + if (items != 1 || !SvROK(ST(0))) + croak_xs_usage(cv, "hv"); + else { + HV * const hv = MUTABLE_HV(SvRV(ST(0))); + hv_clear_placeholders(hv); + XSRETURN(0); + } +} + XS(XS_PerlIO_get_layers); /* prototype to pass -Wmissing-prototypes */ XS(XS_PerlIO_get_layers) { @@ -651,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; } @@ -723,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) @@ -752,73 +768,10 @@ XS(XS_PerlIO_get_layers) XSRETURN(0); } -XS(XS_hash_util_bucket_ratio); /* prototype to pass -Wmissing-prototypes */ -XS(XS_hash_util_bucket_ratio) -{ - dXSARGS; - SV *rhv; - PERL_UNUSED_VAR(cv); - - if (items != 1) - croak_xs_usage(cv, "hv"); - - rhv= ST(0); - if (SvROK(rhv)) { - rhv= SvRV(rhv); - if ( SvTYPE(rhv)==SVt_PVHV ) { - SV *ret= Perl_hv_bucket_ratio(aTHX_ (HV*)rhv); - ST(0)= ret; - XSRETURN(1); - } - } - XSRETURN_UNDEF; -} - -XS(XS_hash_util_num_buckets); /* prototype to pass -Wmissing-prototypes */ -XS(XS_hash_util_num_buckets) -{ - dXSARGS; - SV *rhv; - PERL_UNUSED_VAR(cv); - - if (items != 1) - croak_xs_usage(cv, "hv"); - - rhv= ST(0); - if (SvROK(rhv)) { - rhv= SvRV(rhv); - if ( SvTYPE(rhv)==SVt_PVHV ) { - XSRETURN_UV(HvMAX((HV*)rhv)+1); - } - } - XSRETURN_UNDEF; -} - -XS(XS_hash_util_used_buckets); /* prototype to pass -Wmissing-prototypes */ -XS(XS_hash_util_used_buckets) -{ - dXSARGS; - SV *rhv; - PERL_UNUSED_VAR(cv); - - if (items != 1) - croak_xs_usage(cv, "hv"); - - rhv= ST(0); - if (SvROK(rhv)) { - rhv= SvRV(rhv); - if ( SvTYPE(rhv)==SVt_PVHV ) { - XSRETURN_UV(HvFILL((HV*)rhv)); - } - } - XSRETURN_UNDEF; -} - 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"); @@ -869,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; @@ -902,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; @@ -1006,12 +959,7 @@ XS(XS_re_regexp_pattern) } else { /* Scalar, so use the string that Perl would return */ /* return the pattern in (?msixn:..) format */ -#if PERL_VERSION >= 11 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); } @@ -1063,12 +1011,10 @@ 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, "*;@"}, - {"Hash::Util::bucket_ratio", XS_hash_util_bucket_ratio, "\\%"}, - {"Hash::Util::num_buckets", XS_hash_util_num_buckets, "\\%"}, - {"Hash::Util::used_buckets", XS_hash_util_used_buckets, "\\%"}, {"re::is_regexp", XS_re_is_regexp, "$"}, {"re::regname", XS_re_regname, ";$$"}, {"re::regnames", XS_re_regnames, ";$"}, @@ -1143,12 +1089,12 @@ Perl_boot_core_UNIVERSAL(pTHX) 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(to_native_cv, + cv_set_call_checker_flags(to_native_cv, optimize_out_native_convert_function, - (SV*) to_native_cv); - cv_set_call_checker(to_unicode_cv, + (SV*) to_native_cv, 0); + cv_set_call_checker_flags(to_unicode_cv, optimize_out_native_convert_function, - (SV*) to_unicode_cv); + (SV*) to_unicode_cv, 0); } #endif