return;
type = o->op_type;
+
+ /* an op should only ever acquire op_private flags that we know about.
+ * If this fails, you may need to fix something in regen/op_private */
+ assert(!(o->op_private & ~PL_op_private_valid[type]));
+
if (o->op_private & OPpREFCOUNTED) {
switch (type) {
case OP_LEAVESUB:
if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
!(o->op_flags & OPf_STACKED)) {
o->op_type = OP_RV2CV; /* entersub => rv2cv */
- /* Both ENTERSUB and RV2CV use this bit, but for different pur-
- poses, so we need it clear. */
- o->op_private &= ~1;
o->op_ppaddr = PL_ppaddr[OP_RV2CV];
assert(cUNOPo->op_first->op_type == OP_NULL);
op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
assert(cUNOPo->op_first->op_type == OP_NULL);
op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
o->op_flags |= OPf_SPECIAL;
- o->op_private &= ~1;
}
else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
SV * const oldwarnhook = PL_warnhook;
SV * const olddiehook = PL_diehook;
COP not_compiling;
+ U8 oldwarn = PL_dowarn;
dJMPENV;
PERL_ARGS_ASSERT_FOLD_CONSTANTS;
PL_diehook = NULL;
JMPENV_PUSH(ret);
+ /* Effective $^W=1. */
+ if ( ! (PL_dowarn & G_WARN_ALL_MASK))
+ PL_dowarn |= G_WARN_ON;
+
switch (ret) {
case 0:
CALLRUNOPS(aTHX);
Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
}
JMPENV_POP;
+ PL_dowarn = oldwarn;
PL_warnhook = oldwarnhook;
PL_diehook = olddiehook;
PL_curcop = &PL_compiling;
NewOp(1101, padop, 1, PADOP);
padop->op_type = (OPCODE)type;
padop->op_ppaddr = PL_ppaddr[type];
- padop->op_padix = pad_alloc(type, SVs_PADTMP);
+ padop->op_padix =
+ pad_alloc(type, IS_PADGV(sv) ? SVf_READONLY : SVs_PADTMP);
SvREFCNT_dec(PAD_SVl(padop->op_padix));
PAD_SETSV(padop->op_padix, sv);
assert(sv);
{
if (!cv)
return NULL;
+ if (SvROK(cv)) return SvRV((SV *)cv);
assert (SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM);
return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
}
return NULL;
if (type == OP_CONST && cSVOPo->op_sv)
sv = cSVOPo->op_sv;
+ else if (type == OP_UNDEF && !o->op_private) {
+ sv = newSV(0);
+ SAVEFREESV(sv);
+ }
else if (cv && type == OP_CONST) {
sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
if (!sv)
if (CvNAMED(*spot))
hek = CvNAME_HEK(*spot);
else {
+ dVAR;
+ U32 hash;
+ PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
CvNAME_HEK_set(*spot, hek =
share_hek(
PadnamePV(name)+1,
- PadnameLEN(name)-1 * (PadnameUTF8(name) ? -1 : 1), 0
+ PadnameLEN(name)-1 * (PadnameUTF8(name) ? -1 : 1), hash
)
);
}
}
setname:
if (!CvNAME_HEK(cv)) {
- CvNAME_HEK_set(cv,
- hek
- ? share_hek_hek(hek)
- : share_hek(PadnamePV(name)+1,
+ if (hek) share_hek_hek(hek);
+ else {
+ dVAR;
+ U32 hash;
+ PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
+ hek = share_hek(PadnamePV(name)+1,
PadnameLEN(name)-1 * (PadnameUTF8(name) ? -1 : 1),
- 0)
- );
+ hash);
+ }
+ CvNAME_HEK_set(cv, hek);
}
if (const_sv) goto clone;
o ? (const GV *)cSVOPo->op_sv : NULL, ps,
ps_len, ps_utf8);
}
- if (ps) {
+ if (!SvROK(gv)) {
+ if (ps) {
sv_setpvn(MUTABLE_SV(gv), ps, ps_len);
if ( ps_utf8 ) SvUTF8_on(MUTABLE_SV(gv));
- }
- else
+ }
+ else
sv_setiv(MUTABLE_SV(gv), -1);
+ }
SvREFCNT_dec(PL_compcv);
cv = PL_compcv = NULL;
CvISXSUB_on(cv);
}
else {
- GvCV_set(gv, NULL);
+ if (name) GvCV_set(gv, NULL);
cv = newCONSTSUB_flags(
NULL, name, namlen, name_is_utf8 ? SVf_UTF8 : 0,
const_sv
PERL_ARGS_ASSERT_CK_RVCONST;
o->op_private |= (PL_hints & HINT_STRICT_REFS);
- if (o->op_type == OP_RV2CV)
- o->op_private &= ~1;
if (kid->op_type == OP_CONST) {
int iscv;
+ const int noexpand = o->op_type == OP_RV2CV
+ && o->op_private & OPpMAY_RETURN_CONSTANT
+ ? GV_NOEXPAND
+ : 0;
GV *gv;
SV * const kidsv = kid->op_sv;
/* Is it a constant from cv_const_sv()? */
- if (SvROK(kidsv) && SvREADONLY(kidsv)) {
+ if ((SvROK(kidsv) || isGV_with_GP(kidsv)) && SvREADONLY(kidsv)) {
return o;
}
if (SvTYPE(kidsv) == SVt_PVAV) return o;
* whether the lexer already added THIS instance of this symbol.
*/
iscv = (o->op_type == OP_RV2CV) * 2;
- do {
- gv = gv_fetchsv(kidsv,
- iscv | !(kid->op_private & OPpCONST_ENTERED),
+ gv = gv_fetchsv(kidsv,
+ noexpand
+ ? noexpand
+ : iscv | !(kid->op_private & OPpCONST_ENTERED),
iscv
? SVt_PVCV
: o->op_type == OP_RV2SV
: o->op_type == OP_RV2HV
? SVt_PVHV
: SVt_PVGV);
- } while (!gv && !(kid->op_private & OPpCONST_ENTERED) && !iscv++);
if (gv) {
kid->op_type = OP_GV;
SvREFCNT_dec(kid->op_sv);
#ifdef USE_ITHREADS
/* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
assert (sizeof(PADOP) <= sizeof(SVOP));
- kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
+ kPADOP->op_padix = pad_alloc(OP_GV, SVf_READONLY);
SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
- GvIN_PAD_on(gv);
+ 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);
if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
SVOP * const kid = (SVOP*)cUNOPo->op_first;
-
- if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
- SV * const sv = kid->op_sv;
- U32 was_readonly = SvREADONLY(sv);
- char *s;
- STRLEN len;
+ HEK *hek;
+ U32 hash;
+ char *s;
+ STRLEN len;
+ if (kid->op_type == OP_CONST) {
+ SV * const sv = kid->op_sv;
+ U32 const was_readonly = SvREADONLY(sv);
+ if (kid->op_private & OPpCONST_BARE) {
+ dVAR;
const char *end;
if (was_readonly) {
}
SvEND_set(sv, end);
sv_catpvs(sv, ".pm");
+ PERL_HASH(hash, SvPVX(sv), SvCUR(sv));
+ hek = share_hek(SvPVX(sv),
+ (SSize_t)SvCUR(sv) * (SvUTF8(sv) ? -1 : 1),
+ hash);
+ sv_sethek(sv, hek);
+ unshare_hek(hek);
SvFLAGS(sv) |= was_readonly;
+ }
+ else if (SvPOK(sv) && !SvNIOK(sv) && !SvGMAGICAL(sv)) {
+ s = SvPV(sv, len);
+ if (SvREFCNT(sv) > 1) {
+ kid->op_sv = newSVpvn_share(
+ s, SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len, 0);
+ SvREFCNT_dec_NN(sv);
+ }
+ else {
+ dVAR;
+ if (was_readonly) SvREADONLY_off(sv);
+ PERL_HASH(hash, s, len);
+ hek = share_hek(s,
+ SvUTF8(sv) ? -(SSize_t)len : (SSize_t)len,
+ hash);
+ sv_sethek(sv, hek);
+ unshare_hek(hek);
+ SvFLAGS(sv) |= was_readonly;
+ }
+ }
}
}
CV *cv;
GV *gv;
PERL_ARGS_ASSERT_RV2CV_OP_CV;
- if (flags & ~(RV2CVOPCV_MARK_EARLY|RV2CVOPCV_RETURN_NAME_GV))
+ if (flags & ~RV2CVOPCV_FLAG_MASK)
Perl_croak(aTHX_ "panic: rv2cv_op_cv bad flags %x", (unsigned)flags);
if (cvop->op_type != OP_RV2CV)
return NULL;
switch (rvop->op_type) {
case OP_GV: {
gv = cGVOPx_gv(rvop);
+ if (!isGV(gv)) {
+ if (flags & RV2CVOPCV_RETURN_STUB)
+ return (CV *)gv;
+ else return NULL;
+ }
cv = GvCVu(gv);
if (!cv) {
if (flags & RV2CVOPCV_MARK_EARLY)
goto wrapref; /* autoconvert GLOB -> GLOBref */
else if (o3->op_type == OP_CONST)
o3->op_private &= ~OPpCONST_STRICT;
- else if (o3->op_type == OP_ENTERSUB) {
- /* accidental subroutine, revert to bareword */
- OP *gvop = ((UNOP*)o3)->op_first;
- if (gvop && gvop->op_type == OP_NULL) {
- gvop = ((UNOP*)gvop)->op_first;
- if (gvop) {
- for (; OP_HAS_SIBLING(gvop); gvop = OP_SIBLING(gvop))
- ;
- if (gvop &&
- (gvop->op_private & OPpENTERSUB_NOPAREN) &&
- (gvop = ((UNOP*)gvop)->op_first) &&
- gvop->op_type == OP_GV)
- {
- OP * newop;
- GV * const gv = cGVOPx_gv(gvop);
- SV * const n = newSVpvs("");
- gv_fullname4(n, gv, "", FALSE);
- /* replace the aop subtree with a const op */
- newop = newSVOP(OP_CONST, 0, n);
- op_sibling_splice(parent, prev, 1, newop);
- op_free(aop);
- aop = newop;
- }
- }
- }
- }
scalar(aop);
break;
case '+':
https://perl5.git.perl.org / perl5.git / blobdiff