PERL_ARGS_ASSERT_SLAB_FREE;
if (!o->op_slabbed) {
- PerlMemShared_free(op);
+ if (!o->op_static)
+ PerlMemShared_free(op);
return;
}
)
) {
assert(slot->opslot_op.op_slabbed);
- slab->opslab_refcnt++; /* op_free may free slab */
op_free(&slot->opslot_op);
- if (!--slab->opslab_refcnt) goto free;
+ if (slab->opslab_refcnt == 1) goto free;
}
}
} while ((slab2 = slab2->opslab_next));
#ifdef DEBUGGING
assert(savestack_count == slab->opslab_refcnt-1);
#endif
+ /* Remove the CV’s reference count. */
+ slab->opslab_refcnt--;
return;
}
free:
PL_parser->in_my == KEY_state ? "state" : "my"), flags & SVf_UTF8);
}
}
+ else if (len == 2 && name[1] == '_' && !is_our)
+ /* diag_listed_as: Use of my $_ is deprecated */
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
+ "Use of %s $_ is deprecated",
+ PL_parser->in_my == KEY_state
+ ? "state"
+ : "my");
/* allocate a spare slot and store the name in that slot */
FreeOp(o);
}
-#ifdef USE_ITHREADS
-# define forget_pmop(a,b) S_forget_pmop(aTHX_ a,b)
-#else
-# define forget_pmop(a,b) S_forget_pmop(aTHX_ a)
-#endif
-
/* Destructor */
void
#endif
if (still_valid) {
int try_downgrade = SvREFCNT(gv) == 2;
- SvREFCNT_dec(gv);
+ SvREFCNT_dec_NN(gv);
if (try_downgrade)
gv_try_downgrade(gv);
}
if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
op_free(cPMOPo->op_code_list);
cPMOPo->op_code_list = NULL;
- forget_pmop(cPMOPo, 1);
+ forget_pmop(cPMOPo);
cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
/* we use the same protection as the "SAFE" version of the PM_ macros
* here since sv_clean_all might release some PMOPs
STATIC void
S_forget_pmop(pTHX_ PMOP *const o
-#ifdef USE_ITHREADS
- , U32 flags
-#endif
)
{
HV * const pmstash = PmopSTASH(o);
}
if (PL_curpm == o)
PL_curpm = NULL;
-#ifdef USE_ITHREADS
- if (flags)
- PmopSTASH_free(o);
-#endif
}
STATIC void
case OP_PUSHRE:
case OP_MATCH:
case OP_QR:
- forget_pmop((PMOP*)kid, 0);
+ forget_pmop((PMOP*)kid);
}
find_and_forget_pmops(kid);
kid = kid->op_sibling;
PERL_PV_PRETTY_DUMP
| PERL_PV_ESCAPE_NOCLEAR
| PERL_PV_ESCAPE_UNI_DETECT));
- SvREFCNT_dec(dsv);
+ SvREFCNT_dec_NN(dsv);
}
}
else if (SvOK(sv)) {
/* If op_sv is already a PADTMP/MY then it is being used by
* some pad, so make a copy. */
sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
- SvREADONLY_on(PAD_SVl(ix));
+ if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
SvREFCNT_dec(cSVOPo->op_sv);
}
else if (o->op_type != OP_METHOD_NAMED
SvPADTMP_on(cSVOPo->op_sv);
PAD_SETSV(ix, cSVOPo->op_sv);
/* XXX I don't know how this isn't readonly already. */
- SvREADONLY_on(PAD_SVl(ix));
+ if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
}
cSVOPo->op_sv = NULL;
o->op_targ = ix;
/* Make the CONST have a shared SV */
svp = cSVOPx_svp(((BINOP*)o)->op_last);
- if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv))
+ if ((!SvIsCOW(sv = *svp))
&& SvTYPE(sv) < SVt_PVMG && !SvROK(sv)) {
key = SvPV_const(sv, keylen);
lexname = newSVpvn_share(key,
SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
0);
- SvREFCNT_dec(sv);
+ SvREFCNT_dec_NN(sv);
*svp = lexname;
}
}
break;
}
+
case OP_SUBST: {
if (cPMOPo->op_pmreplrootu.op_pmreplroot)
finalize_op(cPMOPo->op_pmreplrootu.op_pmreplroot);
{
dVAR;
if (o) {
- if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) {
+ if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) {
o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
o->op_type = OP_LEAVE;
o->op_ppaddr = PL_ppaddr[OP_LEAVE];
}
static OP *
-S_fold_constants(pTHX_ register OP *o)
+S_fold_constants(pTHX_ OP *o)
{
dVAR;
OP * VOL curop;
}
static OP *
-S_gen_constant_list(pTHX_ register OP *o)
+S_gen_constant_list(pTHX_ OP *o)
{
dVAR;
OP *curop;
case MAD_NULL:
break;
case MAD_PV:
- Safefree((char*)mp->mad_val);
+ Safefree(mp->mad_val);
break;
case MAD_OP:
if (mp->mad_vlen) /* vlen holds "strong/weak" boolean */
/* handle the implicit sub{} wrapped round the qr/(?{..})/ */
SvREFCNT_inc_simple_void(PL_compcv);
cv = newATTRSUB(floor, 0, NULL, NULL, qr);
- ((struct regexp *)SvANY(re))->qr_anoncv = cv;
+ ReANY(re)->qr_anoncv = cv;
/* attach the anon CV to the pad so that
* pad_fixup_inner_anons() can find it */
* preceding stacking ops;
* OP_REGCRESET is there to reset taint before executing the
* stacking ops */
- if (pm->op_pmflags & PMf_KEEP || PL_tainting)
- expr = newUNOP((PL_tainting ? OP_REGCRESET : OP_REGCMAYBE),0,expr);
+ if (pm->op_pmflags & PMf_KEEP || TAINTING_get)
+ expr = newUNOP((TAINTING_get ? OP_REGCRESET : OP_REGCMAYBE),0,expr);
if (pm->op_pmflags & PMf_HAS_CV) {
/* we have a runtime qr with literal code. This means
}
if (repl) {
- OP *curop;
+ OP *curop = repl;
+ bool konst;
if (pm->op_pmflags & PMf_EVAL) {
- curop = NULL;
if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
}
- else if (repl->op_type == OP_CONST)
- curop = repl;
- else {
- OP *lastop = NULL;
- for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
- if (curop->op_type == OP_SCOPE
- || curop->op_type == OP_LEAVE
- || (PL_opargs[curop->op_type] & OA_DANGEROUS)) {
- if (curop->op_type == OP_GV) {
- GV * const gv = cGVOPx_gv(curop);
- repl_has_vars = 1;
- if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
- break;
- }
- else if (curop->op_type == OP_RV2CV)
- break;
- else if (curop->op_type == OP_RV2SV ||
- curop->op_type == OP_RV2AV ||
- curop->op_type == OP_RV2HV ||
- curop->op_type == OP_RV2GV) {
- if (lastop && lastop->op_type != OP_GV) /*funny deref?*/
- break;
- }
- else if (curop->op_type == OP_PADSV ||
- curop->op_type == OP_PADAV ||
- curop->op_type == OP_PADHV ||
- curop->op_type == OP_PADANY)
- {
- repl_has_vars = 1;
- }
- else if (curop->op_type == OP_PUSHRE)
- NOOP; /* Okay here, dangerous in newASSIGNOP */
- else
- break;
- }
- lastop = curop;
- }
- }
- if (curop == repl
+ /* If we are looking at s//.../e with a single statement, get past
+ the implicit do{}. */
+ if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS
+ && cUNOPx(curop)->op_first->op_type == OP_SCOPE
+ && cUNOPx(curop)->op_first->op_flags & OPf_KIDS) {
+ OP *kid = cUNOPx(cUNOPx(curop)->op_first)->op_first;
+ if (kid->op_type == OP_NULL && kid->op_sibling
+ && !kid->op_sibling->op_sibling)
+ curop = kid->op_sibling;
+ }
+ if (curop->op_type == OP_CONST)
+ konst = TRUE;
+ else if (( (curop->op_type == OP_RV2SV ||
+ curop->op_type == OP_RV2AV ||
+ curop->op_type == OP_RV2HV ||
+ curop->op_type == OP_RV2GV)
+ && cUNOPx(curop)->op_first
+ && cUNOPx(curop)->op_first->op_type == OP_GV )
+ || curop->op_type == OP_PADSV
+ || curop->op_type == OP_PADAV
+ || curop->op_type == OP_PADHV
+ || curop->op_type == OP_PADANY) {
+ repl_has_vars = 1;
+ konst = TRUE;
+ }
+ else konst = FALSE;
+ if (konst
&& !(repl_has_vars
&& (!PM_GETRE(pm)
+ || !RX_PRELEN(PM_GETRE(pm))
|| RX_EXTFLAGS(PM_GETRE(pm)) & RXf_EVAL_SEEN)))
{
pm->op_pmflags |= PMf_CONST; /* const for long enough */
op_prepend_elem(o->op_type, scalar(repl), o);
}
else {
- if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
- pm->op_pmflags |= PMf_MAYBE_CONST;
- }
NewOp(1101, rcop, 1, LOGOP);
rcop->op_type = OP_SUBSTCONT;
rcop->op_ppaddr = PL_ppaddr[OP_SUBSTCONT];
}
STATIC I32
-S_is_list_assignment(pTHX_ register const OP *o)
+S_is_list_assignment(pTHX_ const OP *o)
{
unsigned type;
U8 flags;
= MUTABLE_GV(cSVOPx(tmpop)->op_sv);
cSVOPx(tmpop)->op_sv = NULL; /* steal it */
#endif
- pm->op_pmflags |= PMf_ONCE;
tmpop = cUNOPo->op_first; /* to list (nulled) */
tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
tmpop->op_sibling = NULL; /* don't free split */
{
/* Basically turn for($x..$y) into the same as for($x,$y), but we
* set the STACKED flag to indicate that these values are to be
- * treated as min/max values by 'pp_iterinit'.
+ * treated as min/max values by 'pp_enteriter'.
*/
const UNOP* const flip = (UNOP*)((UNOP*)((BINOP*)expr)->op_first)->op_first;
LOGOP* const range = (LOGOP*) flip->op_first;
return sv;
}
+static bool
+S_already_defined(pTHX_ CV *const cv, OP * const block, OP * const o,
+ PADNAME * const name, SV ** const const_svp)
+{
+ assert (cv);
+ assert (o || name);
+ assert (const_svp);
+ if ((!block
+#ifdef PERL_MAD
+ || block->op_type == OP_NULL
+#endif
+ )) {
+ if (CvFLAGS(PL_compcv)) {
+ /* might have had built-in attrs applied */
+ const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
+ if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
+ && ckWARN(WARN_MISC))
+ {
+ /* protect against fatal warnings leaking compcv */
+ SAVEFREESV(PL_compcv);
+ Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
+ SvREFCNT_inc_simple_void_NN(PL_compcv);
+ }
+ CvFLAGS(cv) |=
+ (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
+ & ~(CVf_LVALUE * pureperl));
+ }
+ return FALSE;
+ }
+
+ /* redundant check for speed: */
+ if (CvCONST(cv) || ckWARN(WARN_REDEFINE)) {
+ const line_t oldline = CopLINE(PL_curcop);
+ SV *namesv = o
+ ? cSVOPo->op_sv
+ : sv_2mortal(newSVpvn_utf8(
+ PadnamePV(name)+1,PadnameLEN(name)-1, PadnameUTF8(name)
+ ));
+ if (PL_parser && PL_parser->copline != NOLINE)
+ /* This ensures that warnings are reported at the first
+ line of a redefinition, not the last. */
+ CopLINE_set(PL_curcop, PL_parser->copline);
+ /* protect against fatal warnings leaking compcv */
+ SAVEFREESV(PL_compcv);
+ report_redefined_cv(namesv, cv, const_svp);
+ SvREFCNT_inc_simple_void_NN(PL_compcv);
+ CopLINE_set(PL_curcop, oldline);
+ }
+#ifdef PERL_MAD
+ if (!PL_minus_c) /* keep old one around for madskills */
+#endif
+ {
+ /* (PL_madskills unset in used file.) */
+ SvREFCNT_dec(cv);
+ }
+ return TRUE;
+}
+
CV *
Perl_newMYSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
{
const char *ps;
STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
U32 ps_utf8 = 0;
- register CV *cv = NULL;
- register CV *compcv = PL_compcv;
+ CV *cv = NULL;
+ CV *compcv = PL_compcv;
SV *const_sv;
PADNAME *name;
PADOFFSET pax = o->op_targ;
if (PL_parser && PL_parser->error_count) {
op_free(block);
+ SvREFCNT_dec(PL_compcv);
+ PL_compcv = 0;
goto done;
}
cv_ckproto_len_flags(cv, (GV *)name, ps, ps_len, ps_utf8);
/* already defined? */
if (exists) {
- if ((!block
-#ifdef PERL_MAD
- || block->op_type == OP_NULL
-#endif
- )) {
- if (CvFLAGS(compcv)) {
- /* might have had built-in attrs applied */
- const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
- if (CvLVALUE(compcv) && ! CvLVALUE(cv) && pureperl
- && ckWARN(WARN_MISC))
- Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
- CvFLAGS(cv) |=
- (CvFLAGS(compcv) & CVf_BUILTIN_ATTRS
- & ~(CVf_LVALUE * pureperl));
- }
+ if (S_already_defined(aTHX_ cv, block, NULL, name, &const_sv))
+ cv = NULL;
+ else {
if (attrs) goto attrs;
/* just a "sub foo;" when &foo is already defined */
SAVEFREESV(compcv);
goto done;
}
- else {
- /* redundant check that avoids creating the extra SV
- most of the time: */
- if (const_sv || ckWARN(WARN_REDEFINE)) {
- const line_t oldline = CopLINE(PL_curcop);
- SV *noamp = sv_2mortal(newSVpvn_utf8(
- PadnamePV(name)+1,PadnameLEN(name)-1,
- PadnameUTF8(name)
- ));
- if (PL_parser && PL_parser->copline != NOLINE)
- CopLINE_set(PL_curcop, PL_parser->copline);
- report_redefined_cv(noamp, cv, &const_sv);
- CopLINE_set(PL_curcop, oldline);
- }
-#ifdef PERL_MAD
- if (!PL_minus_c) /* keep old one around for madskills */
-#endif
- {
- /* (PL_madskills unset in used file.) */
- SvREFCNT_dec(cv);
- }
- cv = NULL;
- }
}
else if (CvDEPTH(outcv) && CvCLONE(compcv)) {
cv = NULL;
&PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax];
if (reusable) cv_clone_into(clonee, *spot);
else *spot = cv_clone(clonee);
- SvREFCNT_dec(clonee);
+ SvREFCNT_dec_NN(clonee);
cv = *spot;
SvPADMY_on(cv);
}
if (ec) {
op_free(block);
+ if (name) SvREFCNT_dec(PL_compcv);
+ else cv = PL_compcv;
+ PL_compcv = 0;
if (name && block) {
const char *s = strrchr(name, ':');
s = s ? s+1 : name;
if (strEQ(s, "BEGIN")) {
- const char not_safe[] =
- "BEGIN not safe after errors--compilation aborted";
if (PL_in_eval & EVAL_KEEPERR)
- Perl_croak(aTHX_ not_safe);
+ Perl_croak_nocontext("BEGIN not safe after errors--compilation aborted");
else {
+ SV * const errsv = ERRSV;
/* force display of errors found but not reported */
- sv_catpv(ERRSV, not_safe);
- Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV));
+ sv_catpvs(errsv, "BEGIN not safe after errors--compilation aborted");
+ Perl_croak_nocontext("%"SVf, SVfARG(errsv));
}
}
}
- cv = PL_compcv;
goto done;
}
cv_ckproto_len_flags(cv, gv, ps, ps_len, ps_utf8);
/* already defined (or promised)? */
if (exists || GvASSUMECV(gv)) {
- if ((!block
-#ifdef PERL_MAD
- || block->op_type == OP_NULL
-#endif
- )) {
- if (CvFLAGS(PL_compcv)) {
- /* might have had built-in attrs applied */
- const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
- if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
- && ckWARN(WARN_MISC))
- Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
- CvFLAGS(cv) |=
- (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
- & ~(CVf_LVALUE * pureperl));
- }
+ if (S_already_defined(aTHX_ cv, block, o, NULL, &const_sv))
+ cv = NULL;
+ else {
if (attrs) goto attrs;
/* just a "sub foo;" when &foo is already defined */
SAVEFREESV(PL_compcv);
goto done;
}
- if (block
-#ifdef PERL_MAD
- && block->op_type != OP_NULL
-#endif
- ) {
- const line_t oldline = CopLINE(PL_curcop);
- if (PL_parser && PL_parser->copline != NOLINE) {
- /* This ensures that warnings are reported at the first
- line of a redefinition, not the last. */
- CopLINE_set(PL_curcop, PL_parser->copline);
- }
- report_redefined_cv(cSVOPo->op_sv, cv, &const_sv);
- CopLINE_set(PL_curcop, oldline);
-#ifdef PERL_MAD
- if (!PL_minus_c) /* keep old one around for madskills */
-#endif
- {
- /* (PL_madskills unset in used file.) */
- SvREFCNT_dec(cv);
- }
- cv = NULL;
- }
}
}
if (const_sv) {
GvCVGEN(gv) = 0;
if (HvENAME_HEK(GvSTASH(gv)))
/* sub Foo::bar { (shift)+1 } */
- mro_method_changed_in(GvSTASH(gv));
+ gv_method_changed(gv);
}
}
if (!CvGV(cv)) {
if (attrs) {
/* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash;
+ if (!name) SAVEFREESV(cv);
apply_attrs(stash, MUTABLE_SV(cv), attrs);
+ if (!name) SvREFCNT_inc_simple_void_NN(cv);
}
if (block && has_name) {
PL_curstash = (HV *)SvREFCNT_inc_simple_NN(stash);
}
+ /* Protect sv against leakage caused by fatal warnings. */
+ if (sv) SAVEFREESV(sv);
+
/* file becomes the CvFILE. For an XS, it's usually static storage,
and so doesn't get free()d. (It's expected to be from the C pre-
processor __FILE__ directive). But we need a dynamically allocated one,
and we need it to get freed. */
cv = newXS_len_flags(name, len, const_sv_xsub, file ? file : "", "",
&sv, XS_DYNAMIC_FILENAME | flags);
- CvXSUBANY(cv).any_ptr = sv;
+ CvXSUBANY(cv).any_ptr = SvREFCNT_inc_simple(sv);
CvCONST_on(cv);
LEAVE;
PERL_ARGS_ASSERT_NEWXS_LEN_FLAGS;
{
- GV * const gv = name
- ? gv_fetchpvn(
- name,len,GV_ADDMULTI|flags,SVt_PVCV
- )
- : gv_fetchpv(
- (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
- GV_ADDMULTI | flags, SVt_PVCV);
+ GV * const gv = gv_fetchpvn(
+ name ? name : PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
+ name ? len : PL_curstash ? sizeof("__ANON__") - 1:
+ sizeof("__ANON__::__ANON__") - 1,
+ GV_ADDMULTI | flags, SVt_PVCV);
if (!subaddr)
Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
),
cv, const_svp);
}
- SvREFCNT_dec(cv);
+ SvREFCNT_dec_NN(cv);
cv = NULL;
}
}
GvCV_set(gv,cv);
GvCVGEN(gv) = 0;
if (HvENAME_HEK(GvSTASH(gv)))
- mro_method_changed_in(GvSTASH(gv)); /* newXS */
+ gv_method_changed(gv); /* newXS */
}
}
if (!name)
GvCV_set(gv, cv);
GvCVGEN(gv) = 0;
if (!fake && HvENAME_HEK(GvSTASH(gv)))
- mro_method_changed_in(GvSTASH(gv));
+ gv_method_changed(gv);
CvGV_set(cv, gv);
CvFILE_set_from_cop(cv, PL_curcop);
CvSTASH_set(cv, PL_curstash);
Perl_newCVREF(pTHX_ I32 flags, OP *o)
{
if (o->op_type == OP_PADANY) {
+ dVAR;
o->op_type = OP_PADCV;
o->op_ppaddr = PL_ppaddr[OP_PADCV];
return o;
}
OP *
-Perl_ck_rvconst(pTHX_ register OP *o)
+Perl_ck_rvconst(pTHX_ OP *o)
{
dVAR;
SVOP * const kid = (SVOP*)cUNOPo->op_first;
* \ mark - glob - rv2cv
* | \ gv(CORE::GLOBAL::glob)
* |
- * \ null - const(wildcard) - const(ix)
+ * \ null - const(wildcard)
*/
o->op_flags |= OPf_SPECIAL;
o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
- op_append_elem(OP_GLOB, o,
- newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
o = newLISTOP(OP_LIST, 0, o, NULL);
o = newUNOP(OP_ENTERSUB, OPf_STACKED,
op_append_elem(OP_LIST, o,
LEAVE;
}
#endif /* !PERL_EXTERNAL_GLOB */
- gv = newGVgen("main");
+ gv = (GV *)newSV(0);
+ gv_init(gv, 0, "", 0, 0);
gv_IOadd(gv);
-#ifndef PERL_EXTERNAL_GLOB
- sv_setiv(GvSVn(gv),PL_glob_index++);
-#endif
op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
+ SvREFCNT_dec_NN(gv); /* newGVOP increased it */
scalarkids(o);
return o;
}
if (kid)
kid = kid->op_sibling; /* get past "big" */
if (kid && kid->op_type == OP_CONST) {
- const bool save_taint = PL_tainted;
+ const bool save_taint = TAINT_get; /* accepted unused var warning if NO_TAINT_SUPPORT */
fbm_compile(((SVOP*)kid)->op_sv, 0);
- PL_tainted = save_taint;
+ TAINT_set(save_taint);
}
}
return ck_fun(o);
const char * const method = SvPVX_const(sv);
if (!(strchr(method, ':') || strchr(method, '\''))) {
OP *cmop;
- if (!SvREADONLY(sv) || !SvFAKE(sv)) {
+ if (!SvIsCOW(sv)) {
sv = newSVpvn_share(method, SvUTF8(sv) ? -(I32)SvCUR(sv) : (I32)SvCUR(sv), 0);
}
else {
const char *end;
if (was_readonly) {
- if (SvFAKE(sv)) {
- sv_force_normal_flags(sv, 0);
- assert(!SvREADONLY(sv));
- was_readonly = 0;
- } else {
SvREADONLY_off(sv);
- }
}
+ if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0);
s = SvPVX(sv);
len = SvCUR(sv);
{
PERL_ARGS_ASSERT_CK_SVCONST;
PERL_UNUSED_CONTEXT;
- SvREADONLY_on(cSVOPo->op_sv);
+ if (!SvIsCOW(cSVOPo->op_sv)) SvREADONLY_on(cSVOPo->op_sv);
return o;
}
* peep() is called */
void
-Perl_rpeep(pTHX_ register OP *o)
+Perl_rpeep(pTHX_ OP *o)
{
dVAR;
OP* oldop = NULL;
+ OP* oldoldop = NULL;
OP* defer_queue[MAX_DEFERRED]; /* small queue of deferred branches */
int defer_base = 0;
int defer_ix = -1;
}
break;
+ case OP_PUSHMARK:
+
+ /* Convert a series of PAD ops for my vars plus support into a
+ * single padrange op. Basically
+ *
+ * pushmark -> pad[ahs]v -> pad[ahs]?v -> ... -> (list) -> rest
+ *
+ * becomes, depending on circumstances, one of
+ *
+ * padrange ----------------------------------> (list) -> rest
+ * padrange --------------------------------------------> rest
+ *
+ * where all the pad indexes are sequential and of the same type
+ * (INTRO or not).
+ * We convert the pushmark into a padrange op, then skip
+ * any other pad ops, and possibly some trailing ops.
+ * Note that we don't null() the skipped ops, to make it
+ * easier for Deparse to undo this optimisation (and none of
+ * the skipped ops are holding any resourses). It also makes
+ * it easier for find_uninit_var(), as it can just ignore
+ * padrange, and examine the original pad ops.
+ */
+ {
+ OP *p;
+ OP *followop = NULL; /* the op that will follow the padrange op */
+ U8 count = 0;
+ U8 intro = 0;
+ PADOFFSET base = 0; /* init only to stop compiler whining */
+ U8 gimme = 0; /* init only to stop compiler whining */
+ bool defav = 0; /* seen (...) = @_ */
+ bool reuse = 0; /* reuse an existing padrange op */
+
+ /* look for a pushmark -> gv[_] -> rv2av */
+
+ {
+ GV *gv;
+ OP *rv2av, *q;
+ p = o->op_next;
+ if ( p->op_type == OP_GV
+ && (gv = cGVOPx_gv(p))
+ && GvNAMELEN_get(gv) == 1
+ && *GvNAME_get(gv) == '_'
+ && GvSTASH(gv) == PL_defstash
+ && (rv2av = p->op_next)
+ && rv2av->op_type == OP_RV2AV
+ && !(rv2av->op_flags & OPf_REF)
+ && !(rv2av->op_private & (OPpLVAL_INTRO|OPpMAYBE_LVSUB))
+ && ((rv2av->op_flags & OPf_WANT) == OPf_WANT_LIST)
+ && o->op_sibling == rv2av /* these two for Deparse */
+ && cUNOPx(rv2av)->op_first == p
+ ) {
+ q = rv2av->op_next;
+ if (q->op_type == OP_NULL)
+ q = q->op_next;
+ if (q->op_type == OP_PUSHMARK) {
+ defav = 1;
+ p = q;
+ }
+ }
+ }
+ if (!defav) {
+ /* To allow Deparse to pessimise this, it needs to be able
+ * to restore the pushmark's original op_next, which it
+ * will assume to be the same as op_sibling. */
+ if (o->op_next != o->op_sibling)
+ break;
+ p = o;
+ }
+
+ /* scan for PAD ops */
+
+ for (p = p->op_next; p; p = p->op_next) {
+ if (p->op_type == OP_NULL)
+ continue;
+
+ if (( p->op_type != OP_PADSV
+ && p->op_type != OP_PADAV
+ && p->op_type != OP_PADHV
+ )
+ /* any private flag other than INTRO? e.g. STATE */
+ || (p->op_private & ~OPpLVAL_INTRO)
+ )
+ break;
+
+ /* let $a[N] potentially be optimised into ALEMFAST_LEX
+ * instead */
+ if ( p->op_type == OP_PADAV
+ && p->op_next
+ && p->op_next->op_type == OP_CONST
+ && p->op_next->op_next
+ && p->op_next->op_next->op_type == OP_AELEM
+ )
+ break;
+
+ /* for 1st padop, note what type it is and the range
+ * start; for the others, check that it's the same type
+ * and that the targs are contiguous */
+ if (count == 0) {
+ intro = (p->op_private & OPpLVAL_INTRO);
+ base = p->op_targ;
+ gimme = (p->op_flags & OPf_WANT);
+ }
+ else {
+ if ((p->op_private & OPpLVAL_INTRO) != intro)
+ break;
+ /* Note that you'd normally expect targs to be
+ * contiguous in my($a,$b,$c), but that's not the case
+ * when external modules start doing things, e.g.
+ i* Function::Parameters */
+ if (p->op_targ != base + count)
+ break;
+ assert(p->op_targ == base + count);
+ /* all the padops should be in the same context */
+ if (gimme != (p->op_flags & OPf_WANT))
+ break;
+ }
+
+ /* for AV, HV, only when we're not flattening */
+ if ( p->op_type != OP_PADSV
+ && gimme != OPf_WANT_VOID
+ && !(p->op_flags & OPf_REF)
+ )
+ break;
+
+ if (count >= OPpPADRANGE_COUNTMASK)
+ break;
+
+ /* there's a biggest base we can fit into a
+ * SAVEt_CLEARPADRANGE in pp_padrange */
+ if (intro && base >
+ (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT)))
+ break;
+
+ /* Success! We've got another valid pad op to optimise away */
+ count++;
+ followop = p->op_next;
+ }
+
+ if (count < 1)
+ break;
+
+ /* pp_padrange in specifically compile-time void context
+ * skips pushing a mark and lexicals; in all other contexts
+ * (including unknown till runtime) it pushes a mark and the
+ * lexicals. We must be very careful then, that the ops we
+ * optimise away would have exactly the same effect as the
+ * padrange.
+ * In particular in void context, we can only optimise to
+ * a padrange if see see the complete sequence
+ * pushmark, pad*v, ...., list, nextstate
+ * which has the net effect of of leaving the stack empty
+ * (for now we leave the nextstate in the execution chain, for
+ * its other side-effects).
+ */
+ assert(followop);
+ if (gimme == OPf_WANT_VOID) {
+ if (followop->op_type == OP_LIST
+ && gimme == (followop->op_flags & OPf_WANT)
+ && ( followop->op_next->op_type == OP_NEXTSTATE
+ || followop->op_next->op_type == OP_DBSTATE))
+ {
+ followop = followop->op_next; /* skip OP_LIST */
+
+ /* consolidate two successive my(...);'s */
+
+ if ( oldoldop
+ && oldoldop->op_type == OP_PADRANGE
+ && (oldoldop->op_flags & OPf_WANT) == OPf_WANT_VOID
+ && (oldoldop->op_private & OPpLVAL_INTRO) == intro
+ && !(oldoldop->op_flags & OPf_SPECIAL)
+ ) {
+ U8 old_count;
+ assert(oldoldop->op_next == oldop);
+ assert( oldop->op_type == OP_NEXTSTATE
+ || oldop->op_type == OP_DBSTATE);
+ assert(oldop->op_next == o);
+
+ old_count
+ = (oldoldop->op_private & OPpPADRANGE_COUNTMASK);
+ assert(oldoldop->op_targ + old_count == base);
+
+ if (old_count < OPpPADRANGE_COUNTMASK - count) {
+ base = oldoldop->op_targ;
+ count += old_count;
+ reuse = 1;
+ }
+ }
+
+ /* if there's any immediately following singleton
+ * my var's; then swallow them and the associated
+ * nextstates; i.e.
+ * my ($a,$b); my $c; my $d;
+ * is treated as
+ * my ($a,$b,$c,$d);
+ */
+
+ while ( ((p = followop->op_next))
+ && ( p->op_type == OP_PADSV
+ || p->op_type == OP_PADAV
+ || p->op_type == OP_PADHV)
+ && (p->op_flags & OPf_WANT) == OPf_WANT_VOID
+ && (p->op_private & OPpLVAL_INTRO) == intro
+ && p->op_next
+ && ( p->op_next->op_type == OP_NEXTSTATE
+ || p->op_next->op_type == OP_DBSTATE)
+ && count < OPpPADRANGE_COUNTMASK
+ ) {
+ assert(base + count == p->op_targ);
+ count++;
+ followop = p->op_next;
+ }
+ }
+ else
+ break;
+ }
+
+ if (reuse) {
+ assert(oldoldop->op_type == OP_PADRANGE);
+ oldoldop->op_next = followop;
+ oldoldop->op_private = (intro | count);
+ o = oldoldop;
+ oldop = NULL;
+ oldoldop = NULL;
+ }
+ else {
+ /* Convert the pushmark into a padrange.
+ * To make Deparse easier, we guarantee that a padrange was
+ * *always* formerly a pushmark */
+ assert(o->op_type == OP_PUSHMARK);
+ o->op_next = followop;
+ o->op_type = OP_PADRANGE;
+ o->op_ppaddr = PL_ppaddr[OP_PADRANGE];
+ o->op_targ = base;
+ /* bit 7: INTRO; bit 6..0: count */
+ o->op_private = (intro | count);
+ o->op_flags = ((o->op_flags & ~(OPf_WANT|OPf_SPECIAL))
+ | gimme | (defav ? OPf_SPECIAL : 0));
+ }
+ break;
+ }
+
case OP_PADAV:
case OP_GV:
if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
}
}
+ oldoldop = oldop;
oldop = o;
}
LEAVE;
}
void
-Perl_peep(pTHX_ register OP *o)
+Perl_peep(pTHX_ OP *o)
{
CALL_RPEEP(o);
}
https://perl5.git.perl.org / perl5.git / blobdiff