X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/b2a8d771f2f5721aa711c6ecdb42fdc198bfd244..273e254d1663b9223905e4b5c3b6546671ba365e:/universal.c diff --git a/universal.c b/universal.c index a72c072..864558f 100644 --- a/universal.c +++ b/universal.c @@ -29,7 +29,7 @@ #define PERL_IN_UNIVERSAL_C #include "perl.h" -#ifdef USE_PERLIO +#if defined(USE_PERLIO) #include "perliol.h" /* For the PERLIO_F_XXX */ #endif @@ -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; @@ -160,15 +158,19 @@ Perl_sv_derived_from_pvn(pTHX_ SV *sv, const char *const name, const STRLEN len, type = sv_reftype(sv,0); if (type && strEQ(type,name)) return TRUE; - stash = SvOBJECT(sv) ? SvSTASH(sv) : NULL; + if (!SvOBJECT(sv)) + return FALSE; + stash = SvSTASH(sv); } else { stash = gv_stashsv(sv, 0); - if (!stash) - stash = gv_stashpvs("UNIVERSAL", 0); } - return stash ? isa_lookup(stash, name, len, flags) : FALSE; + if (stash && isa_lookup(stash, name, len, flags)) + return TRUE; + + stash = gv_stashpvs("UNIVERSAL", 0); + return stash && isa_lookup(stash, name, len, flags); } /* @@ -290,7 +292,7 @@ A specialised variant of C for emitting the usage message for xsubs croak_xs_usage(cv, "eee_yow"); 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: +C. Hence if C is C<&ouch::awk>, it would call C as: Perl_croak(aTHX_ "Usage: %"SVf"::%"SVf"(%s)", "ouch" "awk", "eee_yow"); @@ -300,30 +302,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)", HEKfARG(HvNAME_HEK(stash)), HEKfARG(GvNAME_HEK(gv)), params); else + /* diag_listed_as: SKIPME */ 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. */ - Perl_croak_nocontext("Usage: CODE(0x%"UVxf")(%s)", PTR2UV(cv), params); + /* diag_listed_as: SKIPME */ + 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) @@ -341,13 +350,14 @@ XS(XS_UNIVERSAL_isa) } } +XS(XS_UNIVERSAL_can); /* prototype to pass -Wmissing-prototypes */ XS(XS_UNIVERSAL_can) { - dVAR; dXSARGS; SV *sv; SV *rv; HV *pkg = NULL; + GV *iogv; if (items != 2) croak_xs_usage(cv, "object-ref, method"); @@ -356,8 +366,10 @@ XS(XS_UNIVERSAL_can) SvGETMAGIC(sv); - if (!SvOK(sv) || !(SvROK(sv) || SvNIOK(sv) || (SvPOK(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; rv = &PL_sv_undef; @@ -366,11 +378,17 @@ XS(XS_UNIVERSAL_can) 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); + pkg = gv_stashpvs("UNIVERSAL", 0); } if (pkg) { @@ -383,9 +401,9 @@ XS(XS_UNIVERSAL_can) XSRETURN(1); } +XS(XS_UNIVERSAL_DOES); /* prototype to pass -Wmissing-prototypes */ XS(XS_UNIVERSAL_DOES) { - dVAR; dXSARGS; PERL_UNUSED_ARG(cv); @@ -400,375 +418,9 @@ XS(XS_UNIVERSAL_DOES) } } -XS(XS_UNIVERSAL_VERSION) -{ - dVAR; - dXSARGS; - HV *pkg; - GV **gvp; - GV *gv; - SV *sv; - const char *undef; - PERL_UNUSED_ARG(cv); - - if (SvROK(ST(0))) { - sv = MUTABLE_SV(SvRV(ST(0))); - if (!SvOBJECT(sv)) - Perl_croak(aTHX_ "Cannot find version of an unblessed reference"); - pkg = SvSTASH(sv); - } - else { - pkg = gv_stashsv(ST(0), 0); - } - - gvp = pkg ? (GV**)hv_fetchs(pkg, "VERSION", FALSE) : NULL; - - if (gvp && isGV(gv = *gvp) && (sv = GvSV(gv)) && SvOK(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 = &PL_sv_undef; - undef = "(undef)"; - } - - if (items > 1) { - SV *req = ST(1); - - if (undef) { - if (pkg) { - const HEK * const name = HvNAME_HEK(pkg); - Perl_croak(aTHX_ - "%"HEKf" does not define $%"HEKf - "::VERSION--version check failed", - HEKfARG(name), HEKfARG(name)); - } else { - Perl_croak(aTHX_ - "%"SVf" defines neither package nor VERSION--version check failed", - SVfARG(ST(0)) ); - } - } - - 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_ "%"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_ "%"HEKf" version %"SVf" required--" - "this is only version %"SVf, - HEKfARG(HvNAME_HEK(pkg)), - SVfARG(sv_2mortal(vstringify(req))), - SVfARG(sv_2mortal(vstringify(sv)))); - } - } - - } - - if ( SvOK(sv) && sv_derived_from(sv, "version") ) { - ST(0) = sv_2mortal(vstringify(sv)); - } else { - ST(0) = sv; - } - - XSRETURN(1); -} - -XS(XS_version_new) -{ - dVAR; - dXSARGS; - if (items > 3 || items < 1) - croak_xs_usage(cv, "class, version"); - SP -= items; - { - SV *vs = ST(1); - SV *rv; - 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 */ - vs = sv_newmortal(); - sv_setpvs(vs, "0"); - } - else if ( items == 3 ) { - vs = sv_newmortal(); - Perl_sv_setpvf(aTHX_ vs,"v%s",SvPV_nolen_const(ST(2))); - } - - rv = new_version(vs); - if ( strnNE(classname,"version", len) ) /* inherited new() */ - sv_bless(rv, gv_stashpvn(classname, len, GV_ADD | flags)); - - mPUSHs(rv); - PUTBACK; - return; - } -} - -XS(XS_version_stringify) -{ - dVAR; - dXSARGS; - if (items < 1) - croak_xs_usage(cv, "lobj, ..."); - SP -= items; - { - SV * lobj = ST(0); - - if (sv_isobject(lobj) && sv_derived_from(lobj, "version")) { - lobj = SvRV(lobj); - } - else - Perl_croak(aTHX_ "lobj is not of type version"); - - mPUSHs(vstringify(lobj)); - - PUTBACK; - return; - } -} - -XS(XS_version_numify) -{ - dVAR; - dXSARGS; - if (items < 1) - croak_xs_usage(cv, "lobj, ..."); - SP -= items; - { - SV * lobj = ST(0); - - if (sv_isobject(lobj) && sv_derived_from(lobj, "version")) { - lobj = SvRV(lobj); - } - else - Perl_croak(aTHX_ "lobj is not of type version"); - - mPUSHs(vnumify(lobj)); - - PUTBACK; - return; - } -} - -XS(XS_version_normal) -{ - dVAR; - dXSARGS; - if (items < 1) - croak_xs_usage(cv, "lobj, ..."); - SP -= items; - { - SV * lobj = ST(0); - - if (sv_isobject(lobj) && sv_derived_from(lobj, "version")) { - lobj = SvRV(lobj); - } - else - Perl_croak(aTHX_ "lobj is not of type version"); - - mPUSHs(vnormal(lobj)); - - PUTBACK; - return; - } -} - -XS(XS_version_vcmp) -{ - dVAR; - dXSARGS; - if (items < 1) - croak_xs_usage(cv, "lobj, ..."); - SP -= items; - { - SV * lobj = ST(0); - - if (sv_isobject(lobj) && sv_derived_from(lobj, "version")) { - lobj = SvRV(lobj); - } - else - Perl_croak(aTHX_ "lobj is not of type version"); - - { - SV *rs; - SV *rvs; - SV * robj = ST(1); - const IV swap = (IV)SvIV(ST(2)); - - if ( !sv_isobject(robj) || !sv_derived_from(robj, "version") ) - { - robj = new_version(SvOK(robj) ? robj : newSVpvs_flags("0", SVs_TEMP)); - sv_2mortal(robj); - } - rvs = SvRV(robj); - - if ( swap ) - { - rs = newSViv(vcmp(rvs,lobj)); - } - else - { - rs = newSViv(vcmp(lobj,rvs)); - } - - mPUSHs(rs); - } - - PUTBACK; - return; - } -} - -XS(XS_version_boolean) -{ - dVAR; - dXSARGS; - if (items < 1) - croak_xs_usage(cv, "lobj, ..."); - SP -= items; - if (sv_isobject(ST(0)) && sv_derived_from(ST(0), "version")) { - SV * const lobj = SvRV(ST(0)); - SV * const rs = - newSViv( vcmp(lobj, - sv_2mortal(new_version( - sv_2mortal(newSVpvs("0")) - )) - ) - ); - mPUSHs(rs); - PUTBACK; - return; - } - else - Perl_croak(aTHX_ "lobj is not of type version"); -} - -XS(XS_version_noop) -{ - dVAR; - dXSARGS; - if (items < 1) - croak_xs_usage(cv, "lobj, ..."); - 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"); -#ifndef HASATTRIBUTE_NORETURN - XSRETURN_EMPTY; -#endif -} - -XS(XS_version_is_alpha) -{ - dVAR; - dXSARGS; - if (items != 1) - croak_xs_usage(cv, "lobj"); - SP -= items; - 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; - else - XSRETURN_NO; - PUTBACK; - return; - } - else - Perl_croak(aTHX_ "lobj is not of type version"); -} - -XS(XS_version_qv) -{ - dVAR; - dXSARGS; - PERL_UNUSED_ARG(cv); - SP -= items; - { - SV * ver = ST(0); - SV * rv; - 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 */ - upg_version(rv, TRUE); - } else { - rv = sv_2mortal(new_version(ver)); - } - if ( items == 2 - && strnNE(classname,"version", len) ) { /* inherited new() */ - sv_bless(rv, gv_stashpvn(classname, len, GV_ADD | flags)); - } - PUSHs(rv); - } - PUTBACK; - return; -} - -XS(XS_version_is_qv) -{ - dVAR; - dXSARGS; - if (items != 1) - croak_xs_usage(cv, "lobj"); - SP -= items; - 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; - else - XSRETURN_NO; - PUTBACK; - return; - } - else - Perl_croak(aTHX_ "lobj is not of type version"); -} - +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"); @@ -783,9 +435,9 @@ XS(XS_utf8_is_utf8) XSRETURN_EMPTY; } +XS(XS_utf8_valid); /* prototype to pass -Wmissing-prototypes */ XS(XS_utf8_valid) { - dVAR; dXSARGS; if (items != 1) croak_xs_usage(cv, "sv"); @@ -801,9 +453,9 @@ XS(XS_utf8_valid) XSRETURN_EMPTY; } +XS(XS_utf8_encode); /* prototype to pass -Wmissing-prototypes */ XS(XS_utf8_encode) { - dVAR; dXSARGS; if (items != 1) croak_xs_usage(cv, "sv"); @@ -812,9 +464,9 @@ XS(XS_utf8_encode) XSRETURN_EMPTY; } +XS(XS_utf8_decode); /* prototype to pass -Wmissing-prototypes */ XS(XS_utf8_decode) { - dVAR; dXSARGS; if (items != 1) croak_xs_usage(cv, "sv"); @@ -829,9 +481,9 @@ XS(XS_utf8_decode) XSRETURN(1); } +XS(XS_utf8_upgrade); /* prototype to pass -Wmissing-prototypes */ XS(XS_utf8_upgrade) { - dVAR; dXSARGS; if (items != 1) croak_xs_usage(cv, "sv"); @@ -846,15 +498,15 @@ XS(XS_utf8_upgrade) XSRETURN(1); } +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 failok = (items < 2) ? 0 : SvTRUE(ST(1)) ? 1 : 0; const bool RETVAL = sv_utf8_downgrade(sv, failok); ST(0) = boolSV(RETVAL); @@ -862,9 +514,9 @@ XS(XS_utf8_downgrade) XSRETURN(1); } +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)); @@ -875,9 +527,9 @@ XS(XS_utf8_native_to_unicode) 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)); @@ -888,9 +540,9 @@ XS(XS_utf8_unicode_to_native) 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; @@ -903,28 +555,61 @@ 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); - SvREADONLY_on(sv); +#endif + SvFLAGS(sv) |= SVf_READONLY; XSRETURN_YES; } else { /* I hope you really know what you are doing. */ - if (!SvIsCOW(sv)) SvREADONLY_off(sv); + SvFLAGS(sv) &=~ SVf_READONLY; XSRETURN_NO; } } XSRETURN_UNDEF; /* Can't happen. */ } + +XS(XS_constant__make_const); /* prototype to pass -Wmissing-prototypes */ +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) + croak_xs_usage(cv, "SCALAR"); + + 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 + on arrays anyway. */ + SV **svp; + for (svp = AvARRAY(sv) + AvFILLp(sv) + ; svp >= AvARRAY(sv) + ; --svp) + if (*svp) SvPADTMP_on(*svp); + } + XSRETURN(0); +} + +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; @@ -947,9 +632,9 @@ 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))) @@ -961,13 +646,13 @@ 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]"); -#ifdef USE_PERLIO +#if defined(USE_PERLIO) { SV * sv; GV * gv; @@ -1022,9 +707,9 @@ XS(XS_PerlIO_get_layers) if (gv && (io = GvIO(gv))) { AV* const av = PerlIO_get_layers(aTHX_ input ? IoIFP(io) : IoOFP(io)); - I32 i; - const I32 last = av_len(av); - I32 nitem = 0; + SSize_t i; + const SSize_t last = av_tindex(av); + SSize_t nitem = 0; for (i = last; i >= 0; i -= 3) { SV * const * const namsvp = av_fetch(av, i - 2, FALSE); @@ -1087,9 +772,9 @@ XS(XS_PerlIO_get_layers) } +XS(XS_re_is_regexp); /* prototype to pass -Wmissing-prototypes */ XS(XS_re_is_regexp) { - dVAR; dXSARGS; PERL_UNUSED_VAR(cv); @@ -1103,11 +788,11 @@ XS(XS_re_is_regexp) } } +XS(XS_re_regnames_count); /* prototype to pass -Wmissing-prototypes */ XS(XS_re_regnames_count) { REGEXP *rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL; SV * ret; - dVAR; dXSARGS; if (items != 0) @@ -1126,9 +811,9 @@ XS(XS_re_regnames_count) XSRETURN(1); } +XS(XS_re_regname); /* prototype to pass -Wmissing-prototypes */ XS(XS_re_regname) { - dVAR; dXSARGS; REGEXP * rx; U32 flags; @@ -1158,16 +843,16 @@ XS(XS_re_regname) } +XS(XS_re_regnames); /* prototype to pass -Wmissing-prototypes */ XS(XS_re_regnames) { - dVAR; dXSARGS; REGEXP * rx; U32 flags; SV *ret; AV *av; - I32 length; - I32 i; + SSize_t length; + SSize_t i; SV **entry; if (items > 1) @@ -1195,7 +880,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++) { @@ -1213,11 +898,12 @@ XS(XS_re_regnames) return; } +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; @@ -1240,7 +926,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; @@ -1280,7 +966,7 @@ XS(XS_re_regexp_pattern) XSRETURN(2); } else { /* Scalar, so use the string that Perl would return */ - /* return the pattern in (?msix:..) format */ + /* return the pattern in (?msixn:..) format */ #if PERL_VERSION >= 11 pattern = sv_2mortal(newSVsv(MUTABLE_SV(re))); #else @@ -1292,9 +978,9 @@ XS(XS_re_regexp_pattern) } } 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 @@ -1310,48 +996,25 @@ XS(XS_re_regexp_pattern) XSRETURN_NO; } } - /* NOT-REACHED */ + NOT_REACHED; /* NOTREACHED */ } +#include "vutil.h" +#include "vxs.inc" + struct xsub_details { const char *name; XSUBADDR_t xsub; const char *proto; }; -const struct xsub_details details[] = { +static const struct xsub_details details[] = { {"UNIVERSAL::isa", XS_UNIVERSAL_isa, NULL}, {"UNIVERSAL::can", XS_UNIVERSAL_can, NULL}, {"UNIVERSAL::DOES", XS_UNIVERSAL_DOES, NULL}, - {"UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, NULL}, - {"version::()", XS_version_noop, NULL}, - {"version::new", XS_version_new, NULL}, - {"version::parse", XS_version_new, NULL}, - {"version::(\"\"", XS_version_stringify, NULL}, - {"version::stringify", XS_version_stringify, NULL}, - {"version::(0+", XS_version_numify, NULL}, - {"version::numify", XS_version_numify, NULL}, - {"version::normal", XS_version_normal, NULL}, - {"version::(cmp", XS_version_vcmp, NULL}, - {"version::(<=>", XS_version_vcmp, NULL}, - {"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}, - {"version::qv", XS_version_qv, NULL}, - {"version::declare", XS_version_qv, NULL}, - {"version::is_qv", XS_version_is_qv, NULL}, +#define VXS_XSUB_DETAILS +#include "vxs.inc" +#undef VXS_XSUB_DETAILS {"utf8::is_utf8", XS_utf8_is_utf8, NULL}, {"utf8::valid", XS_utf8_valid, NULL}, {"utf8::encode", XS_utf8_encode, NULL}, @@ -1361,6 +1024,7 @@ 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, "\\%"}, {"PerlIO::get_layers", XS_PerlIO_get_layers, "*;@"}, @@ -1371,26 +1035,89 @@ const struct xsub_details details[] = { {"re::regexp_pattern", XS_re_regexp_pattern, "$"}, }; +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; + SV* prototype = newSVpvs("$"); + + PERL_UNUSED_ARG(protosv); + + assert(entersubop->op_type == OP_ENTERSUB); + + entersubop = ck_entersub_args_proto(entersubop, namegv, prototype); + + SvREFCNT_dec(prototype); + + pushop = cUNOPx(entersubop)->op_first; + if (! pushop->op_sibling) { + pushop = cUNOPx(pushop)->op_first; + } + argop = pushop->op_sibling; + + /* Carry on without doing the optimization if it is not something we're + * expecting, so continues to work */ + if ( ! argop + || ! argop->op_sibling + || argop->op_sibling->op_sibling + ) { + return entersubop; + } + + pushop->op_sibling = argop->op_sibling; + argop->op_sibling = NULL; + argop->op_lastsib = 1; + + 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 *end = C_ARRAY_END(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(to_native_cv, + optimize_out_native_convert_function, + (SV*) to_native_cv); + cv_set_call_checker(to_unicode_cv, + optimize_out_native_convert_function, + (SV*) to_unicode_cv); + } +#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); } }