X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/c7abbf64034f62cedb5a6bfddec1d84a60828ffd..2e9e14ddec173be05687c2df560a22b6721eae37:/universal.c diff --git a/universal.c b/universal.c index 6ba565d..10fefe1 100644 --- a/universal.c +++ b/universal.c @@ -154,7 +154,7 @@ Perl_sv_derived_from_pvn(pTHX_ SV *sv, const char *const name, const STRLEN len, SvGETMAGIC(sv); - if (SvROK(sv)) { /* hugdo: */ + if (SvROK(sv)) { const char *type; sv = SvRV(sv); type = sv_reftype(sv,0); @@ -164,13 +164,15 @@ 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; } /* -=for apidoc sv_does +=for apidoc sv_does_sv Returns a boolean indicating whether the SV performs a specific, named role. The SV can be a Perl object or the name of a Perl class. @@ -181,40 +183,41 @@ The SV can be a Perl object or the name of a Perl class. #include "XSUB.h" bool -Perl_sv_does(pTHX_ SV *sv, const char *const name) +Perl_sv_does_sv(pTHX_ SV *sv, SV *namesv, U32 flags) { - const char *classname; + SV *classname; bool does_it; SV *methodname; dSP; - PERL_ARGS_ASSERT_SV_DOES; + PERL_ARGS_ASSERT_SV_DOES_SV; + PERL_UNUSED_ARG(flags); ENTER; SAVETMPS; 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; } if (sv_isobject(sv)) { - classname = sv_reftype(SvRV(sv),TRUE); + classname = sv_ref(NULL,SvRV(sv),TRUE); } else { - classname = SvPV_nolen(sv); + classname = sv; } - if (strEQ(name,classname)) { + if (sv_eq(classname, namesv)) { LEAVE; return TRUE; } PUSHMARK(SP); - XPUSHs(sv); - mXPUSHs(newSVpv(name, 0)); + EXTEND(SP, 2); + PUSHs(sv); + PUSHs(namesv); PUTBACK; methodname = newSVpvs_flags("isa", SVs_TEMP); @@ -233,6 +236,53 @@ Perl_sv_does(pTHX_ SV *sv, const char *const name) } /* +=for apidoc sv_does + +Like L, but doesn't take a C parameter. + +=cut +*/ + +bool +Perl_sv_does(pTHX_ SV *sv, const char *const name) +{ + PERL_ARGS_ASSERT_SV_DOES; + return sv_does_sv(sv, newSVpvn_flags(name, strlen(name), SVs_TEMP), 0); +} + +/* +=for apidoc sv_does_pv + +Like L, but takes a nul-terminated string instead of an SV. + +=cut +*/ + + +bool +Perl_sv_does_pv(pTHX_ SV *sv, const char *const name, U32 flags) +{ + PERL_ARGS_ASSERT_SV_DOES_PV; + return sv_does_sv(sv, newSVpvn_flags(name, strlen(name), SVs_TEMP | flags), flags); +} + +/* +=for apidoc sv_does_pvn + +Like L, but takes a string/length pair instead of an SV. + +=cut +*/ + +bool +Perl_sv_does_pvn(pTHX_ SV *sv, const char *const name, const STRLEN len, U32 flags) +{ + PERL_ARGS_ASSERT_SV_DOES_PVN; + + return sv_does_sv(sv, newSVpvn_flags(name, len, flags | SVs_TEMP), flags); +} + +/* =for apidoc croak_xs_usage A specialised variant of C for emitting the usage message for xsubs @@ -242,30 +292,32 @@ 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: %s::%s(%s)", "ouch" "awk", "eee_yow"); + Perl_croak(aTHX_ "Usage: %"SVf"::%"SVf"(%s)", "ouch" "awk", "eee_yow"); =cut */ 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); PERL_ARGS_ASSERT_CROAK_XS_USAGE; if (gv) { - const char *const gvname = GvNAME(gv); const HV *const stash = GvSTASH(gv); - const char *const hvname = stash ? HvNAME_get(stash) : NULL; - if (hvname) - Perl_croak(aTHX_ "Usage: %s::%s(%s)", hvname, gvname, params); + if (HvNAME_get(stash)) + Perl_croak_nocontext("Usage: %"HEKf"::%"HEKf"(%s)", + HEKfARG(HvNAME_HEK(stash)), + HEKfARG(GvNAME_HEK(gv)), + params); else - Perl_croak(aTHX_ "Usage: %s(%s)", gvname, params); + 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); } } @@ -281,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)); @@ -295,9 +346,9 @@ XS(XS_UNIVERSAL_can) dVAR; dXSARGS; SV *sv; - const char *name; SV *rv; HV *pkg = NULL; + GV *iogv; if (items != 2) croak_xs_usage(cv, "object-ref, method"); @@ -306,24 +357,33 @@ XS(XS_UNIVERSAL_can) SvGETMAGIC(sv); - if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv)) - || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv)))) + /* Reject undef and empty string. Note that the string form takes + precedence here over the numeric form, as (!1)->foo treats the + invocant as the empty string, though it is a dualvar. */ + if (!SvOK(sv) || (SvPOK(sv) && !SvCUR(sv))) XSRETURN_UNDEF; - name = SvPV_nolen_const(ST(1)); rv = &PL_sv_undef; if (SvROK(sv)) { sv = MUTABLE_SV(SvRV(sv)); if (SvOBJECT(sv)) pkg = SvSTASH(sv); + else if (isGV_with_GP(sv) && GvIO(sv)) + pkg = SvSTASH(GvIO(sv)); } + else if (isGV_with_GP(sv) && GvIO(sv)) + pkg = SvSTASH(GvIO(sv)); + else if ((iogv = gv_fetchsv_nomg(sv, 0, SVt_PVIO)) && GvIO(iogv)) + pkg = SvSTASH(GvIO(iogv)); else { pkg = gv_stashsv(sv, 0); + if (!pkg) + pkg = gv_stashpv("UNIVERSAL", 0); } if (pkg) { - GV * const gv = gv_fetchmethod_autoload(pkg, name, FALSE); + GV * const gv = gv_fetchmethod_sv_flags(pkg, ST(1), 0); if (gv && isGV(gv)) rv = sv_2mortal(newRV(MUTABLE_SV(GvCV(gv)))); } @@ -342,10 +402,7 @@ XS(XS_UNIVERSAL_DOES) Perl_croak(aTHX_ "Usage: invocant->DOES(kind)"); else { SV * const sv = ST(0); - const char *name; - - name = SvPV_nolen_const(ST(1)); - if (sv_does( sv, name )) + if (sv_does_sv( sv, ST(1), 0 )) XSRETURN_YES; XSRETURN_NO; @@ -360,7 +417,6 @@ XS(XS_UNIVERSAL_VERSION) GV **gvp; GV *gv; SV *sv; - SV *ret; const char *undef; PERL_UNUSED_ARG(cv); @@ -377,12 +433,16 @@ XS(XS_UNIVERSAL_VERSION) gvp = pkg ? (GV**)hv_fetchs(pkg, "VERSION", FALSE) : NULL; if (gvp && isGV(gv = *gvp) && (sv = GvSV(gv)) && SvOK(sv)) { - ret = sv_newmortal(); - sv_setsv(ret, sv); + SV * const nsv = sv_newmortal(); + sv_setsv(nsv, sv); + sv = nsv; + if ( !sv_isobject(sv) || !sv_derived_from(sv, "version")) + upg_version(sv, FALSE); + undef = NULL; } else { - sv = ret = &PL_sv_undef; + sv = &PL_sv_undef; undef = "(undef)"; } @@ -391,34 +451,34 @@ XS(XS_UNIVERSAL_VERSION) if (undef) { if (pkg) { - const char * const name = HvNAME_get(pkg); + const HEK * const name = HvNAME_HEK(pkg); Perl_croak(aTHX_ - "%s does not define $%s::VERSION--version check failed", - name, name); + "%"HEKf" does not define $%"HEKf + "::VERSION--version check failed", + HEKfARG(name), HEKfARG(name)); } else { Perl_croak(aTHX_ - "%s defines neither package nor VERSION--version check failed", - SvPVx_nolen_const(ST(0)) ); + "%"SVf" defines neither package nor VERSION--version check failed", + SVfARG(ST(0)) ); } } - if ( !sv_derived_from(sv, "version")) - upg_version(sv, FALSE); - - if ( !sv_derived_from(req, "version")) { + if ( !sv_isobject(req) || !sv_derived_from(req, "version")) { /* req may very well be R/O, so create a new object */ req = sv_2mortal( new_version(req) ); } if ( vcmp( req, sv ) > 0 ) { if ( hv_exists(MUTABLE_HV(SvRV(req)), "qv", 2 ) ) { - Perl_croak(aTHX_ "%s version %"SVf" required--" - "this is only version %"SVf"", HvNAME_get(pkg), + Perl_croak(aTHX_ "%"HEKf" version %"SVf" required--" + "this is only version %"SVf"", + HEKfARG(HvNAME_HEK(pkg)), SVfARG(sv_2mortal(vnormal(req))), SVfARG(sv_2mortal(vnormal(sv)))); } else { - Perl_croak(aTHX_ "%s version %"SVf" required--" - "this is only version %"SVf"", HvNAME_get(pkg), + Perl_croak(aTHX_ "%"HEKf" version %"SVf" required--" + "this is only version %"SVf, + HEKfARG(HvNAME_HEK(pkg)), SVfARG(sv_2mortal(vstringify(req))), SVfARG(sv_2mortal(vstringify(sv)))); } @@ -426,7 +486,11 @@ XS(XS_UNIVERSAL_VERSION) } - ST(0) = ret; + if ( SvOK(sv) && sv_derived_from(sv, "version") ) { + ST(0) = sv_2mortal(vstringify(sv)); + } else { + ST(0) = sv; + } XSRETURN(1); } @@ -435,16 +499,25 @@ XS(XS_version_new) { dVAR; dXSARGS; - if (items > 3) + if (items > 3 || items < 1) croak_xs_usage(cv, "class, version"); SP -= items; { SV *vs = ST(1); SV *rv; - const char * const classname = - sv_isobject(ST(0)) /* get the class if called as an object method */ - ? HvNAME(SvSTASH(SvRV(ST(0)))) - : (char *)SvPV_nolen(ST(0)); + STRLEN len; + const char *classname; + U32 flags; + if ( sv_isobject(ST(0)) ) { /* get the class if called as an object method */ + const HV * stash = SvSTASH(SvRV(ST(0))); + classname = HvNAME(stash); + len = HvNAMELEN(stash); + flags = HvNAMEUTF8(stash) ? SVf_UTF8 : 0; + } + else { + classname = SvPV(ST(0), len); + flags = SvUTF8(ST(0)); + } if ( items == 1 || ! SvOK(vs) ) { /* no param or explicit undef */ /* create empty object */ @@ -457,8 +530,8 @@ XS(XS_version_new) } rv = new_version(vs); - if ( strcmp(classname,"version") != 0 ) /* inherited new() */ - sv_bless(rv, gv_stashpv(classname, GV_ADD)); + if ( strnNE(classname,"version", len) ) /* inherited new() */ + sv_bless(rv, gv_stashpvn(classname, len, GV_ADD | flags)); mPUSHs(rv); PUTBACK; @@ -476,7 +549,7 @@ XS(XS_version_stringify) { SV * lobj = ST(0); - if (sv_derived_from(lobj, "version") && SvROK(lobj)) { + if (sv_isobject(lobj) && sv_derived_from(lobj, "version")) { lobj = SvRV(lobj); } else @@ -499,7 +572,7 @@ XS(XS_version_numify) { SV * lobj = ST(0); - if (sv_derived_from(lobj, "version") && SvROK(lobj)) { + if (sv_isobject(lobj) && sv_derived_from(lobj, "version")) { lobj = SvRV(lobj); } else @@ -522,7 +595,7 @@ XS(XS_version_normal) { SV * lobj = ST(0); - if (sv_derived_from(lobj, "version") && SvROK(lobj)) { + if (sv_isobject(lobj) && sv_derived_from(lobj, "version")) { lobj = SvRV(lobj); } else @@ -545,7 +618,7 @@ XS(XS_version_vcmp) { SV * lobj = ST(0); - if (sv_derived_from(lobj, "version") && SvROK(lobj)) { + if (sv_isobject(lobj) && sv_derived_from(lobj, "version")) { lobj = SvRV(lobj); } else @@ -557,7 +630,7 @@ XS(XS_version_vcmp) SV * robj = ST(1); const IV swap = (IV)SvIV(ST(2)); - if ( ! sv_derived_from(robj, "version") ) + if ( !sv_isobject(robj) || !sv_derived_from(robj, "version") ) { robj = new_version(SvOK(robj) ? robj : newSVpvs_flags("0", SVs_TEMP)); sv_2mortal(robj); @@ -588,9 +661,15 @@ XS(XS_version_boolean) if (items < 1) croak_xs_usage(cv, "lobj, ..."); SP -= items; - if (sv_derived_from(ST(0), "version") && SvROK(ST(0))) { + if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version")) { SV * const lobj = SvRV(ST(0)); - SV * const rs = newSViv( vcmp(lobj,new_version(newSVpvs("0"))) ); + SV * const rs = + newSViv( vcmp(lobj, + sv_2mortal(new_version( + sv_2mortal(newSVpvs("0")) + )) + ) + ); mPUSHs(rs); PUTBACK; return; @@ -605,7 +684,7 @@ XS(XS_version_noop) dXSARGS; if (items < 1) croak_xs_usage(cv, "lobj, ..."); - if (sv_derived_from(ST(0), "version") && SvROK(ST(0))) + if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version")) Perl_croak(aTHX_ "operation not supported with version object"); else Perl_croak(aTHX_ "lobj is not of type version"); @@ -621,7 +700,7 @@ XS(XS_version_is_alpha) if (items != 1) croak_xs_usage(cv, "lobj"); SP -= items; - if (sv_derived_from(ST(0), "version") && SvROK(ST(0))) { + if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version")) { SV * const lobj = ST(0); if ( hv_exists(MUTABLE_HV(SvRV(lobj)), "alpha", 5 ) ) XSRETURN_YES; @@ -643,15 +722,22 @@ XS(XS_version_qv) { SV * ver = ST(0); SV * rv; - const char * classname = ""; - if ( items == 2 && SvOK(ST(1)) ) { - /* getting called as object or class method */ - ver = ST(1); - classname = - sv_isobject(ST(0)) /* class called as an object method */ - ? HvNAME_get(SvSTASH(SvRV(ST(0)))) - : (char *)SvPV_nolen(ST(0)); - } + STRLEN len = 0; + const char * classname = ""; + U32 flags = 0; + if ( items == 2 && SvOK(ST(1)) ) { + ver = ST(1); + if ( sv_isobject(ST(0)) ) { /* class called as an object method */ + const HV * stash = SvSTASH(SvRV(ST(0))); + classname = HvNAME(stash); + len = HvNAMELEN(stash); + flags = HvNAMEUTF8(stash) ? SVf_UTF8 : 0; + } + else { + classname = SvPV(ST(0), len); + flags = SvUTF8(ST(0)); + } + } if ( !SvVOK(ver) ) { /* not already a v-string */ rv = sv_newmortal(); sv_setsv(rv,ver); /* make a duplicate */ @@ -659,9 +745,10 @@ XS(XS_version_qv) } else { rv = sv_2mortal(new_version(ver)); } - if ( items == 2 && strcmp(classname,"version") ) { /* inherited new() */ - sv_bless(rv, gv_stashpv(classname, GV_ADD)); - } + if ( items == 2 + && strnNE(classname,"version", len) ) { /* inherited new() */ + sv_bless(rv, gv_stashpvn(classname, len, GV_ADD | flags)); + } PUSHs(rv); } PUTBACK; @@ -675,7 +762,7 @@ XS(XS_version_is_qv) if (items != 1) croak_xs_usage(cv, "lobj"); SP -= items; - if (sv_derived_from(ST(0), "version") && SvROK(ST(0))) { + if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version")) { SV * const lobj = ST(0); if ( hv_exists(MUTABLE_HV(SvRV(lobj)), "qv", 2 ) ) XSRETURN_YES; @@ -730,6 +817,7 @@ XS(XS_utf8_encode) if (items != 1) croak_xs_usage(cv, "sv"); sv_utf8_encode(ST(0)); + SvSETMAGIC(ST(0)); XSRETURN_EMPTY; } @@ -742,8 +830,9 @@ XS(XS_utf8_decode) else { SV * const sv = ST(0); bool RETVAL; - if (SvIsCOW(sv)) sv_force_normal(sv); + SvPV_force_nolen(sv); RETVAL = sv_utf8_decode(sv); + SvSETMAGIC(sv); ST(0) = boolSV(RETVAL); } XSRETURN(1); @@ -823,48 +912,59 @@ XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */ sv = SvRV(svz); if (items == 1) { - if (SvREADONLY(sv) && !SvIsCOW(sv)) + if (SvREADONLY(sv)) XSRETURN_YES; else 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); + if (SvTYPE(sv) == SVt_PVAV && AvFILLp(sv) != -1) { + /* for constant.pm; nobody else should be calling this + on arrays anyway. */ + SV **svp; + for (svp = AvARRAY(sv) + AvFILLp(sv) + ; svp >= AvARRAY(sv) + ; --svp) + if (*svp) SvPADTMP_on(*svp); + } XSRETURN_YES; } else { /* I hope you really know what you are doing. */ - if (!SvIsCOW(sv)) SvREADONLY_off(sv); + SvREADONLY_off(sv); XSRETURN_NO; } } 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_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */ - else if (items == 2) { /* I hope you really know what you are doing. */ - SvREFCNT(sv) = SvIV(ST(1)); - XSRETURN_IV(SvREFCNT(sv)); - } - 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) @@ -934,14 +1034,10 @@ XS(XS_PerlIO_get_layers) } sv = POPs; - gv = MUTABLE_GV(sv); + gv = MAYBE_DEREF_GV(sv); - if (!isGV(sv)) { - if (SvROK(sv) && isGV(SvRV(sv))) - gv = MUTABLE_GV(SvRV(sv)); - else if (SvPOKp(sv)) - gv = gv_fetchsv(sv, 0, SVt_PVIO); - } + if (!gv && !SvROK(sv)) + gv = gv_fetchsv_nomg(sv, 0, SVt_PVIO); if (gv && (io = GvIO(gv))) { AV* const av = PerlIO_get_layers(aTHX_ input ? @@ -959,40 +1055,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++; } } @@ -1009,44 +1106,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) { @@ -1158,13 +1217,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); @@ -1179,11 +1239,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 @@ -1235,8 +1295,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 */ @@ -1247,7 +1307,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 { @@ -1279,7 +1339,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}, @@ -1297,6 +1357,15 @@ struct xsub_details details[] = { {"version::vcmp", XS_version_vcmp, NULL}, {"version::(bool", XS_version_boolean, NULL}, {"version::boolean", XS_version_boolean, NULL}, + {"version::(+", XS_version_noop, NULL}, + {"version::(-", XS_version_noop, NULL}, + {"version::(*", XS_version_noop, NULL}, + {"version::(/", XS_version_noop, NULL}, + {"version::(+=", XS_version_noop, NULL}, + {"version::(-=", XS_version_noop, NULL}, + {"version::(*=", XS_version_noop, NULL}, + {"version::(/=", XS_version_noop, NULL}, + {"version::(abs", XS_version_noop, NULL}, {"version::(nomethod", XS_version_noop, NULL}, {"version::noop", XS_version_noop, NULL}, {"version::is_alpha", XS_version_is_alpha, NULL}, @@ -1315,9 +1384,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, ";$"}, @@ -1330,7 +1396,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]); @@ -1338,9 +1404,6 @@ Perl_boot_core_UNIVERSAL(pTHX) newXS_flags(xsub->name, xsub->xsub, file, xsub->proto, 0); } while (++xsub < end); - /* register the overloading (type 'A') magic */ - PL_amagic_generation++; - /* Providing a Regexp::DESTROY fixes #21347. See test in t/op/ref.t */ { CV * const cv = @@ -1355,8 +1418,8 @@ Perl_boot_core_UNIVERSAL(pTHX) * Local variables: * c-indentation-style: bsd * c-basic-offset: 4 - * indent-tabs-mode: t + * indent-tabs-mode: nil * End: * - * ex: set ts=8 sts=4 sw=4 noet: + * ex: set ts=8 sts=4 sw=4 et: */