SV **svp = AvARRAY(PL_comppad_name);
HV *ourstash = (PL_curstash ? PL_curstash : PL_defstash);
PADOFFSET top = AvFILLp(PL_comppad_name);
- for (off = top; off > PL_comppad_name_floor; off--) {
+ for (off = top; (I32)off > PL_comppad_name_floor; off--) {
if ((sv = svp[off])
&& sv != &PL_sv_undef
&& (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)
for (off = AvFILLp(curname); off > 0; off--) {
if ((sv = svp[off]) &&
sv != &PL_sv_undef &&
- seq <= SvIVX(sv) &&
- seq > I_32(SvNVX(sv)) &&
+ seq <= (U32)SvIVX(sv) &&
+ seq > (U32)I_32(SvNVX(sv)) &&
strEQ(SvPVX(sv), name))
{
I32 depth;
if ((sv = svp[off]) &&
sv != &PL_sv_undef &&
(!SvIVX(sv) ||
- (seq <= SvIVX(sv) &&
- seq > I_32(SvNVX(sv)))) &&
+ (seq <= (U32)SvIVX(sv) &&
+ seq > (U32)I_32(SvNVX(sv)))) &&
strEQ(SvPVX(sv), name))
{
if (SvIVX(sv) || SvFLAGS(sv) & SVpad_OUR)
if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) {
SvPADTMP_off(PL_curpad[po]);
#ifdef USE_ITHREADS
- SvREADONLY_off(PL_curpad[po]); /* could be a freed constant */
+#ifdef PERL_COPY_ON_WRITE
+ if (SvIsCOW(PL_curpad[po])) {
+ sv_force_normal_flags(PL_curpad[po], SV_COW_DROP_PV);
+ } else
+#endif
+ SvREADONLY_off(PL_curpad[po]); /* could be a freed constant */
#endif
}
if ((I32)po < PL_padix)
}
type = o->op_type;
if (type == OP_NULL)
- type = o->op_targ;
+ type = (OPCODE)o->op_targ;
/* COP* is not cleared by op_clear() so that we may track line
* numbers etc even after null() */
case OP_OR:
case OP_AND:
+ case OP_DOR:
case OP_COND_EXPR:
for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
scalarvoid(kid);
case OP_AASSIGN:
case OP_NEXTSTATE:
case OP_DBSTATE:
- case OP_CHOMP:
PL_modcount = RETURN_UNLIMITED_NUMBER;
break;
case OP_RV2SV:
case OP_SASSIGN:
case OP_ANDASSIGN:
case OP_ORASSIGN:
+ case OP_DORASSIGN:
case OP_AELEMFAST:
PL_modcount++;
break;
} else if (type == OP_RV2SV || /* "our" declaration */
type == OP_RV2AV ||
type == OP_RV2HV) { /* XXX does this let anything illegal in? */
- if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
- yyerror(Perl_form(aTHX_ "Can't declare %s in my", OP_DESC(o)));
- }
- if (attrs) {
- GV *gv = cGVOPx_gv(cUNOPo->op_first);
- PL_in_my = FALSE;
- PL_in_my_stash = Nullhv;
- apply_attrs(GvSTASH(gv),
- (type == OP_RV2SV ? GvSV(gv) :
- type == OP_RV2AV ? (SV*)GvAV(gv) :
- type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
- attrs, FALSE);
- }
+ if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
+ yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
+ OP_DESC(o), PL_in_my == KEY_our ? "our" : "my"));
+ } else if (attrs) {
+ GV *gv = cGVOPx_gv(cUNOPo->op_first);
+ PL_in_my = FALSE;
+ PL_in_my_stash = Nullhv;
+ apply_attrs(GvSTASH(gv),
+ (type == OP_RV2SV ? GvSV(gv) :
+ type == OP_RV2AV ? (SV*)GvAV(gv) :
+ type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
+ attrs, FALSE);
+ }
o->op_private |= OPpOUR_INTRO;
return o;
}
OP *rops = Nullop;
int maybe_scalar = 0;
+/* [perl #17376]: this appears to be premature, and results in code such as
+ C< my(%x); > executing in list mode rather than void mode */
+#if 0
if (o->op_flags & OPf_PARENS)
list(o);
else
maybe_scalar = 1;
+#else
+ maybe_scalar = 1;
+#endif
if (attrs)
SAVEFREEOP(attrs);
o = my_kid(o, attrs, &rops);
PL_copline = copline; /* XXX newSTATEOP may reset PL_copline */
LEAVE_SCOPE(floor);
PL_pad_reset_pending = FALSE;
- PL_compiling.op_private = PL_hints;
+ PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
if (needblockscope)
PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
pad_leavemy(PL_comppad_name_fill);
Perl_localize(pTHX_ OP *o, I32 lex)
{
if (o->op_flags & OPf_PARENS)
+/* [perl #17376]: this appears to be premature, and results in code such as
+ C< our(%x); > executing in list mode rather than void mode */
+#if 0
list(o);
+#else
+ ;
+#endif
else {
if (ckWARN(WARN_PARENTHESIS)
&& PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',')
if (!(PL_opargs[type] & OA_MARK))
op_null(cLISTOPo->op_first);
- o->op_type = type;
+ o->op_type = (OPCODE)type;
o->op_ppaddr = PL_ppaddr[type];
o->op_flags |= flags;
NewOp(1101, listop, 1, LISTOP);
- listop->op_type = type;
+ listop->op_type = (OPCODE)type;
listop->op_ppaddr = PL_ppaddr[type];
if (first || last)
flags |= OPf_KIDS;
- listop->op_flags = flags;
+ listop->op_flags = (U8)flags;
if (!last && first)
last = first;
{
OP *o;
NewOp(1101, o, 1, OP);
- o->op_type = type;
+ o->op_type = (OPCODE)type;
o->op_ppaddr = PL_ppaddr[type];
- o->op_flags = flags;
+ o->op_flags = (U8)flags;
o->op_next = o;
- o->op_private = 0 + (flags >> 8);
+ o->op_private = (U8)(0 | (flags >> 8));
if (PL_opargs[type] & OA_RETSCALAR)
scalar(o);
if (PL_opargs[type] & OA_TARGET)
first = force_list(first);
NewOp(1101, unop, 1, UNOP);
- unop->op_type = type;
+ unop->op_type = (OPCODE)type;
unop->op_ppaddr = PL_ppaddr[type];
unop->op_first = first;
unop->op_flags = flags | OPf_KIDS;
- unop->op_private = 1 | (flags >> 8);
+ unop->op_private = (U8)(1 | (flags >> 8));
unop = (UNOP*) CHECKOP(type, unop);
if (unop->op_next)
return (OP*)unop;
if (!first)
first = newOP(OP_NULL, 0);
- binop->op_type = type;
+ binop->op_type = (OPCODE)type;
binop->op_ppaddr = PL_ppaddr[type];
binop->op_first = first;
binop->op_flags = flags | OPf_KIDS;
if (!last) {
last = first;
- binop->op_private = 1 | (flags >> 8);
+ binop->op_private = (U8)(1 | (flags >> 8));
}
else {
- binop->op_private = 2 | (flags >> 8);
+ binop->op_private = (U8)(2 | (flags >> 8));
first->op_sibling = last;
}
binop = (BINOP*)CHECKOP(type, binop);
- if (binop->op_next || binop->op_type != type)
+ if (binop->op_next || binop->op_type != (OPCODE)type)
return (OP*)binop;
binop->op_last = binop->op_first->op_sibling;
tbl = (short*)cPVOPo->op_pv;
if (complement) {
Zero(tbl, 256, short);
- for (i = 0; i < tlen; i++)
+ for (i = 0; i < (I32)tlen; i++)
tbl[t[i]] = -1;
for (i = 0, j = 0; i < 256; i++) {
if (!tbl[i]) {
- if (j >= rlen) {
+ if (j >= (I32)rlen) {
if (del)
tbl[i] = -2;
else if (rlen)
tbl[i] = r[j-1];
else
- tbl[i] = i;
+ tbl[i] = (short)i;
}
else {
if (i < 128 && r[j] >= 128)
if (!squash)
o->op_private |= OPpTRANS_IDENTICAL;
}
- else if (j >= rlen)
+ else if (j >= (I32)rlen)
j = rlen - 1;
else
cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
tbl[0x100] = rlen - j;
- for (i=0; i < rlen - j; i++)
+ for (i=0; i < (I32)rlen - j; i++)
tbl[0x101+i] = r[j+i];
}
}
}
for (i = 0; i < 256; i++)
tbl[i] = -1;
- for (i = 0, j = 0; i < tlen; i++,j++) {
- if (j >= rlen) {
+ for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
+ if (j >= (I32)rlen) {
if (del) {
if (tbl[t[i]] == -1)
tbl[t[i]] = -2;
PMOP *pmop;
NewOp(1101, pmop, 1, PMOP);
- pmop->op_type = type;
+ pmop->op_type = (OPCODE)type;
pmop->op_ppaddr = PL_ppaddr[type];
- pmop->op_flags = flags;
- pmop->op_private = 0 | (flags >> 8);
+ pmop->op_flags = (U8)flags;
+ pmop->op_private = (U8)(0 | (flags >> 8));
if (PL_hints & HINT_RE_TAINT)
pmop->op_pmpermflags |= PMf_RETAINT;
if (pm->op_pmflags & PMf_EVAL) {
curop = 0;
if (CopLINE(PL_curcop) < PL_multi_end)
- CopLINE_set(PL_curcop, PL_multi_end);
+ CopLINE_set(PL_curcop, (line_t)PL_multi_end);
}
#ifdef USE_5005THREADS
else if (repl->op_type == OP_THREADSV
{
SVOP *svop;
NewOp(1101, svop, 1, SVOP);
- svop->op_type = type;
+ svop->op_type = (OPCODE)type;
svop->op_ppaddr = PL_ppaddr[type];
svop->op_sv = sv;
svop->op_next = (OP*)svop;
- svop->op_flags = flags;
+ svop->op_flags = (U8)flags;
if (PL_opargs[type] & OA_RETSCALAR)
scalar((OP*)svop);
if (PL_opargs[type] & OA_TARGET)
{
PADOP *padop;
NewOp(1101, padop, 1, PADOP);
- padop->op_type = type;
+ padop->op_type = (OPCODE)type;
padop->op_ppaddr = PL_ppaddr[type];
padop->op_padix = pad_alloc(type, SVs_PADTMP);
SvREFCNT_dec(PL_curpad[padop->op_padix]);
PL_curpad[padop->op_padix] = sv;
SvPADTMP_on(sv);
padop->op_next = (OP*)padop;
- padop->op_flags = flags;
+ padop->op_flags = (U8)flags;
if (PL_opargs[type] & OA_RETSCALAR)
scalar((OP*)padop);
if (PL_opargs[type] & OA_TARGET)
{
PVOP *pvop;
NewOp(1101, pvop, 1, PVOP);
- pvop->op_type = type;
+ pvop->op_type = (OPCODE)type;
pvop->op_ppaddr = PL_ppaddr[type];
pvop->op_pv = pv;
pvop->op_next = (OP*)pvop;
- pvop->op_flags = flags;
+ pvop->op_flags = (U8)flags;
if (PL_opargs[type] & OA_RETSCALAR)
scalar((OP*)pvop);
if (PL_opargs[type] & OA_TARGET)
void
Perl_package(pTHX_ OP *o)
{
- SV *sv;
+ char *name;
+ STRLEN len;
save_hptr(&PL_curstash);
save_item(PL_curstname);
- if (o) {
- STRLEN len;
- char *name;
- sv = cSVOPo->op_sv;
- name = SvPV(sv, len);
- PL_curstash = gv_stashpvn(name,len,TRUE);
- sv_setpvn(PL_curstname, name, len);
- op_free(o);
- }
- else {
- deprecate("\"package\" with no arguments");
- sv_setpv(PL_curstname,"<none>");
- PL_curstash = Nullhv;
- }
+
+ name = SvPV(cSVOPo->op_sv, len);
+ PL_curstash = gv_stashpvn(name, len, TRUE);
+ sv_setpvn(PL_curstname, name, len);
+ op_free(o);
+
PL_hints |= HINT_BLOCK_SCOPE;
PL_copline = NOLINE;
PL_expect = XSTATE;
OP *pack;
OP *imop;
OP *veop;
- char *packname = Nullch;
- STRLEN packlen = 0;
- SV *packsv;
if (id->op_type != OP_CONST)
Perl_croak(aTHX_ "Module name must be constant");
pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
/* Fake up a method call to import/unimport */
- meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);;
+ meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);
(void)SvUPGRADE(meth, SVt_PVIV);
(void)SvIOK_on(meth);
PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
newSVOP(OP_METHOD_NAMED, 0, meth)));
}
- if (ckWARN(WARN_MISC) &&
- imop && (imop != arg) && /* no warning on use 5.0; or explicit () */
- SvPOK(packsv = ((SVOP*)id)->op_sv))
- {
- /* BEGIN will free the ops, so we need to make a copy */
- packlen = SvCUR(packsv);
- packname = savepvn(SvPVX(packsv), packlen);
- }
-
/* Fake up the BEGIN {}, which does its thing immediately. */
newATTRSUB(floor,
newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
newSTATEOP(0, Nullch, veop)),
newSTATEOP(0, Nullch, imop) ));
- if (packname) {
- /* The "did you use incorrect case?" warning used to be here.
- * The problem is that on case-insensitive filesystems one
- * might get false positives for "use" (and "require"):
- * "use Strict" or "require CARP" will work. This causes
- * portability problems for the script: in case-strict
- * filesystems the script will stop working.
- *
- * The "incorrect case" warning checked whether "use Foo"
- * imported "Foo" to your namespace, but that is wrong, too:
- * there is no requirement nor promise in the language that
- * a Foo.pm should or would contain anything in package "Foo".
- *
- * There is very little Configure-wise that can be done, either:
- * the case-sensitivity of the build filesystem of Perl does not
- * help in guessing the case-sensitivity of the runtime environment.
- */
- safefree(packname);
- }
+ /* The "did you use incorrect case?" warning used to be here.
+ * The problem is that on case-insensitive filesystems one
+ * might get false positives for "use" (and "require"):
+ * "use Strict" or "require CARP" will work. This causes
+ * portability problems for the script: in case-strict
+ * filesystems the script will stop working.
+ *
+ * The "incorrect case" warning checked whether "use Foo"
+ * imported "Foo" to your namespace, but that is wrong, too:
+ * there is no requirement nor promise in the language that
+ * a Foo.pm should or would contain anything in package "Foo".
+ *
+ * There is very little Configure-wise that can be done, either:
+ * the case-sensitivity of the build filesystem of Perl does not
+ * help in guessing the case-sensitivity of the runtime environment.
+ */
PL_hints |= HINT_BLOCK_SCOPE;
PL_copline = NOLINE;
OP *o;
if (optype) {
- if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) {
+ if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
return newLOGOP(optype, 0,
mod(scalar(left), optype),
newUNOP(OP_SASSIGN, 0, scalar(right)));
}
curop = list(force_list(left));
o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
- o->op_private = 0 | (flags >> 8);
- for (curop = ((LISTOP*)curop)->op_first;
- curop; curop = curop->op_sibling)
- {
- if (curop->op_type == OP_RV2HV &&
- ((UNOP*)curop)->op_first->op_type != OP_GV) {
- o->op_private |= OPpASSIGN_HASH;
- break;
- }
- }
+ o->op_private = (U8)(0 | (flags >> 8));
if (!(left->op_private & OPpLVAL_INTRO)) {
OP *lastop = o;
PL_generation++;
if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
if (curop->op_type == OP_GV) {
GV *gv = cGVOPx_gv(curop);
- if (gv == PL_defgv || SvCUR(gv) == PL_generation)
+ if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
break;
SvCUR(gv) = PL_generation;
}
curop->op_type == OP_PADANY) {
SV **svp = AvARRAY(PL_comppad_name);
SV *sv = svp[curop->op_targ];
- if (SvCUR(sv) == PL_generation)
+ if ((int)SvCUR(sv) == PL_generation)
break;
SvCUR(sv) = PL_generation; /* (SvCUR not used any more) */
}
#else
GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
#endif
- if (gv == PL_defgv || SvCUR(gv) == PL_generation)
+ if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
break;
SvCUR(gv) = PL_generation;
}
cop->op_type = OP_NEXTSTATE;
cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
}
- cop->op_flags = flags;
- cop->op_private = (PL_hints & HINT_PRIVATE_MASK);
+ cop->op_flags = (U8)flags;
+ cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
#ifdef NATIVE_HINTS
cop->op_private |= NATIVE_HINTS;
#endif
}
}
if (first->op_type == OP_CONST) {
- if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
- Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
+ if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE)) {
+ if (first->op_private & OPpCONST_STRICT)
+ no_bareword_allowed(first);
+ else
+ Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
+ }
if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
op_free(first);
*firstp = Nullop;
return first;
}
}
- else if (first->op_type == OP_WANTARRAY) {
- if (type == OP_AND)
- list(other);
- else
- scalar(other);
- }
else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
OP *k1 = ((UNOP*)first)->op_first;
OP *k2 = k1->op_sibling;
|| k1->op_type == OP_EACH)
{
warnop = ((k1->op_type == OP_NULL)
- ? k1->op_targ : k1->op_type);
+ ? (OPCODE)k1->op_targ : k1->op_type);
}
break;
}
if (!other)
return first;
- if (type == OP_ANDASSIGN || type == OP_ORASSIGN)
+ if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
NewOp(1101, logop, 1, LOGOP);
- logop->op_type = type;
+ logop->op_type = (OPCODE)type;
logop->op_ppaddr = PL_ppaddr[type];
logop->op_first = first;
logop->op_flags = flags | OPf_KIDS;
logop->op_other = LINKLIST(other);
- logop->op_private = 1 | (flags >> 8);
+ logop->op_private = (U8)(1 | (flags >> 8));
/* establish postfix order */
logop->op_next = LINKLIST(first);
scalarboolean(first);
if (first->op_type == OP_CONST) {
+ if (first->op_private & OPpCONST_BARE &&
+ first->op_private & OPpCONST_STRICT) {
+ no_bareword_allowed(first);
+ }
if (SvTRUE(((SVOP*)first)->op_sv)) {
op_free(first);
op_free(falseop);
return falseop;
}
}
- else if (first->op_type == OP_WANTARRAY) {
- list(trueop);
- scalar(falseop);
- }
NewOp(1101, logop, 1, LOGOP);
logop->op_type = OP_COND_EXPR;
logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
logop->op_first = first;
logop->op_flags = flags | OPf_KIDS;
- logop->op_private = 1 | (flags >> 8);
+ logop->op_private = (U8)(1 | (flags >> 8));
logop->op_other = LINKLIST(trueop);
logop->op_next = LINKLIST(falseop);
range->op_flags = OPf_KIDS;
leftstart = LINKLIST(left);
range->op_other = LINKLIST(right);
- range->op_private = 1 | (flags >> 8);
+ range->op_private = (U8)(1 | (flags >> 8));
left->op_sibling = right;
next = unstack;
cont = append_elem(OP_LINESEQ, cont, unstack);
if ((line_t)whileline != NOLINE) {
- PL_copline = whileline;
+ PL_copline = (line_t)whileline;
cont = append_elem(OP_LINESEQ, cont,
newSTATEOP(0, Nullch, Nullop));
}
redo = LINKLIST(listop);
if (expr) {
- PL_copline = whileline;
+ PL_copline = (line_t)whileline;
scalar(listop);
o = new_logop(OP_AND, 0, &expr, &listop);
if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
{
LOOP *loop;
OP *wop;
- int padoff = 0;
+ PADOFFSET padoff = 0;
I32 iterflags = 0;
if (sv) {
void
Perl_cv_undef(pTHX_ CV *cv)
{
+ CV *outsidecv;
+ CV *freecv = Nullcv;
+ bool is_eval = CvEVAL(cv) && !CvGV(cv); /* is this eval"" ? */
+
#ifdef USE_5005THREADS
if (CvMUTEXP(cv)) {
MUTEX_DESTROY(CvMUTEXP(cv));
}
SvPOK_off((SV*)cv); /* forget prototype */
CvGV(cv) = Nullgv;
+ outsidecv = CvOUTSIDE(cv);
/* Since closure prototypes have the same lifetime as the containing
* CV, they don't hold a refcount on the outside CV. This avoids
* the refcount loop between the outer CV (which keeps a refcount to
* the closure prototype in the pad entry for pp_anoncode()) and the
* closure prototype, and the ensuing memory leak. --GSAR */
if (!CvANON(cv) || CvCLONED(cv))
- SvREFCNT_dec(CvOUTSIDE(cv));
+ freecv = outsidecv;
CvOUTSIDE(cv) = Nullcv;
if (CvCONST(cv)) {
SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
if (CvPADLIST(cv)) {
/* may be during global destruction */
if (SvREFCNT(CvPADLIST(cv))) {
- I32 i = AvFILLp(CvPADLIST(cv));
- while (i >= 0) {
- SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
- SV* sv = svp ? *svp : Nullsv;
+ AV *padlist = CvPADLIST(cv);
+ I32 ix;
+ /* pads may be cleared out already during global destruction */
+ if ((is_eval && !PL_dirty) || CvSPECIAL(cv)) {
+ /* inner references to eval's cv must be fixed up */
+ AV *comppad_name = (AV*)AvARRAY(padlist)[0];
+ AV *comppad = (AV*)AvARRAY(padlist)[1];
+ SV **namepad = AvARRAY(comppad_name);
+ SV **curpad = AvARRAY(comppad);
+ for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
+ SV *namesv = namepad[ix];
+ if (namesv && namesv != &PL_sv_undef
+ && *SvPVX(namesv) == '&'
+ && ix <= AvFILLp(comppad))
+ {
+ CV *innercv = (CV*)curpad[ix];
+ if (innercv && SvTYPE(innercv) == SVt_PVCV
+ && CvOUTSIDE(innercv) == cv)
+ {
+ CvOUTSIDE(innercv) = outsidecv;
+ if (!CvANON(innercv) || CvCLONED(innercv)) {
+ (void)SvREFCNT_inc(outsidecv);
+ if (SvREFCNT(cv))
+ SvREFCNT_dec(cv);
+ }
+ }
+ }
+ }
+ }
+ if (freecv)
+ SvREFCNT_dec(freecv);
+ ix = AvFILLp(padlist);
+ while (ix >= 0) {
+ SV* sv = AvARRAY(padlist)[ix--];
if (!sv)
continue;
if (sv == (SV*)PL_comppad_name)
}
CvPADLIST(cv) = Nullav;
}
+ else if (freecv)
+ SvREFCNT_dec(freecv);
if (CvXSUB(cv)) {
CvXSUB(cv) = 0;
}
/* already defined (or promised)? */
if (exists || GvASSUMECV(gv)) {
if (!block && !attrs) {
+ if (CvFLAGS(PL_compcv)) {
+ /* might have had built-in attrs applied */
+ CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
+ }
/* just a "sub foo;" when &foo is already defined */
SAVEFREESV(PL_compcv);
goto done;
*/
if (cv && !block) {
rcv = (SV*)cv;
+ /* Might have had built-in attributes applied -- propagate them. */
+ CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
if (CvGV(cv) && GvSTASH(CvGV(cv)))
stash = GvSTASH(CvGV(cv));
else if (CvSTASH(cv))
call_list(oldscope, PL_beginav);
PL_curcop = &PL_compiling;
- PL_compiling.op_private = PL_hints;
+ PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
LEAVE;
}
else if (strEQ(s, "END") && !PL_error_count) {
GV_ADDMULTI, SVt_PVCV);
register CV *cv;
+ if (!subaddr)
+ Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
+
if ((cv = (name ? GvCV(gv) : Nullcv))) {
if (GvCVGEN(gv)) {
/* just a cached method */
OP *
Perl_ck_bitop(pTHX_ OP *o)
{
- o->op_private = PL_hints;
+ o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
return o;
}
badtype = "an ARRAY";
break;
case OP_RV2HV:
- if (svtype != SVt_PVHV) {
- if (svtype == SVt_PVAV) { /* pseudohash? */
- SV **ksv = av_fetch((AV*)rsv, 0, FALSE);
- if (ksv && SvROK(*ksv)
- && SvTYPE(SvRV(*ksv)) == SVt_PVHV)
- {
- break;
- }
- }
+ if (svtype != SVt_PVHV)
badtype = "a HASH";
- }
break;
case OP_RV2CV:
if (svtype != SVt_PVCV)
OP *newop = newGVOP(OP_GV, 0,
gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
SVt_PVIO) );
- if ((o->op_flags & OPf_KIDS) &&
+ if (!(o->op_private & 1) && /* if not unop */
kid == cLISTOPo->op_last)
cLISTOPo->op_last = newop;
op_free(kid);
kid->op_type = OP_PUSHRE;
kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
scalar(kid);
+ if (ckWARN(WARN_REGEXP) && ((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
+ Perl_warner(aTHX_ packWARN(WARN_REGEXP),
+ "Use of /g modifier is meaningless in split");
+ }
if (!kid->op_sibling)
append_elem(OP_SPLIT, o, newDEFSVOP());
Perl_peep(pTHX_ register OP *o)
{
register OP* oldop = 0;
- STRLEN n_a;
if (!o || o->op_seq)
return;
case OP_GREPWHILE:
case OP_AND:
case OP_OR:
+ case OP_DOR:
case OP_ANDASSIGN:
case OP_ORASSIGN:
+ case OP_DORASSIGN:
case OP_COND_EXPR:
case OP_RANGE:
o->op_seq = PL_op_seqmax++;
break;
case OP_HELEM: {
- UNOP *rop;
- SV *lexname;
- GV **fields;
- SV **svp, **indsvp, *sv;
- I32 ind;
+ SV *lexname;
+ SV **svp, *sv;
char *key = NULL;
STRLEN keylen;
SvREFCNT_dec(sv);
*svp = lexname;
}
-
- if ((o->op_private & (OPpLVAL_INTRO)))
- break;
-
- rop = (UNOP*)((BINOP*)o)->op_first;
- if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
- break;
- lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
- if (!(SvFLAGS(lexname) & SVpad_TYPED))
- break;
- fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
- if (!fields || !GvHV(*fields))
- break;
- key = SvPV(*svp, keylen);
- indsvp = hv_fetch(GvHV(*fields), key,
- SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
- if (!indsvp) {
- Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
- key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
- }
- ind = SvIV(*indsvp);
- if (ind < 1)
- Perl_croak(aTHX_ "Bad index while coercing array into hash");
- rop->op_type = OP_RV2AV;
- rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
- o->op_type = OP_AELEM;
- o->op_ppaddr = PL_ppaddr[OP_AELEM];
- sv = newSViv(ind);
- if (SvREADONLY(*svp))
- SvREADONLY_on(sv);
- SvFLAGS(sv) |= (SvFLAGS(*svp)
- & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
- SvREFCNT_dec(*svp);
- *svp = sv;
- break;
- }
-
- case OP_HSLICE: {
- UNOP *rop;
- SV *lexname;
- GV **fields;
- SV **svp, **indsvp, *sv;
- I32 ind;
- char *key;
- STRLEN keylen;
- SVOP *first_key_op, *key_op;
-
- o->op_seq = PL_op_seqmax++;
- if ((o->op_private & (OPpLVAL_INTRO))
- /* I bet there's always a pushmark... */
- || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
- /* hmmm, no optimization if list contains only one key. */
- break;
- rop = (UNOP*)((LISTOP*)o)->op_last;
- if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
- break;
- lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
- if (!(SvFLAGS(lexname) & SVpad_TYPED))
- break;
- fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
- if (!fields || !GvHV(*fields))
- break;
- /* Again guessing that the pushmark can be jumped over.... */
- first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
- ->op_first->op_sibling;
- /* Check that the key list contains only constants. */
- for (key_op = first_key_op; key_op;
- key_op = (SVOP*)key_op->op_sibling)
- if (key_op->op_type != OP_CONST)
- break;
- if (key_op)
- break;
- rop->op_type = OP_RV2AV;
- rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
- o->op_type = OP_ASLICE;
- o->op_ppaddr = PL_ppaddr[OP_ASLICE];
- for (key_op = first_key_op; key_op;
- key_op = (SVOP*)key_op->op_sibling) {
- svp = cSVOPx_svp(key_op);
- key = SvPV(*svp, keylen);
- indsvp = hv_fetch(GvHV(*fields), key,
- SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
- if (!indsvp) {
- Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
- "in variable %s of type %s",
- key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
- }
- ind = SvIV(*indsvp);
- if (ind < 1)
- Perl_croak(aTHX_ "Bad index while coercing array into hash");
- sv = newSViv(ind);
- if (SvREADONLY(*svp))
- SvREADONLY_on(sv);
- SvFLAGS(sv) |= (SvFLAGS(*svp)
- & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
- SvREFCNT_dec(*svp);
- *svp = sv;
- }
- break;
- }
+ break;
+ }
default:
o->op_seq = PL_op_seqmax++;
https://perl5.git.perl.org / perl5.git / blobdiff