X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/a65cc145b2ce31d135006c2fb8e7b89e0843f3b4..a63813b376f25b984970473e47c98e473b1f70eb:/op.c?ds=sidebyside diff --git a/op.c b/op.c index 57f78f1..08e6028 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) { @@ -546,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 = cv_name((CV *)gv, NULL); + SV * const namesv = cv_name((CV *)gv, NULL, 0); PERL_ARGS_ASSERT_BAD_TYPE_GV; yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %"SVf" must be %s (not %s)", @@ -818,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; } @@ -886,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 @@ -1049,25 +1034,25 @@ Perl_op_refcnt_unlock(pTHX) =for apidoc op_sibling_splice A general function for editing the structure of an existing chain of -op_sibling nodes. By analogy with the perl-level splice() function, allows +op_sibling nodes. By analogy with the perl-level splice() function, allows you to delete zero or more sequential nodes, replacing them with zero or more different nodes. Performs the necessary op_first/op_last housekeeping on the parent node and op_sibling manipulation on the -children. The last deleted node will be marked as as the last node by +children. The last deleted node will be marked as as the last node by updating the op_sibling or op_lastsib field as appropriate. Note that op_next is not manipulated, and nodes are not freed; that is the -responsibility of the caller. It also won't create a new list op for an +responsibility of the caller. It also won't create a new list op for an empty list etc; use higher-level functions like op_append_elem() for that. parent is the parent node of the sibling chain. -start is the node preceding the first node to be spliced. Node(s) -following it will be deleted, and ops will be inserted after it. If it is +start is the node preceding the first node to be spliced. Node(s) +following it will be deleted, and ops will be inserted after it. If it is NULL, the first node onwards is deleted, and nodes are inserted at the beginning. -del_count is the number of nodes to delete. If zero, no nodes are deleted. +del_count is the number of nodes to delete. If zero, no nodes are deleted. If -1 or greater than or equal to the number of remaining kids, all remaining kids are deleted. @@ -1171,7 +1156,7 @@ Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert) /* =for apidoc op_parent -returns the parent OP of o, if it has a parent. Returns NULL otherwise. +returns the parent OP of o, if it has a parent. Returns NULL otherwise. (Currently perl must be built with C<-DPERL_OP_PARENT> for this feature to work. @@ -1745,6 +1730,7 @@ Perl_scalarvoid(pTHX_ OP *o) no_bareword_allowed(o); else { if (ckWARN(WARN_VOID)) { + NV nv; /* don't warn on optimised away booleans, eg * use constant Foo, 5; Foo || print; */ if (cSVOPo->op_private & OPpCONST_SHORTCIRCUIT) @@ -1752,7 +1738,7 @@ Perl_scalarvoid(pTHX_ OP *o) /* the constants 0 and 1 are permitted as they are conventionally used as dummies in constructs like 1 while some_condition_with_side_effects; */ - else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0)) + else if (SvNIOK(sv) && ((nv = SvNV(sv)) == 0.0 || nv == 1.0)) useless = NULL; else if (SvPOK(sv)) { SV * const dsv = newSVpvs(""); @@ -5197,7 +5183,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); @@ -5230,7 +5216,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)); @@ -6378,10 +6363,11 @@ Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right) left->op_next = flip; right->op_next = flop; - range->op_targ = pad_alloc(OP_RANGE, SVs_PADMY); + range->op_targ = pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK, 0, 0); sv_upgrade(PAD_SV(range->op_targ), SVt_PVNV); - flip->op_targ = pad_alloc(OP_RANGE, SVs_PADMY); + flip->op_targ = pad_add_name_pvn("$", 1, padadd_NO_DUP_CHECK, 0, 0);; sv_upgrade(PAD_SV(flip->op_targ), SVt_PVNV); + SvPADTMP_on(PAD_SV(flip->op_targ)); flip->op_private = left->op_type == OP_CONST ? OPpFLIP_LINENUM : 0; flop->op_private = right->op_type == OP_CONST ? OPpFLIP_LINENUM : 0; @@ -7428,7 +7414,7 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) } if (const_sv) { SvREFCNT_inc_simple_void_NN(const_sv); - SvFLAGS(const_sv) = (SvFLAGS(const_sv) & ~SVs_PADMY) | SVs_PADTMP; + SvFLAGS(const_sv) |= SVs_PADTMP; if (cv) { assert(!CvROOT(cv) && !CvCONST(cv)); cv_forget_slab(cv); @@ -7620,7 +7606,6 @@ Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) else *spot = cv_clone(clonee); SvREFCNT_dec_NN(clonee); cv = *spot; - SvPADMY_on(cv); } if (CvDEPTH(outcv) && !reusable && PadnameIsSTATE(name)) { PADOFFSET depth = CvDEPTH(outcv); @@ -7669,8 +7654,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; @@ -7850,7 +7835,7 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, } if (const_sv) { SvREFCNT_inc_simple_void_NN(const_sv); - SvFLAGS(const_sv) = (SvFLAGS(const_sv) & ~SVs_PADMY) | SVs_PADTMP; + SvFLAGS(const_sv) |= SVs_PADTMP; if (cv) { assert(!CvROOT(cv) && !CvCONST(cv)); cv_forget_slab(cv); @@ -7900,11 +7885,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)); } @@ -7962,10 +7950,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); @@ -8034,7 +8025,7 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, if (block && has_name) { if (PERLDB_SUBLINE && PL_curstash != PL_debstash) { - SV * const tmpstr = cv_name(cv,NULL); + SV * const tmpstr = cv_name(cv,NULL,0); GV * const db_postponed = gv_fetchpvs("DB::postponed", GV_ADDMULTI, SVt_PVHV); HV *hv; @@ -8061,7 +8052,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); } } @@ -9033,7 +9027,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); @@ -9527,7 +9520,7 @@ Perl_ck_readline(pTHX_ OP *o) } else { OP * const newop - = newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, PL_argvgv)); + = newUNOP(OP_READLINE, o->op_flags | OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv)); op_free(o); return newop; } @@ -9978,6 +9971,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); } @@ -10395,7 +10415,7 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) if (proto >= proto_end) { - SV * const namesv = cv_name((CV *)namegv, NULL); + SV * const namesv = cv_name((CV *)namegv, NULL, 0); yyerror_pv(Perl_form(aTHX_ "Too many arguments for %"SVf, SVfARG(namesv)), SvUTF8(namesv)); return entersubop; @@ -10550,7 +10570,7 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) default: oops: { Perl_croak(aTHX_ "Malformed prototype for %"SVf": %"SVf, - SVfARG(cv_name((CV *)namegv, NULL)), + SVfARG(cv_name((CV *)namegv, NULL, 0)), SVfARG(protosv)); } } @@ -10566,7 +10586,7 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) if (!optional && proto_end > proto && (*proto != '@' && *proto != '%' && *proto != ';' && *proto != '_')) { - SV * const namesv = cv_name((CV *)namegv, NULL); + SV * const namesv = cv_name((CV *)namegv, NULL, 0); yyerror_pv(Perl_form(aTHX_ "Not enough arguments for %"SVf, SVfARG(namesv)), SvUTF8(namesv)); } @@ -10759,7 +10779,7 @@ 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; - return S_cv_get_call_checker(cv, ckfun_p, ckobj_p, NULL); + S_cv_get_call_checker(cv, ckfun_p, ckobj_p, NULL); } /* @@ -10833,7 +10853,7 @@ Perl_cv_set_call_checker_flags(pTHX_ CV *cv, Perl_call_checker ckfun, callmg->mg_flags |= MGf_REFCOUNTED; } callmg->mg_flags = (callmg->mg_flags &~ MGf_REQUIRE_GV) - | (flags & MGf_REQUIRE_GV) | MGf_COPY; + | (U8)(flags & MGf_REQUIRE_GV) | MGf_COPY; } }