X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/e52eb89d6b6e33611c38ec4ef278fd23c7109640..99f74b09f61407826aeb0bf8eabad6e2e628c02b:/op.c diff --git a/op.c b/op.c index b08ddcd..163b6a8 100644 --- a/op.c +++ b/op.c @@ -496,17 +496,6 @@ Perl_op_refcnt_dec(pTHX_ OP *o) o->op_ppaddr = PL_ppaddr[type]; \ } STMT_END -STATIC SV* -S_gv_ename(pTHX_ GV *gv) -{ - SV* const tmpsv = sv_newmortal(); - - PERL_ARGS_ASSERT_GV_ENAME; - - gv_efullname3(tmpsv, gv, NULL); - return tmpsv; -} - STATIC OP * S_no_fh_allowed(pTHX_ OP *o) { @@ -518,15 +507,6 @@ S_no_fh_allowed(pTHX_ OP *o) } STATIC OP * -S_too_few_arguments_sv(pTHX_ OP *o, SV *namesv, U32 flags) -{ - PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_SV; - yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %"SVf, SVfARG(namesv)), - SvUTF8(namesv) | flags); - return o; -} - -STATIC OP * S_too_few_arguments_pv(pTHX_ OP *o, const char* name, U32 flags) { PERL_ARGS_ASSERT_TOO_FEW_ARGUMENTS_PV; @@ -543,16 +523,6 @@ S_too_many_arguments_pv(pTHX_ OP *o, const char *name, U32 flags) return o; } -STATIC OP * -S_too_many_arguments_sv(pTHX_ OP *o, SV *namesv, U32 flags) -{ - PERL_ARGS_ASSERT_TOO_MANY_ARGUMENTS_SV; - - yyerror_pv(Perl_form(aTHX_ "Too many arguments for %"SVf, SVfARG(namesv)), - SvUTF8(namesv) | flags); - return o; -} - STATIC void S_bad_type_pv(pTHX_ I32 n, const char *t, const char *name, U32 flags, const OP *kid) { @@ -565,7 +535,7 @@ S_bad_type_pv(pTHX_ I32 n, const char *t, const char *name, U32 flags, const OP STATIC void S_bad_type_gv(pTHX_ I32 n, const char *t, GV *gv, U32 flags, const OP *kid) { - SV * const namesv = gv_ename(gv); + SV * const namesv = cv_name((CV *)gv, NULL); PERL_ARGS_ASSERT_BAD_TYPE_GV; yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %"SVf" must be %s (not %s)", @@ -837,8 +807,6 @@ Perl_op_clear(pTHX_ OP *o) SvREFCNT_inc_simple_void(gv); #ifdef USE_ITHREADS if (cPADOPo->op_padix > 0) { - /* No GvIN_PAD_off(cGVOPo_gv) here, because other references - * may still exist on the pad */ pad_swipe(cPADOPo->op_padix, TRUE); cPADOPo->op_padix = 0; } @@ -905,8 +873,6 @@ Perl_op_clear(pTHX_ OP *o) case OP_PUSHRE: #ifdef USE_ITHREADS if (cPMOPo->op_pmreplrootu.op_pmtargetoff) { - /* No GvIN_PAD_off here, because other references may still - * exist on the pad */ pad_swipe(cPMOPo->op_pmreplrootu.op_pmtargetoff, TRUE); } #else @@ -5216,7 +5182,7 @@ Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv) padop->op_type = (OPCODE)type; padop->op_ppaddr = PL_ppaddr[type]; padop->op_padix = - pad_alloc(type, IS_PADGV(sv) ? SVf_READONLY : SVs_PADTMP); + pad_alloc(type, isGV(sv) ? SVf_READONLY : SVs_PADTMP); SvREFCNT_dec(PAD_SVl(padop->op_padix)); PAD_SETSV(padop->op_padix, sv); assert(sv); @@ -5249,7 +5215,6 @@ Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv) PERL_ARGS_ASSERT_NEWGVOP; #ifdef USE_ITHREADS - GvIN_PAD_on(gv); return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv)); #else return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv)); @@ -7688,8 +7653,8 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, bool name_is_utf8 = o && !o_is_gv && SvUTF8(cSVOPo->op_sv); #ifdef PERL_DEBUG_READONLY_OPS OPSLAB *slab = NULL; -#endif bool special = FALSE; +#endif if (o_is_gv) { gv = (GV*)o; @@ -7919,11 +7884,14 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, assert(CvGV(cv) == gv); } else { + dVAR; U32 hash; PERL_HASH(hash, name, namlen); CvNAME_HEK_set(cv, share_hek(name, - name_is_utf8 ? -namlen : namlen, + name_is_utf8 + ? -(SSize_t)namlen + : (SSize_t)namlen, hash)); } @@ -7981,10 +7949,13 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, if (!CvHASGV(cv)) { if (isGV(gv)) CvGV_set(cv, gv); else { + dVAR; U32 hash; PERL_HASH(hash, name, namlen); CvNAME_HEK_set(cv, share_hek(name, - name_is_utf8 ? -namlen : namlen, + name_is_utf8 + ? -(SSize_t)namlen + : (SSize_t)namlen, hash)); } CvFILE_set_from_cop(cv, PL_curcop); @@ -8080,7 +8051,10 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, if (PL_parser && PL_parser->error_count) clear_special_blocks(name, gv, cv); else - special = process_special_blocks(floor, name, gv, cv); +#ifdef PERL_DEBUG_READONLY_OPS + special = +#endif + process_special_blocks(floor, name, gv, cv); } } @@ -9052,7 +9026,6 @@ Perl_ck_rvconst(pTHX_ OP *o) assert (sizeof(PADOP) <= sizeof(SVOP)); kPADOP->op_padix = pad_alloc(OP_GV, SVf_READONLY); SvREFCNT_dec(PAD_SVl(kPADOP->op_padix)); - if (isGV(gv)) GvIN_PAD_on(gv); PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv))); #else kid->op_sv = SvREFCNT_inc_simple_NN(gv); @@ -9997,6 +9970,33 @@ Perl_ck_sort(pTHX_ OP *o) kid->op_next = kid; o->op_flags |= OPf_SPECIAL; } + else if (kid->op_type == OP_CONST + && kid->op_private & OPpCONST_BARE) { + char tmpbuf[256]; + STRLEN len; + PADOFFSET off; + const char * const name = SvPV(kSVOP_sv, len); + *tmpbuf = '&'; + assert (len < 256); + Copy(name, tmpbuf+1, len, char); + off = pad_findmy_pvn(tmpbuf, len+1, SvUTF8(kSVOP_sv)); + if (off != NOT_IN_PAD) { + if (PAD_COMPNAME_FLAGS_isOUR(off)) { + SV * const fq = + newSVhek(HvNAME_HEK(PAD_COMPNAME_OURSTASH(off))); + sv_catpvs(fq, "::"); + sv_catsv(fq, kSVOP_sv); + SvREFCNT_dec_NN(kSVOP_sv); + kSVOP->op_sv = fq; + } + else { + OP * const padop = newOP(OP_PADCV, 0); + padop->op_targ = off; + cUNOPx(firstkid)->op_first = padop; + op_free(kid); + } + } + } firstkid = OP_SIBLING(firstkid); } @@ -10315,8 +10315,9 @@ Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags) } if (SvTYPE((SV*)cv) != SVt_PVCV) return NULL; - if (flags & RV2CVOPCV_RETURN_NAME_GV) { - if ((!CvANON(cv) || !gv) && !CvLEXICAL(cv)) + if (flags & (RV2CVOPCV_RETURN_NAME_GV|RV2CVOPCV_MAYBE_NAME_GV)) { + if ((!CvANON(cv) || !gv) && !CvLEXICAL(cv) + && ((flags & RV2CVOPCV_RETURN_NAME_GV) || !CvNAMED(cv))) gv = CvGV(cv); return (CV*)gv; } else { @@ -10412,7 +10413,12 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) OP* o3 = aop; if (proto >= proto_end) - return too_many_arguments_sv(entersubop, gv_ename(namegv), 0); + { + SV * const namesv = cv_name((CV *)namegv, NULL); + yyerror_pv(Perl_form(aTHX_ "Too many arguments for %"SVf, + SVfARG(namesv)), SvUTF8(namesv)); + return entersubop; + } switch (*proto) { case ';': @@ -10562,10 +10568,9 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) continue; default: oops: { - SV* const tmpsv = sv_newmortal(); - gv_efullname3(tmpsv, namegv, NULL); Perl_croak(aTHX_ "Malformed prototype for %"SVf": %"SVf, - SVfARG(tmpsv), SVfARG(protosv)); + SVfARG(cv_name((CV *)namegv, NULL)), + SVfARG(protosv)); } } @@ -10579,7 +10584,11 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) } if (!optional && proto_end > proto && (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_')) - return too_few_arguments_sv(entersubop, gv_ename(namegv), 0); + { + SV * const namesv = cv_name((CV *)namegv, NULL); + yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %"SVf, + SVfARG(namesv)), SvUTF8(namesv)); + } return entersubop; } @@ -10747,24 +10756,33 @@ by L. =cut */ -void -Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p) +static void +S_cv_get_call_checker(CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p, + U8 *flagsp) { MAGIC *callmg; - PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER; - PERL_UNUSED_CONTEXT; callmg = SvMAGICAL((SV*)cv) ? mg_find((SV*)cv, PERL_MAGIC_checkcall) : NULL; if (callmg) { *ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr); *ckobj_p = callmg->mg_obj; + if (flagsp) *flagsp = callmg->mg_flags; } else { *ckfun_p = Perl_ck_entersub_args_proto_or_list; *ckobj_p = (SV*)cv; + if (flagsp) *flagsp = 0; } } +void +Perl_cv_get_call_checker(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p) +{ + PERL_ARGS_ASSERT_CV_GET_CALL_CHECKER; + PERL_UNUSED_CONTEXT; + S_cv_get_call_checker(cv, ckfun_p, ckobj_p, NULL); +} + /* -=for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj +=for apidoc Am|void|cv_set_call_checker_flags|CV *cv|Perl_call_checker ckfun|SV *ckobj|U32 flags Sets the function that will be used to fix up a call to I. Specifically, the function is applied to an C op tree for a @@ -10781,15 +10799,25 @@ It is intended to be called in this manner: entersubop = ckfun(aTHX_ entersubop, namegv, ckobj); In this call, I is a pointer to the C op, -which may be replaced by the check function, and I is a GV -supplying the name that should be used by the check function to refer +which may be replaced by the check function, and I supplies +the name that should be used by the check function to refer to the callee of the C op if it needs to emit any diagnostics. It is permitted to apply the check function in non-standard situations, such as to a call to a different subroutine or to a method call. +I may not actually be a GV. For efficiency, perl may pass a +CV or other SV instead. Whatever is passed can be used as the first +argument to L. You can force perl to pass a GV by including +C in the I. + The current setting for a particular CV can be retrieved by L. +=for apidoc Am|void|cv_set_call_checker|CV *cv|Perl_call_checker ckfun|SV *ckobj + +The original form of L, which passes it the +C flag for backward-compatibility. + =cut */ @@ -10797,6 +10825,14 @@ void Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj) { PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER; + cv_set_call_checker_flags(cv, ckfun, ckobj, CALL_CHECKER_REQUIRE_GV); +} + +void +Perl_cv_set_call_checker_flags(pTHX_ CV *cv, Perl_call_checker ckfun, + SV *ckobj, U32 flags) +{ + PERL_ARGS_ASSERT_CV_SET_CALL_CHECKER_FLAGS; if (ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) { if (SvMAGICAL((SV*)cv)) mg_free_type((SV*)cv, PERL_MAGIC_checkcall); @@ -10815,7 +10851,8 @@ Perl_cv_set_call_checker(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj) SvREFCNT_inc_simple_void_NN(ckobj); callmg->mg_flags |= MGf_REFCOUNTED; } - callmg->mg_flags |= MGf_COPY; + callmg->mg_flags = (callmg->mg_flags &~ MGf_REQUIRE_GV) + | (U8)(flags & MGf_REQUIRE_GV) | MGf_COPY; } } @@ -10834,7 +10871,7 @@ Perl_ck_subr(pTHX_ OP *o) aop = OP_SIBLING(aop); for (cvop = aop; OP_HAS_SIBLING(cvop); cvop = OP_SIBLING(cvop)) ; cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY); - namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_RETURN_NAME_GV) : NULL; + namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_MAYBE_NAME_GV) : NULL; o->op_private &= ~1; o->op_private |= OPpENTERSUB_HASTARG; @@ -10859,21 +10896,24 @@ Perl_ck_subr(pTHX_ OP *o) } else { Perl_call_checker ckfun; SV *ckobj; - cv_get_call_checker(cv, &ckfun, &ckobj); - if (!namegv) { /* expletive! */ - /* XXX The call checker API is public. And it guarantees that - a GV will be provided with the right name. So we have - to create a GV. But it is still not correct, as its - stringification will include the package. What we - really need is a new call checker API that accepts a - GV or string (or GV or CV). */ - HEK * const hek = CvNAME_HEK(cv); + U8 flags; + S_cv_get_call_checker(cv, &ckfun, &ckobj, &flags); + if (!namegv) { + /* The original call checker API guarantees that a GV will be + be provided with the right name. So, if the old API was + used (or the REQUIRE_GV flag was passed), we have to reify + the CV’s GV, unless this is an anonymous sub. This is not + ideal for lexical subs, as its stringification will include + the package. But it is the best we can do. */ + if (flags & MGf_REQUIRE_GV) { + if (!CvANON(cv) && (!CvNAMED(cv) || CvNAME_HEK(cv))) + namegv = CvGV(cv); + } + else namegv = MUTABLE_GV(cv); /* After a syntax error in a lexical sub, the cv that rv2cv_op_cv returns may be a nameless stub. */ - if (!hek) return ck_entersub_args_list(o);; - namegv = (GV *)sv_newmortal(); - gv_init_pvn(namegv, PL_curstash, HEK_KEY(hek), HEK_LEN(hek), - SVf_UTF8 * !!HEK_UTF8(hek)); + if (!namegv) return ck_entersub_args_list(o); + } return ckfun(aTHX_ o, namegv, ckobj); }