(PL_in_my == KEY_our
/* $_ is always in main::, even with our */
? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
- : Nullhv
+ : NULL
),
0 /* not fake */
);
case OP_AND:
case OP_DOR:
case OP_COND_EXPR:
+ case OP_ENTERGIVEN:
+ case OP_ENTERWHEN:
for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
scalarvoid(kid);
break;
case OP_LEAVELOOP:
case OP_LINESEQ:
case OP_LIST:
+ case OP_LEAVEGIVEN:
+ case OP_LEAVEWHEN:
for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
scalarvoid(kid);
break;
return o;
}
-/* Propagate lvalue ("modifiable") context to an op and it's children.
+/* Propagate lvalue ("modifiable") context to an op and its children.
* 'type' represents the context type, roughly based on the type of op that
* would do the modifying, although local() is represented by OP_NULL.
* It's responsible for detecting things that can't be modified, flag
if ((type == OP_UNDEF || type == OP_REFGEN) &&
!(o->op_flags & OPf_STACKED)) {
o->op_type = OP_RV2CV; /* entersub => rv2cv */
+ /* The default is to set op_private to the number of children,
+ which for a UNOP such as RV2CV is always 1. And w're using
+ the bit for a flag in RV2CV, 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 */
newop->op_next = (OP*)newop;
kid->op_sibling = (OP*)newop;
newop->op_private |= OPpLVAL_INTRO;
+ newop->op_private &= ~1;
break;
}
okid->op_targ = 0;
okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
okid->op_private |= OPpLVAL_INTRO;
+ okid->op_private &= ~1;
break;
}
/* FALL THROUGH */
default:
nomod:
- /* grep, foreach, subcalls, refgen */
- if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
+ /* grep, foreach, subcalls, refgen, m//g */
+ if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN
+ || type == OP_MATCH)
break;
yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
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;
}
break;
STATIC OP *
S_dup_attrlist(pTHX_ OP *o)
{
- OP *rop = Nullop;
+ OP *rop;
/* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
* where the first kid is OP_PUSHMARK and the remaining ones
rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
else {
assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
+ rop = Nullop;
for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
if (o->op_type == OP_CONST)
rop = append_elem(OP_LIST, rop,
} else if (attrs) {
GV * const gv = cGVOPx_gv(cUNOPo->op_first);
PL_in_my = FALSE;
- PL_in_my_stash = Nullhv;
+ PL_in_my_stash = NULL;
apply_attrs(GvSTASH(gv),
(type == OP_RV2SV ? GvSV(gv) :
type == OP_RV2AV ? (SV*)GvAV(gv) :
HV *stash;
PL_in_my = FALSE;
- PL_in_my_stash = Nullhv;
+ PL_in_my_stash = NULL;
/* check for C<my Dog $spot> when deciding package */
stash = PAD_COMPNAME_TYPE(o->op_targ);
OP *
Perl_my_attrs(pTHX_ OP *o, OP *attrs)
{
- OP *rops = Nullop;
+ OP *rops;
int maybe_scalar = 0;
/* [perl #17376]: this appears to be premature, and results in code such as
#endif
if (attrs)
SAVEFREEOP(attrs);
+ rops = Nullop;
o = my_kid(o, attrs, &rops);
if (rops) {
if (maybe_scalar && o->op_type == OP_PADSV) {
o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
}
PL_in_my = FALSE;
- PL_in_my_stash = Nullhv;
+ PL_in_my_stash = NULL;
return o;
}
}
if (!(right->op_flags & OPf_STACKED) && ismatchop) {
right->op_flags |= OPf_STACKED;
- if (right->op_type != OP_MATCH &&
- ! (right->op_type == OP_TRANS &&
- right->op_private & OPpTRANS_IDENTICAL))
+ /* s/// and tr/// modify their arg.
+ * m//g also indirectly modifies the arg by setting pos magic on it */
+ if ( (right->op_type == OP_MATCH &&
+ (cPMOPx(right)->op_pmflags & PMf_GLOBAL))
+ || (right->op_type == OP_SUBST)
+ || (right->op_type == OP_TRANS &&
+ ! (right->op_private & OPpTRANS_IDENTICAL))
+ )
left = mod(left, right->op_type);
if (right->op_type == OP_TRANS)
o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
else
o = mod(o, OP_NULL); /* a bit kludgey */
PL_in_my = FALSE;
- PL_in_my_stash = Nullhv;
+ PL_in_my_stash = NULL;
return o;
}
{
if (o->op_type == OP_LIST) {
OP *o2;
- o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
+ o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", GV_ADD, SVt_PV))),
o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
}
return o;
/* XXX might want a ck_negate() for this */
cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
break;
- case OP_SPRINTF:
case OP_UCFIRST:
case OP_LCFIRST:
case OP_UC:
cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
{
/* convert single element list to element */
- OP* oe = expr;
+ OP* const oe = expr;
expr = cLISTOPx(oe)->op_first->op_sibling;
cLISTOPx(oe)->op_first->op_sibling = Nullop;
cLISTOPx(oe)->op_last = Nullop;
GV *gv = Nullgv;
if (!force_builtin) {
- gv = gv_fetchpv("do", FALSE, SVt_PVCV);
+ gv = gv_fetchpv("do", 0, SVt_PVCV);
if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
GV * const * const gvp = (GV**)hv_fetch(PL_globalstash, "do", 2, FALSE);
gv = gvp ? *gvp : Nullgv;
iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
sv->op_type = OP_RV2GV;
sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
+ if (cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
+ iterpflags |= OPpITER_DEF;
}
else if (sv->op_type == OP_PADSV) { /* private variable */
iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
}
else
Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
+ if (padoff && strEQ(PAD_COMPNAME_PV(padoff), "$_"))
+ iterpflags |= OPpITER_DEF;
}
else {
const I32 offset = pad_findmy("$_");
else {
padoff = offset;
}
+ iterpflags |= OPpITER_DEF;
}
if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
return o;
}
+/* if the condition is a literal array or hash
+ (or @{ ... } etc), make a reference to it.
+ */
+STATIC OP *
+S_ref_array_or_hash(pTHX_ OP *cond)
+{
+ if (cond
+ && (cond->op_type == OP_RV2AV
+ || cond->op_type == OP_PADAV
+ || cond->op_type == OP_RV2HV
+ || cond->op_type == OP_PADHV))
+
+ return newUNOP(OP_REFGEN,
+ 0, mod(cond, OP_REFGEN));
+
+ else
+ return cond;
+}
+
+/* These construct the optree fragments representing given()
+ and when() blocks.
+
+ entergiven and enterwhen are LOGOPs; the op_other pointer
+ points up to the associated leave op. We need this so we
+ can put it in the context and make break/continue work.
+ (Also, of course, pp_enterwhen will jump straight to
+ op_other if the match fails.)
+ */
+
+STATIC
+OP *
+S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
+ I32 enter_opcode, I32 leave_opcode,
+ PADOFFSET entertarg)
+{
+ LOGOP *enterop;
+ OP *o;
+
+ NewOp(1101, enterop, 1, LOGOP);
+ enterop->op_type = enter_opcode;
+ enterop->op_ppaddr = PL_ppaddr[enter_opcode];
+ enterop->op_flags = (U8) OPf_KIDS;
+ enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
+ enterop->op_private = 0;
+
+ o = newUNOP(leave_opcode, 0, (OP *) enterop);
+
+ if (cond) {
+ enterop->op_first = scalar(cond);
+ cond->op_sibling = block;
+
+ o->op_next = LINKLIST(cond);
+ cond->op_next = (OP *) enterop;
+ }
+ else {
+ /* This is a default {} block */
+ enterop->op_first = block;
+ enterop->op_flags |= OPf_SPECIAL;
+
+ o->op_next = (OP *) enterop;
+ }
+
+ CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
+ entergiven and enterwhen both
+ use ck_null() */
+
+ enterop->op_next = LINKLIST(block);
+ block->op_next = enterop->op_other = o;
+
+ return o;
+}
+
+/* Does this look like a boolean operation? For these purposes
+ a boolean operation is:
+ - a subroutine call [*]
+ - a logical connective
+ - a comparison operator
+ - a filetest operator, with the exception of -s -M -A -C
+ - defined(), exists() or eof()
+ - /$re/ or $foo =~ /$re/
+
+ [*] possibly surprising
+ */
+STATIC
+bool
+S_looks_like_bool(pTHX_ OP *o)
+{
+ switch(o->op_type) {
+ case OP_OR:
+ return looks_like_bool(cLOGOPo->op_first);
+
+ case OP_AND:
+ return (
+ looks_like_bool(cLOGOPo->op_first)
+ && looks_like_bool(cLOGOPo->op_first->op_sibling));
+
+ case OP_ENTERSUB:
+
+ case OP_NOT: case OP_XOR:
+ /* Note that OP_DOR is not here */
+
+ case OP_EQ: case OP_NE: case OP_LT:
+ case OP_GT: case OP_LE: case OP_GE:
+
+ case OP_I_EQ: case OP_I_NE: case OP_I_LT:
+ case OP_I_GT: case OP_I_LE: case OP_I_GE:
+
+ case OP_SEQ: case OP_SNE: case OP_SLT:
+ case OP_SGT: case OP_SLE: case OP_SGE:
+
+ case OP_SMARTMATCH:
+
+ case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
+ case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
+ case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
+ case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
+ case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
+ case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
+ case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
+ case OP_FTTEXT: case OP_FTBINARY:
+
+ case OP_DEFINED: case OP_EXISTS:
+ case OP_MATCH: case OP_EOF:
+
+ return TRUE;
+
+ case OP_CONST:
+ /* Detect comparisons that have been optimized away */
+ if (cSVOPo->op_sv == &PL_sv_yes
+ || cSVOPo->op_sv == &PL_sv_no)
+
+ return TRUE;
+
+ /* FALL THROUGH */
+ default:
+ return FALSE;
+ }
+}
+
+OP *
+Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
+{
+ assert( cond );
+ return newGIVWHENOP(
+ ref_array_or_hash(cond),
+ block,
+ OP_ENTERGIVEN, OP_LEAVEGIVEN,
+ defsv_off);
+}
+
+/* If cond is null, this is a default {} block */
+OP *
+Perl_newWHENOP(pTHX_ OP *cond, OP *block)
+{
+ bool cond_llb = (!cond || looks_like_bool(cond));
+ OP *cond_op;
+
+ if (cond_llb)
+ cond_op = cond;
+ else {
+ cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
+ newDEFSVOP(),
+ scalar(ref_array_or_hash(cond)));
+ }
+
+ return newGIVWHENOP(
+ cond_op,
+ append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
+ OP_ENTERWHEN, OP_LEAVEWHEN, 0);
+}
+
/*
=for apidoc cv_undef
SV *
Perl_cv_const_sv(pTHX_ CV *cv)
{
- if (!cv || !CvCONST(cv))
- return Nullsv;
- return (SV*)CvXSUBANY(cv).any_ptr;
+ if (!cv)
+ return NULL;
+ if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
+ return NULL;
+ return CvCONST(cv) ? (SV*)CvXSUBANY(cv).any_ptr : NULL;
}
/* op_const_sv: examine an optree to determine whether it's in-lineable.
if (name || aname) {
const char *s;
- const char *tname = (name ? name : aname);
+ const char * const tname = (name ? name : aname);
if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
SV * const sv = NEWSV(0,0);
goto done;
if (strEQ(s, "BEGIN") && !PL_error_count) {
- dSP;
const I32 oldscope = PL_scopestack_ix;
ENTER;
- PUSHSTACKi(PERLSI_REQUIRE);
SAVECOPFILE(&PL_compiling);
SAVECOPLINE(&PL_compiling);
PL_curcop = &PL_compiling;
PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
- POPSTACK;
LEAVE;
}
else if (strEQ(s, "END") && !PL_error_count) {
Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
{
register CV *cv;
- GV *gv;
- if (o)
- gv = gv_fetchsv(cSVOPo->op_sv, TRUE, SVt_PVFM);
- else
- gv = gv_fetchpv("STDOUT", TRUE, SVt_PVFM);
-
+ GV * const gv = o
+ ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
+ : gv_fetchpv("STDOUT", GV_ADD, SVt_PVFM);
+
#ifdef GV_UNIQUE_CHECK
if (GvUNIQUE(gv)) {
Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
OP *
Perl_ck_concat(pTHX_ OP *o)
{
- const OP *kid = cUNOPo->op_first;
+ const OP * const kid = cUNOPo->op_first;
if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
!(kUNOP->op_first->op_flags & OPf_MOD))
o->op_flags |= OPf_STACKED;
o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
}
o->op_targ = (PADOFFSET)PL_hints;
+ if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
+ /* Store a copy of %^H that pp_entereval can pick up */
+ OP *hhop = newSVOP(OP_CONST, 0, (SV*)newHVhv(GvHV(PL_hintgv)));
+ cUNOPo->op_first->op_sibling = hhop;
+ o->op_private |= OPpEVAL_HAS_HH;
+ }
return o;
}
Perl_ck_rvconst(pTHX_ register OP *o)
{
dVAR;
- SVOP *kid = (SVOP*)cUNOPo->op_first;
+ SVOP * const kid = (SVOP*)cUNOPo->op_first;
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;
GV *gv;
/* Is it a constant from cv_const_sv()? */
if (SvROK(kidsv) && SvREADONLY(kidsv)) {
- SV *rsv = SvRV(kidsv);
+ SV * const rsv = SvRV(kidsv);
const int svtype = SvTYPE(rsv);
const char *badtype = Nullch;
if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
OP * const newop = newGVOP(type, OPf_REF,
- gv_fetchsv(kid->op_sv, TRUE, SVt_PVIO));
+ gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
op_free(o);
o = newop;
return o;
(kid->op_private & OPpCONST_BARE))
{
OP * const newop = newAVREF(newGVOP(OP_GV, 0,
- gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVAV) ));
+ gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
"Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
(kid->op_private & OPpCONST_BARE))
{
OP * const newop = newHVREF(newGVOP(OP_GV, 0,
- gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVHV) ));
+ gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
"Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
if (kid->op_type == OP_CONST &&
(kid->op_private & OPpCONST_BARE))
{
- OP *newop = newGVOP(OP_GV, 0,
- gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVIO) );
+ OP * const newop = newGVOP(OP_GV, 0,
+ gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
if (!(o->op_private & 1) && /* if not unop */
kid == cLISTOPo->op_last)
cLISTOPo->op_last = newop;
else if (kid->op_type == OP_RV2SV
&& kUNOP->op_first->op_type == OP_GV)
{
- GV *gv = cGVOPx_gv(kUNOP->op_first);
+ GV * const gv = cGVOPx_gv(kUNOP->op_first);
name = GvNAME(gv);
len = GvNAMELEN(gv);
}
if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
append_elem(OP_GLOB, o, newDEFSVOP());
- if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
+ if (!((gv = gv_fetchpv("glob", 0, SVt_PVCV))
&& GvCVu(gv) && GvIMPORTED_CV(gv)))
{
- gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
+ gv = gv_fetchpv("CORE::GLOBAL::glob", 0, SVt_PVCV);
}
#if !defined(PERL_EXTERNAL_GLOB)
ENTER;
Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
- gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
- glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
+ gv = gv_fetchpv("CORE::GLOBAL::glob", 0, SVt_PVCV);
+ glob_gv = gv_fetchpv("File::Glob::csh_glob", 0, SVt_PVCV);
GvCV(gv) = GvCV(glob_gv);
(void)SvREFCNT_inc((SV*)GvCV(gv));
GvIMPORTED_CV_on(gv);
}
OP *
+Perl_ck_say(pTHX_ OP *o)
+{
+ o = ck_listiob(o);
+ o->op_type = OP_PRINT;
+ cLISTOPo->op_last = cLISTOPo->op_last->op_sibling
+ = newSVOP(OP_CONST, 0, newSVpvn("\n", 1));
+ return o;
+}
+
+OP *
+Perl_ck_smartmatch(pTHX_ OP *o)
+{
+ if (0 == (o->op_flags & OPf_SPECIAL)) {
+ OP *first = cBINOPo->op_first;
+ OP *second = first->op_sibling;
+
+ /* Implicitly take a reference to an array or hash */
+ first->op_sibling = Nullop;
+ first = cBINOPo->op_first = ref_array_or_hash(first);
+ second = first->op_sibling = ref_array_or_hash(second);
+
+ /* Implicitly take a reference to a regular expression */
+ if (first->op_type == OP_MATCH) {
+ first->op_type = OP_QR;
+ first->op_ppaddr = PL_ppaddr[OP_QR];
+ }
+ if (second->op_type == OP_MATCH) {
+ second->op_type = OP_QR;
+ second->op_ppaddr = PL_ppaddr[OP_QR];
+ }
+ }
+
+ return o;
+}
+
+
+OP *
Perl_ck_sassign(pTHX_ OP *o)
{
OP *kid = cLISTOPo->op_first;
OP *
Perl_ck_match(pTHX_ OP *o)
{
- if (o->op_type != OP_QR) {
+ if (o->op_type != OP_QR && PL_compcv) {
const I32 offset = pad_findmy("$_");
if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS(offset) & SVpad_OUR)) {
o->op_targ = offset;
if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
/* handle override, if any */
- gv = gv_fetchpv("require", FALSE, SVt_PVCV);
+ gv = gv_fetchpv("require", 0, SVt_PVCV);
if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
GV * const * const gvp = (GV**)hv_fetch(PL_globalstash, "require", 7, FALSE);
gv = gvp ? *gvp : Nullgv;
{
OP *firstkid;
+ if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0)
+ {
+ HV *hinthv = GvHV(PL_hintgv);
+ if (hinthv) {
+ SV **svp = hv_fetch(hinthv, "sort", 4, 0);
+ if (svp) {
+ I32 sorthints = (I32)SvIV(*svp);
+ if ((sorthints & HINT_SORT_QUICKSORT) != 0)
+ o->op_private |= OPpSORT_QSORT;
+ if ((sorthints & HINT_SORT_STABLE) != 0)
+ o->op_private |= OPpSORT_STABLE;
+ }
+ }
+ }
+
if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
simplify_sort(o);
firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
const char *gvname;
if (!(o->op_flags & OPf_STACKED))
return;
- GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
- GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
+ GvMULTI_on(gv_fetchpv("a", GV_ADD, SVt_PV));
+ GvMULTI_on(gv_fetchpv("b", GV_ADD, SVt_PV));
kid = kUNOP->op_first; /* get past null */
if (kid->op_type != OP_SCOPE)
return;
break;
case ']':
if (contextclass) {
+ /* XXX We shouldn't be modifying proto, so we can const proto */
char *p = proto;
const char s = *p;
contextclass = 0;
case OP_PADAV:
case OP_GV:
if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
- OP* pop = (o->op_type == OP_PADAV) ?
+ OP* const pop = (o->op_type == OP_PADAV) ?
o->op_next : o->op_next->op_next;
IV i;
if (pop && pop->op_type == OP_CONST &&
break;
}
+
+ case OP_SASSIGN: {
+ OP *rv2gv;
+ UNOP *refgen, *rv2cv;
+ LISTOP *exlist;
+
+ /* I do not understand this, but if o->op_opt isn't set to 1,
+ various tests in ext/B/t/bytecode.t fail with no readily
+ apparent cause. */
+
+ o->op_opt = 1;
+
+ if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
+ break;
+
+ rv2gv = ((BINOP *)o)->op_last;
+ if (!rv2gv || rv2gv->op_type != OP_RV2GV)
+ break;
+
+ refgen = (UNOP *)((BINOP *)o)->op_first;
+
+ if (!refgen || refgen->op_type != OP_REFGEN)
+ break;
+
+ exlist = (LISTOP *)refgen->op_first;
+ if (!exlist || exlist->op_type != OP_NULL
+ || exlist->op_targ != OP_LIST)
+ break;
+
+ if (exlist->op_first->op_type != OP_PUSHMARK)
+ break;
+
+ rv2cv = (UNOP*)exlist->op_last;
+
+ if (rv2cv->op_type != OP_RV2CV)
+ break;
+
+ assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
+ assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
+ assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
+
+ o->op_private |= OPpASSIGN_CV_TO_GV;
+ rv2gv->op_private |= OPpDONT_INIT_GV;
+ rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
+
+ break;
+ }
+
default:
o->op_opt = 1;
https://perl5.git.perl.org / perl5.git / blobdiff