X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/14d04a33467fd25c9767918f61a2bfaec64b0cfa..6b976e32dcccdff3dde7682ad9314dc5cd918e17:/universal.c diff --git a/universal.c b/universal.c index af3207f..f583817 100644 --- a/universal.c +++ b/universal.c @@ -164,6 +164,8 @@ Perl_sv_derived_from_pvn(pTHX_ SV *sv, const char *const name, const STRLEN len, } else { stash = gv_stashsv(sv, 0); + if (!stash) + stash = gv_stashpvs("UNIVERSAL", 0); } return stash ? isa_lookup(stash, name, len, flags) : FALSE; @@ -196,8 +198,7 @@ Perl_sv_does_sv(pTHX_ SV *sv, SV *namesv, U32 flags) SvGETMAGIC(sv); - if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv)) - || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv)))) { + if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv)))) { LEAVE; return FALSE; } @@ -297,7 +298,7 @@ C. Hence if C is C<&ouch::awk>, it would call C as: */ void -Perl_croak_xs_usage(pTHX_ const CV *const cv, const char *const params) +Perl_croak_xs_usage(const CV *const cv, const char *const params) { const GV *const gv = CvGV(cv); @@ -307,16 +308,16 @@ Perl_croak_xs_usage(pTHX_ const CV *const cv, const char *const params) const HV *const stash = GvSTASH(gv); if (HvNAME_get(stash)) - Perl_croak(aTHX_ "Usage: %"HEKf"::%"HEKf"(%s)", + Perl_croak_nocontext("Usage: %"HEKf"::%"HEKf"(%s)", HEKfARG(HvNAME_HEK(stash)), HEKfARG(GvNAME_HEK(gv)), params); else - Perl_croak(aTHX_ "Usage: %"HEKf"(%s)", + Perl_croak_nocontext("Usage: %"HEKf"(%s)", HEKfARG(GvNAME_HEK(gv)), params); } else { /* Pants. I don't think that it should be possible to get here. */ - Perl_croak(aTHX_ "Usage: CODE(0x%"UVxf")(%s)", PTR2UV(cv), params); + Perl_croak_nocontext("Usage: CODE(0x%"UVxf")(%s)", PTR2UV(cv), params); } } @@ -332,8 +333,7 @@ XS(XS_UNIVERSAL_isa) SvGETMAGIC(sv); - if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv)) - || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv)))) + if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv)))) XSRETURN_UNDEF; ST(0) = boolSV(sv_derived_from_sv(sv, ST(1), 0)); @@ -356,8 +356,8 @@ XS(XS_UNIVERSAL_can) SvGETMAGIC(sv); - if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv)) - || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv)))) + if (!SvOK(sv) || !(SvROK(sv) || SvNIOK(sv) || (SvPOK(sv) && SvCUR(sv)) + )) XSRETURN_UNDEF; rv = &PL_sv_undef; @@ -369,6 +369,8 @@ XS(XS_UNIVERSAL_can) } else { pkg = gv_stashsv(sv, 0); + if (!pkg) + pkg = gv_stashpv("UNIVERSAL", 0); } if (pkg) { @@ -806,6 +808,7 @@ XS(XS_utf8_encode) if (items != 1) croak_xs_usage(cv, "sv"); sv_utf8_encode(ST(0)); + SvSETMAGIC(ST(0)); XSRETURN_EMPTY; } @@ -820,6 +823,7 @@ XS(XS_utf8_decode) bool RETVAL; SvPV_force_nolen(sv); RETVAL = sv_utf8_decode(sv); + SvSETMAGIC(sv); ST(0) = boolSV(RETVAL); } XSRETURN(1); @@ -918,29 +922,29 @@ XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */ } XSRETURN_UNDEF; /* Can't happen. */ } - 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 (!SvROK(svz)) + if ((items != 1 && items != 2) || !SvROK(svz)) croak_xs_usage(cv, "SCALAR[, REFCOUNT]"); sv = SvRV(svz); - if (items == 1) - XSRETURN_UV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */ - else if (items == 2) { /* I hope you really know what you are doing. */ - SvREFCNT(sv) = SvUV(ST(1)) + 1; /* we free one ref on exit */ - XSRETURN_UV(SvREFCNT(sv) - 1); - } - XSRETURN_UNDEF; /* Can't happen. */ + /* idea is for SvREFCNT(sv) to be accessed only once */ + refcnt = items == 2 ? + /* we free one ref on exit */ + (SvREFCNT(sv) = SvUV(ST(1)) + 1) + : SvREFCNT(sv); + XSRETURN_UV(refcnt - 1); /* Minus the ref created for us. */ + } XS(XS_Internals_hv_clear_placehold) @@ -1031,40 +1035,41 @@ XS(XS_PerlIO_get_layers) const bool argok = argsvp && *argsvp && SvPOK(*argsvp); const bool flgok = flgsvp && *flgsvp && SvIOK(*flgsvp); + EXTEND(SP, 3); /* Three is the max in all branches: better check just once */ if (details) { /* Indents of 5? Yuck. */ /* We know that PerlIO_get_layers creates a new SV for the name and flags, so we can just take a reference and "steal" it when we free the AV below. */ - XPUSHs(namok + PUSHs(namok ? sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp)) : &PL_sv_undef); - XPUSHs(argok + PUSHs(argok ? newSVpvn_flags(SvPVX_const(*argsvp), SvCUR(*argsvp), (SvUTF8(*argsvp) ? SVf_UTF8 : 0) | SVs_TEMP) : &PL_sv_undef); - XPUSHs(flgok + PUSHs(flgok ? sv_2mortal(SvREFCNT_inc_simple_NN(*flgsvp)) : &PL_sv_undef); nitem += 3; } else { if (namok && argok) - XPUSHs(sv_2mortal(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")", + PUSHs(sv_2mortal(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")", SVfARG(*namsvp), SVfARG(*argsvp)))); else if (namok) - XPUSHs(sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp))); + PUSHs(sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp))); else - XPUSHs(&PL_sv_undef); + PUSHs(&PL_sv_undef); nitem++; if (flgok) { const IV flags = SvIVX(*flgsvp); if (flags & PERLIO_F_UTF8) { - XPUSHs(newSVpvs_flags("utf8", SVs_TEMP)); + PUSHs(newSVpvs_flags("utf8", SVs_TEMP)); nitem++; } } @@ -1081,44 +1086,6 @@ XS(XS_PerlIO_get_layers) XSRETURN(0); } -XS(XS_Internals_hash_seed) -{ - dVAR; - /* Using dXSARGS would also have dITEM and dSP, - * which define 2 unused local variables. */ - dAXMARK; - PERL_UNUSED_ARG(cv); - PERL_UNUSED_VAR(mark); - XSRETURN_UV(PERL_HASH_SEED); -} - -XS(XS_Internals_rehash_seed) -{ - dVAR; - /* Using dXSARGS would also have dITEM and dSP, - * which define 2 unused local variables. */ - dAXMARK; - PERL_UNUSED_ARG(cv); - PERL_UNUSED_VAR(mark); - XSRETURN_UV(PL_rehash_seed); -} - -XS(XS_Internals_HvREHASH) /* Subject to change */ -{ - dVAR; - dXSARGS; - PERL_UNUSED_ARG(cv); - if (SvROK(ST(0))) { - const HV * const hv = (const HV *) SvRV(ST(0)); - if (items == 1 && SvTYPE(hv) == SVt_PVHV) { - if (HvREHASH(hv)) - XSRETURN_YES; - else - XSRETURN_NO; - } - } - Perl_croak(aTHX_ "Internals::HvREHASH $hashref"); -} XS(XS_re_is_regexp) { @@ -1230,13 +1197,14 @@ XS(XS_re_regnames) av = MUTABLE_AV(SvRV(ret)); length = av_len(av); + EXTEND(SP, length+1); /* better extend stack just once */ for (i = 0; i <= length; i++) { entry = av_fetch(av, i, FALSE); if (!entry) Perl_croak(aTHX_ "NULL array element in re::regnames()"); - mXPUSHs(SvREFCNT_inc_simple_NN(*entry)); + mPUSHs(SvREFCNT_inc_simple_NN(*entry)); } SvREFCNT_dec(ret); @@ -1251,11 +1219,11 @@ XS(XS_re_regexp_pattern) dXSARGS; REGEXP *re; + EXTEND(SP, 2); + SP -= items; if (items != 1) croak_xs_usage(cv, "sv"); - SP -= items; - /* Checks if a reference is a regex or not. If the parameter is not a ref, or is not the result of a qr// then returns false @@ -1307,8 +1275,8 @@ XS(XS_re_regexp_pattern) (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP); /* return the pattern and the modifiers */ - XPUSHs(pattern); - XPUSHs(newSVpvn_flags(reflags, left, SVs_TEMP)); + PUSHs(pattern); + PUSHs(newSVpvn_flags(reflags, left, SVs_TEMP)); XSRETURN(2); } else { /* Scalar, so use the string that Perl would return */ @@ -1319,7 +1287,7 @@ XS(XS_re_regexp_pattern) pattern = newSVpvn_flags(RX_WRAPPED(re), RX_WRAPLEN(re), (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP); #endif - XPUSHs(pattern); + PUSHs(pattern); XSRETURN(1); } } else { @@ -1351,7 +1319,7 @@ struct xsub_details { const char *proto; }; -struct xsub_details details[] = { +const struct xsub_details details[] = { {"UNIVERSAL::isa", XS_UNIVERSAL_isa, NULL}, {"UNIVERSAL::can", XS_UNIVERSAL_can, NULL}, {"UNIVERSAL::DOES", XS_UNIVERSAL_DOES, NULL}, @@ -1396,9 +1364,6 @@ struct xsub_details details[] = { {"Internals::SvREFCNT", XS_Internals_SvREFCNT, "\\[$%@];$"}, {"Internals::hv_clear_placeholders", XS_Internals_hv_clear_placehold, "\\%"}, {"PerlIO::get_layers", XS_PerlIO_get_layers, "*;@"}, - {"Internals::hash_seed", XS_Internals_hash_seed, ""}, - {"Internals::rehash_seed", XS_Internals_rehash_seed, ""}, - {"Internals::HvREHASH", XS_Internals_HvREHASH, "\\%"}, {"re::is_regexp", XS_re_is_regexp, "$"}, {"re::regname", XS_re_regname, ";$$"}, {"re::regnames", XS_re_regnames, ";$"}, @@ -1411,7 +1376,7 @@ Perl_boot_core_UNIVERSAL(pTHX) { dVAR; static const char file[] = __FILE__; - struct xsub_details *xsub = details; + const struct xsub_details *xsub = details; const struct xsub_details *end = details + sizeof(details) / sizeof(details[0]);